Merge pull request #1022 from MikeSS8/typo

fix typo

.githooks/pre-commit

@@ -0,0 +1,30 @@
+#!/bin/bash
+
+if git rev-parse --verify HEAD >/dev/null 2>&1; then
+    against=HEAD
+else
+    # Initial commit: diff against an empty tree object
+    against=4b825dc642cb6eb9a060e54bf8d69288fbee4904
+fi
+
+# fail if we add any new lines to C or Scheme source containing a tab
+if git diff --name-only "$against" | egrep -q '\.(cpp|h|scm|sld|stub)$' &&\
+        git diff --name-only "$against" |\
+        egrep '\.(cpp|h|scm|sld|stub)$' |\
+        xargs -d'\n' git diff -U0 --no-color "$against" -- |\
+        grep -q $'^+ *\t'; then
+    echo "Error: Attempting to add a source file using tabs for indentation."
+    echo
+    echo -n "   "
+    git diff --name-only "$against" |\
+        egrep '\.(cpp|h|scm|sld|stub)$' |\
+        xargs -d'\n' git diff -U0 "$against" -- |\
+        grep $'^+ *\t' | head -1
+    echo
+    cat <<EOF
+It's important for arguments to line up vertically to a precise column.
+Since there is no standard tab width, using tabs for indentation makes
+this impossible in general.  Please use spaces.
+EOF
+    exit 1
+fi

.github/workflows/CI.yaml

@@ -0,0 +1,23 @@
+name: CI
+
+on: [push, pull_request]
+
+jobs:
+  build:
+    name: ${{ matrix.os }}
+    runs-on: ${{ matrix.os }}
+    strategy:
+      matrix:
+        os: [ubuntu-latest, macos-latest]
+              
+    steps:
+      - uses: actions/checkout@v2
+      - name: Build
+        run: make # assumes GNUMake
+      - name: Test
+        run: make test-all
+      - name: Setup
+        run: sudo make install
+      - name: Run in PATH
+        run: chibi-scheme r7rs-tests.scm
+        working-directory: tests

.gitignore

@@ -1,5 +1,6 @@
 # Object files
 *.o
+*.bc
 *.ko
 *.obj
 *.elf
@@ -16,6 +17,7 @@
 
 # Shared objects (inc. Windows DLLs)
 *.dll
+*.dll.*
 *.so
 *.so.*
 *.dylib
@@ -36,6 +38,7 @@ lib/.*.meta
 
 # Generated files
 chibi-scheme
+chibi-scheme-emscripten
 chibi-scheme.pc
 include/chibi/install.h
 lib/chibi/emscripten.c
@@ -43,12 +46,30 @@ lib/chibi/filesystem.c
 lib/chibi/io/io.c
 lib/chibi/net.c
 lib/chibi/process.c
+lib/chibi/pty.c
+lib/chibi/snow/install.sld
 lib/chibi/stty.c
 lib/chibi/system.c
 lib/chibi/time.c
+lib/chibi/win32/process-win32.c
+lib/scheme/bytevector.c
+lib/srfi/144/math.c
+lib/srfi/160/uvprims.c
 *.tgz
+*.bz2
+*.xz
 *.html
+*.img
+*.err
+*.fasl
+*.txt
+!CMakeLists.txt
+*.test
+*.train
+*.h5
+!index.html
 
+benchmarks/gabriel/times.tsv
 examples/snow-fort
 examples/synthcode
 tests/snow/repo-cache
@@ -58,3 +79,8 @@ tmp
 /lib/chibi/crypto/crypto.c
 /chibi-scheme-ulimit
 /clibs.c
+
+js/chibi.*
+
+build-lib/chibi/char-set/derived.scm
+build-lib/chibi/char-set/width.scm

.travis.yml

@@ -0,0 +1,4 @@
+language: c
+compiler:
+  - clang
+  - gcc

AUTHORS

@@ -1,6 +1,11 @@
 Alex Shinn wrote the initial version of chibi-scheme and all
 distributed modules.
 
+The Emscripten build, syntax-case and SRFI 139 implementation, and
+various other patches were contributed by Marc Nieper-Wißkirchen.
+
+The image handling code in gc_heap.c was written by Chris Walsh.
+
 The `dynamic-wind' implementation is adapted from the implementation
 in the appendix to the Scheme48 reference manual, reportedly first
 written by Chris Hanson and John Lamping.
@@ -9,6 +14,17 @@ The (scheme time) module includes code for handling leap seconds
 from Alan Watson's Scheme clock library at
 http://code.google.com/p/scheme-clock/ under the same license.
 
+The lgamma_r implementation for Windows builds is based on code by
+Haruhiko Okumura via Ruby.
+
+The following distributed SRFIs use the reference implementations:
+
+  (srfi 101) is adapted from David van Horn's implementation
+  (srfi 134) is Shiro Kawai's implementation
+  (srfi 135) is Will Clinger's implementation
+  (srfi 139), (srfi 146), (srfi 154), (srfi 165) are Marc Nieper-Wißkirchen's implementations
+  (srfi 146 hash) is Arthur Gleckler's Hash Array Mapped Trie implementation
+
 The benchmarks are based on the Racket versions of the classic
 Gabriel benchmarks from
 http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html.
@@ -16,36 +32,58 @@ They are not installed or needed but are included for convenience.
 
 Thanks to the following people for patches and bug reports:
 
+  * Adam Feuer
   * Alan Watson
   * Alexei Lozovsky
   * Alexander Shendi
   * Andreas Rottman
+  * Arthur Gleckler
   * Bakul Shah
+  * Ben Davenport-Ray
   * Ben Mather
   * Ben Weaver
+  * Bertrand Augereau
+  * Bradley Lucier
   * Bruno Deferrari
+  * Damien Diederen
+  * Daphne Preston-Kendal
   * Doug Currie
   * Derrick Eddington
   * Dmitry Chestnykh
   * Eduardo Cavazos
+  * Ekaitz Zarraga
   * Felix Winkelmann
   * Gregor Klinke
   * Jeremy Wolff
   * Jeronimo Pellegrini
   * John Cowan
   * John Samsa
+  * Jonas Rinke
+  * Kris Katterjohn
   * Lars J Aas
+  * Lassi Kortela
   * Lorenzo Campedelli
+  * Lukas Böger
   * Marc Nieper-Wißkirchen
+  * McKay Marston
   * Meng Zhang
   * Michal Kowalski (sladegen)
   * Miroslav Urbanek
+  * Naoki Koguro
+  * Nguyễn Thái Ngọc Duy
+  * Petteri Piiroinen
   * Rajesh Krishnan
+  * Ricardo G. Herdt
+  * Roger Crew
   * Seth Alves
+  * Sören Tempel
   * Stephen Lewis
   * Taylor Venable
   * Travis Cross
-  * Zhang Meng
+  * Vasilij Schneidermann
+  * Vitaliy Mysak
+  * Yota Toyama
+  * Yuki Okumura
 
 If you would prefer not to be listed, or are one of the users listed
 without a full name, please contact me.  If you've made a contribution

CMakeLists.txt

@@ -0,0 +1,603 @@
+
+cmake_minimum_required(VERSION 3.12)
+
+file(READ ${CMAKE_CURRENT_SOURCE_DIR}/VERSION version)
+string(STRIP ${version} version)
+
+file(READ ${CMAKE_CURRENT_SOURCE_DIR}/RELEASE release)
+string(STRIP ${release} release)
+
+project(chibi-scheme LANGUAGES C VERSION ${version}
+    DESCRIPTION "Chibi-Scheme: minimal r7rs implementation, release: ${release}")
+
+include(CheckIncludeFile)
+include(CheckSymbolExists)
+include(GNUInstallDirs)
+include(CMakePackageConfigHelpers)
+
+set(CMAKE_EXPORT_COMPILE_COMMANDS ON)
+
+set(CMAKE_BUILD_TYPE "${CMAKE_BUILD_TYPE}" CACHE STRING
+    "Build type: None, Debug, Release, RelWithDebInfo, MinSizeRel, or Sanitizer." FORCE)
+
+if (NOT EXISTS ${CMAKE_BINARY_DIR}/CMakeCache.txt AND NOT CMAKE_BUILD_TYPE)
+    # CMake doesn't have a default build type, so set one manually
+    set(CMAKE_BUILD_TYPE "RelWithDebInfo" CACHE STRING "" FORCE)
+endif()
+
+#
+# Features
+#
+
+check_include_file(poll.h HAVE_POLL_H)
+check_symbol_exists(ntp_gettime sys/timex.h HAVE_NTP_GETTIME)
+check_symbol_exists(int_least8_t inttypes.h HAVE_STDINT_H)
+
+if (WIN32 AND NOT CYGWIN)
+    set(DEFAULT_SHARED_LIBS OFF)
+else()
+    set(DEFAULT_SHARED_LIBS ON)
+endif()
+
+option(BUILD_SHARED_LIBS "Build chibi-scheme as a shared library" ${DEFAULT_SHARED_LIBS})
+option(SEXP_USE_BOEHM "Use Boehm garbage collection library" OFF)
+
+if(SEXP_USE_BOEHM)
+    find_library(BOEHMGC gc REQUIRED)
+    find_path(BOEHMGC_INCLUDE NAMES gc/gc.h)
+endif()
+
+set(chibi-scheme-exclude-modules)
+if(WIN32)
+    set(chibi-scheme-exclude-modules
+        # Following modules are not compatible with Win32
+        lib/chibi/net.sld
+        lib/chibi/process.sld
+        lib/chibi/stty.sld
+        lib/chibi/system.sld
+        lib/chibi/time.sld
+        lib/chibi/pty.sld)
+endif()
+
+#
+# Default settings for all targets. We use an interface library here to not
+# pollute/mutate global settings. Any configuration applied to this library
+# is propagated to its client targets.
+#
+
+add_library(libchibi-common
+    INTERFACE)
+
+target_compile_definitions(libchibi-common
+    INTERFACE
+    SEXP_STATIC_LIBRARY=$<NOT:$<BOOL:${BUILD_SHARED_LIBS}>>
+    SEXP_USE_DL=$<BOOL:${BUILD_SHARED_LIBS}>
+    $<$<PLATFORM_ID:Windows>:BUILDING_DLL=$<BOOL:${BUILD_SHARED_LIBS}>>
+    SEXP_USE_INTTYPES=$<BOOL:${HAVE_STDINT_H}>
+    SEXP_USE_NTPGETTIME=$<BOOL:${HAVE_NTP_GETTIME}>
+    $<$<NOT:$<BOOL:${HAVE_POLL_H}>>:SEXP_USE_GREEN_THREADS=0>
+    $<$<PLATFORM_ID:Windows>:SEXP_USE_STRING_STREAMS=0>
+    $<$<BOOL:${SEXP_USE_BOEHM}>:SEXP_USE_BOEHM=1>)
+
+target_compile_options(libchibi-common
+    INTERFACE
+    $<$<C_COMPILER_ID:GNU>:-Wall>
+    $<$<OR:$<C_COMPILER_ID:AppleClang>,$<C_COMPILER_ID:Clang>>:-Wall>
+    $<$<CONFIG:SANITIZER>:-g
+    -fsanitize=address,undefined,integer,float-divide-by-zero,float-cast-overflow,return
+    -fno-omit-frame-pointer>)
+
+target_include_directories(libchibi-common
+    INTERFACE
+    ${BOEHMGC_INCLUDE}
+    $<BUILD_INTERFACE:${CMAKE_CURRENT_SOURCE_DIR}/include>
+    $<BUILD_INTERFACE:${CMAKE_CURRENT_BINARY_DIR}/include>
+    $<INSTALL_INTERFACE:${CMAKE_INSTALL_INCLUDEDIR}>)
+
+target_link_libraries(libchibi-common INTERFACE
+    ${BOEHMGC}
+    $<$<CONFIG:SANITIZER>:-fsanitize=address,undefined>
+    $<$<PLATFORM_ID:Windows>:ws2_32>
+    $<$<AND:$<PLATFORM_ID:Linux>,$<BOOL:${BUILD_SHARED_LIBS}>>:${CMAKE_DL_LIBS}>
+    $<$<PLATFORM_ID:Linux>:m>)
+
+#
+# Sources
+#
+
+set(chibi-scheme-srcs
+    # SEXP
+    gc.c
+    sexp.c
+    bignum.c
+    gc_heap.c
+
+    # Eval
+    opcodes.c
+    vm.c
+    eval.c
+    simplify.c)
+
+#
+# Bootstrap
+#
+
+add_executable(chibi-scheme-bootstrap
+    EXCLUDE_FROM_ALL
+    ${chibi-scheme-srcs}
+    main.c)
+
+target_link_libraries(chibi-scheme-bootstrap PRIVATE libchibi-common)
+
+
+#
+# Core library
+#
+
+add_library(libchibi-scheme
+    ${chibi-scheme-srcs})
+
+target_link_libraries(libchibi-scheme
+    PUBLIC libchibi-common)
+
+set_target_properties(libchibi-scheme
+    PROPERTIES
+    PREFIX "" # It's liblibchibi-scheme otherwise
+    SOVERSION ${CMAKE_PROJECT_VERSION_MAJOR}
+    VERSION ${CMAKE_PROJECT_VERSION})
+
+
+#
+# Generate modules
+#
+
+file(GLOB_RECURSE slds RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}
+    CONFIGURE_DEPENDS lib/*.sld)
+if (chibi-scheme-exclude-modules)
+    # CMake doesn't complain anymore about an empty 2nd argument, but 3.12 does. When we require a
+    # more recent version, the if-guard should go.
+    list(REMOVE_ITEM slds ${chibi-scheme-exclude-modules})
+endif()
+
+set(chibi-ffi ${CMAKE_CURRENT_SOURCE_DIR}/tools/chibi-ffi)
+set(chibi-genstatic ${CMAKE_CURRENT_SOURCE_DIR}/tools/chibi-genstatic)
+
+add_custom_target(chibi-compiled-libs)
+
+function(add_compiled_library cfile)
+    if (NOT BUILD_SHARED_LIBS)
+        return()
+    endif()
+
+    set(link-libraries LINK_LIBRARIES)
+    cmake_parse_arguments(compiledlib-options "" "" "${link-libraries}" ${ARGN})
+
+    get_filename_component(basename ${cfile} NAME_WE)
+    get_filename_component(libdir ${cfile} DIRECTORY)
+
+    if(NOT IS_ABSOLUTE ${libdir})
+        set(libdir ${CMAKE_CURRENT_BINARY_DIR}/${libdir})
+    endif()
+
+    file(RELATIVE_PATH libname ${CMAKE_CURRENT_BINARY_DIR} ${libdir}/${basename})
+    string(REPLACE "/" "-" libname ${libname})
+
+    add_library(${libname} ${cfile})
+    target_link_libraries(${libname} PRIVATE libchibi-scheme ${compiledlib-options_LINK_LIBRARIES})
+    add_dependencies(chibi-compiled-libs ${libname})
+
+    set_target_properties(${libname} PROPERTIES
+        LIBRARY_OUTPUT_DIRECTORY ${libdir}
+        LIBRARY_OUTPUT_NAME ${basename}
+        PREFIX "")
+
+    file(RELATIVE_PATH installsubdir ${CMAKE_CURRENT_BINARY_DIR}/lib ${libdir})
+    install(TARGETS ${libname}
+        LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}/chibi/${installsubdir})
+endfunction()
+
+if(BUILD_SHARED_LIBS)
+    # This makes sure we only use the separate bootstrap executable for static
+    # builds. With dynamic linking, the default executable is fine. The dispatch
+    # is not a generator expression within the actual custom command to process
+    # the stubs, as older CMake versions fail to properly construct the dependency
+    # on the bootstrap executable from the generator expression.
+    set(bootstrap chibi-scheme)
+else()
+    set(bootstrap chibi-scheme-bootstrap)
+endif()
+
+function(add_stubs_library stub)
+    set(link-libraries LINK_LIBRARIES)
+    cmake_parse_arguments(stubs-options "" "" "${link-libraries}" ${ARGN})
+
+    get_filename_component(stubdir ${stub} PATH)
+    get_filename_component(basename ${stub} NAME_WE)
+    set(stubfile ${CMAKE_CURRENT_SOURCE_DIR}/${stub})
+    set(stubdir ${CMAKE_CURRENT_BINARY_DIR}/${stubdir})
+    set(stubout ${stubdir}/${basename}.c)
+    set(stubouts ${stubouts} ${stubout} PARENT_SCOPE)
+    set(stublinkedlibs ${stublinkedlibs} ${stubs-options_LINK_LIBRARIES} PARENT_SCOPE)
+
+    file(MAKE_DIRECTORY ${stubdir})
+
+    add_custom_command(OUTPUT ${stubout}
+        COMMAND ${bootstrap} ${chibi-ffi} ${stubfile} ${stubout}
+        DEPENDS ${stubfile} ${chibi-ffi}
+        WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+
+    add_compiled_library(${stubout} LINK_LIBRARIES ${stubs-options_LINK_LIBRARIES})
+endfunction()
+
+add_stubs_library(lib/chibi/crypto/crypto.stub)
+add_stubs_library(lib/chibi/emscripten.stub)
+add_stubs_library(lib/chibi/filesystem.stub)
+add_stubs_library(lib/chibi/io/io.stub)
+add_stubs_library(lib/scheme/bytevector.stub)
+add_stubs_library(lib/srfi/144/math.stub)
+add_stubs_library(lib/srfi/160/uvprims.stub)
+
+if(NOT WIN32)
+    add_stubs_library(lib/chibi/net.stub)
+    add_stubs_library(lib/chibi/process.stub)
+    add_stubs_library(lib/chibi/pty.stub LINK_LIBRARIES util)
+    add_stubs_library(lib/chibi/stty.stub)
+    add_stubs_library(lib/chibi/system.stub)
+    add_stubs_library(lib/chibi/time.stub)
+else()
+    add_stubs_library(lib/chibi/win32/process-win32.stub)
+endif()
+
+add_custom_target(chibi-scheme-stubs DEPENDS ${stubouts})
+
+if (NOT BUILD_SHARED_LIBS)
+    add_dependencies(libchibi-scheme chibi-scheme-stubs)
+endif()
+
+add_compiled_library(lib/chibi/weak.c)
+add_compiled_library(lib/chibi/heap-stats.c)
+add_compiled_library(lib/chibi/disasm.c)
+add_compiled_library(lib/chibi/ast.c)
+add_compiled_library(lib/chibi/json.c)
+add_compiled_library(lib/srfi/18/threads.c)
+add_compiled_library(lib/chibi/optimize/rest.c)
+add_compiled_library(lib/chibi/optimize/profile.c)
+add_compiled_library(lib/srfi/27/rand.c)
+add_compiled_library(lib/srfi/151/bit.c)
+add_compiled_library(lib/srfi/39/param.c)
+add_compiled_library(lib/srfi/69/hash.c)
+add_compiled_library(lib/srfi/95/qsort.c)
+add_compiled_library(lib/srfi/98/env.c)
+add_compiled_library(lib/scheme/time.c)
+
+#
+# Generate clib.c for SEXP_USE_STATIC_LIBS
+#
+
+if (NOT BUILD_SHARED_LIBS)
+    string(REPLACE ";" "\n" genstatic-input "${slds}")
+    set(clibin ${CMAKE_CURRENT_BINARY_DIR}/clib-in.txt)
+    set(clibout ${CMAKE_CURRENT_BINARY_DIR}/clib.c)
+    set(genstatic-helper
+        ${CMAKE_CURRENT_LIST_DIR}/contrib/chibi-genstatic-helper.cmake)
+    file(WRITE ${clibin} "${genstatic-input}")
+
+    add_custom_command(OUTPUT ${clibout}
+        COMMAND
+        ${CMAKE_COMMAND}
+        -DEXEC=$<TARGET_FILE:chibi-scheme-bootstrap>
+        -DGENSTATIC=${chibi-genstatic}
+        -DSTUBS=${clibin}
+        -DOUT=${clibout}
+        -P ${genstatic-helper}
+        WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
+        DEPENDS
+        chibi-scheme-bootstrap
+        ${chibi-genstatic}
+        ${genstatic-helper}
+        ${slds})
+
+    # The generated file will #include both manually written files in
+    # the source directory as well as files generated by chibi-ffi in
+    # the build directory. The latter can be found without special flags,
+    # as they are relative to the clib.c, but the preprocessor needs
+    # help for the former. As only clib.c needs this flag, we set it
+    # as locally as possible, i.e., not as a target property.
+    set_source_files_properties(${clibout}
+        PROPERTIES
+        INCLUDE_DIRECTORIES
+        ${CMAKE_CURRENT_SOURCE_DIR})
+
+    target_compile_definitions(libchibi-scheme
+        PUBLIC
+        SEXP_USE_STATIC_LIBS=1)
+
+    target_sources(libchibi-scheme
+        PRIVATE
+        ${clibout})
+
+    target_link_libraries(libchibi-scheme
+        PRIVATE
+        ${stublinkedlibs})
+endif()
+
+#
+# Interpreter
+#
+
+add_executable(chibi-scheme
+    main.c)
+
+target_link_libraries(chibi-scheme
+    PRIVATE libchibi-scheme)
+
+#
+# Generate "chibi/install.h"
+#
+
+if(WIN32)
+    set(platform "windows")
+elseif(CYGWIN)
+    set(platform "cygwin")
+elseif(APPLE)
+    set(platform "macosx")
+elseif(CMAKE_SYSTEM MATCHES "[Bb][Ss][Dd]")
+    set(platform "bsd")
+elseif(CMAKE_SYSTEM MATCHES "[Aa]ndroid")
+    set(platform "android")
+elseif(CMAKE_SYSTEM MATCHES "[Ss]un[Oo][Ss]")
+    set(platform "solaris")
+elseif (CMAKE_SYSTEM MATCHES "[Ll]inux")
+    set(platform "linux")
+else()
+    set(platform "unix")
+endif()
+
+if(WIN32)
+    # Leave this empty for now, as the default GNU install directories won't
+    # help on Windows.
+    set(default_module_path "")
+else()
+    string(JOIN ":" default_module_path
+        ${CMAKE_INSTALL_FULL_DATAROOTDIR}/chibi
+        ${CMAKE_INSTALL_FULL_LIBDIR}/chibi
+        ${CMAKE_INSTALL_FULL_DATAROOTDIR}/snow
+        ${CMAKE_INSTALL_FULL_LIBDIR}/snow)
+endif()
+
+configure_file(include/chibi/install.h.in include/chibi/install.h)
+
+#
+# Testing
+#
+
+enable_testing()
+
+set(chibi-scheme-tests
+    r7rs-tests
+    division-tests
+    syntax-tests
+    unicode-tests)
+
+foreach(e ${chibi-scheme-tests})
+    add_test(NAME "${e}"
+        COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib tests/${e}.scm
+        WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+endforeach()
+
+add_test(NAME r5rs-test
+    COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib -xchibi tests/r5rs-tests.scm
+    WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+
+file(GLOB_RECURSE srfi_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
+    CONFIGURE_DEPENDS lib/srfi/*/test.sld)
+
+file(GLOB_RECURSE chibi_scheme_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
+    CONFIGURE_DEPENDS lib/chibi/*-test.sld)
+
+set(win32testexcludes
+    # Excluded tests
+    chibi/filesystem-test
+    chibi/memoize-test
+    chibi/term/ansi-test
+    chibi/weak-test
+
+    # Not ported to Win32
+    srfi/18/test # Threading
+    chibi/doc-test # Depends (chibi time)
+    chibi/log-test
+    chibi/system-test
+    chibi/tar-test # Depends (chibi system)
+    chibi/process-test # Not applicable
+    chibi/pty-test # Depends (chibi pty)
+    chibi/shell-test # Depends Linux procfs
+    )
+
+foreach(e ${srfi_tests} ${chibi_scheme_tests})
+    get_filename_component(pth ${e} PATH)
+    get_filename_component(nam ${e} NAME_WE)
+    list(APPEND testlibs ${pth}/${nam})
+endforeach()
+
+if(WIN32)
+    list(REMOVE_ITEM testlibs ${win32testexcludes})
+endif()
+
+foreach(e ${testlibs})
+    string(REGEX REPLACE "/" "_" testname ${e})
+    string(REGEX REPLACE "/" " " form ${e})
+    add_test(NAME "lib_${testname}"
+        COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib
+        -e "(import (${form}))"
+        -e "(run-tests)"
+        WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+endforeach()
+
+#
+# Testing (embedding)
+#
+
+add_executable(test-foreign-apply-loop
+    tests/foreign/apply-loop.c)
+
+target_link_libraries(test-foreign-apply-loop
+    PRIVATE libchibi-scheme)
+
+add_test(NAME "foreign-apply-loop"
+    COMMAND test-foreign-apply-loop
+    WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR})
+
+add_executable(test-foreign-typeid
+    tests/foreign/typeid.c)
+
+target_link_libraries(test-foreign-typeid
+    PRIVATE libchibi-scheme)
+
+add_test(NAME "foreign-typeid"
+    COMMAND test-foreign-typeid
+    WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR})
+
+
+#
+# Image, pkgconfig and meta file generation
+#
+
+add_custom_command(OUTPUT chibi.img
+    COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib -mchibi.repl
+    -d ${CMAKE_CURRENT_BINARY_DIR}/chibi.img
+    WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+add_custom_command(OUTPUT red.img
+    COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib -xscheme.red -mchibi.repl
+    -d ${CMAKE_CURRENT_BINARY_DIR}/red.img
+    WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+add_custom_command(OUTPUT snow.img
+    COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib
+        -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils
+        -d ${CMAKE_CURRENT_BINARY_DIR}/snow.img
+    WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+
+if(BUILD_SHARED_LIBS)
+    # Currently, image dumps only work with shared library builds, which includes Windows
+    add_custom_target(chibi-images ALL
+        DEPENDS
+        ${CMAKE_CURRENT_BINARY_DIR}/chibi.img
+        ${CMAKE_CURRENT_BINARY_DIR}/red.img
+        ${CMAKE_CURRENT_BINARY_DIR}/snow.img
+        # The dependency on libchibi-scheme is crucial here:
+        chibi-compiled-libs)
+endif()
+
+configure_file(contrib/chibi-scheme.pc.cmake.in chibi-scheme.pc @ONLY)
+
+function(generate_package_list libdir output)
+    add_custom_command(OUTPUT ${output}
+        COMMAND
+        ${CMAKE_COMMAND}
+        -DEXEC=$<TARGET_FILE:chibi-scheme>
+        -DLIBDIR=${libdir}
+        -DGENMETA=tools/generate-install-meta.scm
+        -DVERSION=${CMAKE_PROJECT_VERSION}
+        -DOUT=${CMAKE_CURRENT_BINARY_DIR}/${output}
+        -P contrib/chibi-generate-install-meta-helper.cmake
+        WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
+        DEPENDS
+        chibi-scheme
+        tools/generate-install-meta.scm
+        contrib/chibi-generate-install-meta-helper.cmake)
+endfunction()
+
+generate_package_list(lib/chibi .chibi.meta)
+generate_package_list(lib/scheme .scheme.meta)
+generate_package_list(lib/srfi .srfi.meta)
+
+add_custom_target(chibi-meta-lists ALL
+    DEPENDS
+    ${CMAKE_CURRENT_BINARY_DIR}/.chibi.meta
+    ${CMAKE_CURRENT_BINARY_DIR}/.scheme.meta
+    ${CMAKE_CURRENT_BINARY_DIR}/.srfi.meta)
+
+
+#
+# Installation
+#
+
+install(DIRECTORY include/chibi
+    DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}
+    PATTERN "sexp-*.[hc]" EXCLUDE
+    PATTERN "*.h.in" EXCLUDE)
+
+install(FILES ${CMAKE_CURRENT_BINARY_DIR}/include/chibi/install.h
+    DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}/chibi)
+
+install(FILES ${CMAKE_CURRENT_BINARY_DIR}/chibi-scheme.pc
+    DESTINATION ${CMAKE_INSTALL_LIBDIR}/pkgconfig)
+
+add_library(chibi::libchibi-scheme ALIAS libchibi-scheme)
+
+install(TARGETS libchibi-scheme libchibi-common chibi-scheme
+    EXPORT chibi-scheme-targets
+    RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}
+    LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}
+    ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR})
+
+install(FILES
+    tools/chibi-ffi
+    tools/chibi-doc
+    tools/snow-chibi
+    tools/snow-chibi.scm
+    DESTINATION ${CMAKE_INSTALL_BINDIR})
+
+install(FILES
+    doc/chibi-scheme.1
+    doc/chibi-ffi.1
+    doc/chibi-doc.1
+    DESTINATION ${CMAKE_INSTALL_MANDIR}/man1)
+
+if(BUILD_SHARED_LIBS)
+    install(FILES
+        ${CMAKE_CURRENT_BINARY_DIR}/chibi.img
+        ${CMAKE_CURRENT_BINARY_DIR}/red.img
+        ${CMAKE_CURRENT_BINARY_DIR}/snow.img
+        DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi)
+endif()
+
+install(DIRECTORY
+    lib/
+    DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi
+    PATTERN "*win32" EXCLUDE
+    PATTERN "*test.sld" EXCLUDE
+    PATTERN "*.c" EXCLUDE
+    PATTERN "*.stub" EXCLUDE)
+
+# This is to revert the above exclusion pattern
+install(FILES lib/chibi/test.sld
+    DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi/chibi)
+
+if(WIN32)
+    install(DIRECTORY
+        lib/
+        DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi
+        FILES_MATCHING
+        PATTERN "*win32/*.scm"
+        PATTERN "*win32/*.sld")
+endif()
+
+install(FILES
+    ${CMAKE_CURRENT_BINARY_DIR}/.chibi.meta
+    ${CMAKE_CURRENT_BINARY_DIR}/.scheme.meta
+    ${CMAKE_CURRENT_BINARY_DIR}/.srfi.meta
+    DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi)
+
+install(EXPORT chibi-scheme-targets
+    FILE chibi-scheme-targets.cmake
+    NAMESPACE chibi::
+    DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/chibi)
+
+write_basic_package_version_file(chibi-scheme-config-version.cmake
+    VERSION ${CMAKE_PROJECT_VERSION}
+    COMPATIBILITY ExactVersion)
+
+install(FILES
+    contrib/chibi-scheme-config.cmake
+    ${CMAKE_CURRENT_BINARY_DIR}/chibi-scheme-config-version.cmake
+    DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/chibi)

CONTRIBUTING.md

@@ -0,0 +1,13 @@
+# Contributing to Chibi-Scheme
+
+Thanks for your interest!
+
+Chibi-Scheme is fun and easy to hack.  If you want to contribute your
+changes back upstream, there are just a few guidelines:
+
+* Code must be released following the license in COPYING.
+* New modules likely belong on snow-fort.org, not the core distribution.
+* Chibi values small size over speed.
+* Features should be built up in layers, not added directly to the core.
+* Once you're ready to contribute, run `make init-dev` to install some
+  local settings (currently only git submit hooks).

COPYING

@@ -1,4 +1,4 @@
-Copyright (c) 2009-2015 Alex Shinn
+Copyright (c) 2009-2021 Alex Shinn
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

Makefile

@@ -1,94 +1,112 @@
 # -*- makefile-gmake -*-
 
-.PHONY: dist mips-dist cleaner test test-all test-dist checkdefs debian snowballs
+.PHONY: dist mips-dist cleaner distclean dist-clean test test-all test-dist checkdefs debian snowballs init-dev
 .DEFAULT_GOAL := all
 
-VERSION ?= $(shell cat VERSION)
-SOVERSION ?= $(VERSION)
+CHIBI_VERSION ?= $(shell cat VERSION)
+SOVERSION ?= $(CHIBI_VERSION)
 SOVERSION_MAJOR ?= $(shell echo "$(SOVERSION)" | sed "s/\..*//")
 
 CHIBI_FFI ?= $(CHIBI) -q tools/chibi-ffi
 CHIBI_FFI_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-ffi
 
 CHIBI_DOC ?= $(CHIBI) tools/chibi-doc
-CHIBI_DOC_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-doc
+CHIBI_DOC_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-doc $(COMPILED_LIBS)
 
 GENSTATIC ?= ./tools/chibi-genstatic
 
-CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH=".:$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH=lib ./chibi-scheme$(EXE)
+CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH=".:$(DYLD_LIBRARY_PATH)" CHIBI_IGNORE_SYSTEM_PATH=1 CHIBI_MODULE_PATH=lib ./chibi-scheme$(EXE)
 CHIBI_DEPENDENCIES = ./chibi-scheme$(EXE)
 
-SNOW_CHIBI ?= $(CHIBI) tools/snow-chibi
+SNOW_CHIBI ?= tools/snow-chibi
 
 ########################################################################
 
-CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
-	lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/stty$(SO) \
-	lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
-	lib/chibi/net$(SO) lib/chibi/ast$(SO) lib/chibi/emscripten$(SO)
+CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/weak$(SO) \
+	lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) lib/chibi/ast$(SO) \
+	lib/chibi/json$(SO) lib/chibi/emscripten$(SO)
+CHIBI_POSIX_COMPILED_LIBS = lib/chibi/process$(SO) lib/chibi/time$(SO) \
+	lib/chibi/system$(SO) lib/chibi/stty$(SO) lib/chibi/pty$(SO) \
+	lib/chibi/net$(SO) lib/srfi/18/threads$(SO)
+CHIBI_WIN32_COMPILED_LIBS = lib/chibi/win32/process-win32$(SO)
 CHIBI_CRYPTO_COMPILED_LIBS = lib/chibi/crypto/crypto$(SO)
 CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)
 CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
 	lib/chibi/optimize/profile$(SO)
 EXTRA_COMPILED_LIBS ?=
+
 COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
 	$(CHIBI_OPT_COMPILED_LIBS) $(CHIBI_CRYPTO_COMPILED_LIBS) \
 	$(EXTRA_COMPILED_LIBS) \
-	lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
+	lib/srfi/27/rand$(SO) lib/srfi/151/bit$(SO) \
 	lib/srfi/39/param$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
-	lib/srfi/98/env$(SO) lib/scheme/time$(SO)
+	lib/srfi/98/env$(SO) lib/srfi/144/math$(SO) lib/srfi/160/uvprims$(SO) \
+	lib/scheme/bytevector$(SO) lib/scheme/time$(SO)
 
 BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
-INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h
+INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h
 
-MODULE_DOCS := app ast config disasm equiv filesystem generic heap-stats io \
-	loop match mime modules net parse pathname process repl scribble stty \
-	system test time trace type-inference uri weak monad/environment \
-	show show/base crypto/sha2
+MODULE_DOCS := app assert ast base64 binary-record bytevector config \
+	crypto/md5 crypto/rsa crypto/sha2 diff disasm doc edit-distance \
+	equiv filesystem generic heap-stats io \
+	iset/base iset/constructors iset/iterators json loop \
+	match math/prime memoize mime modules net net/http-server net/servlet \
+	optional parse pathname process repl scribble string stty sxml system \
+	temp-file test time trace type-inference uri weak monad/environment \
+	crypto/sha2 shell
 
-HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
+IMAGE_FILES = lib/chibi.img lib/red.img lib/snow.img
+
+HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html) doc/lib/srfi/166/base.html
 
 META_FILES = lib/.chibi.meta lib/.srfi.meta lib/.scheme.meta
 
 ########################################################################
+# This includes the rules to build optional libraries.
+# It also pulls in Makefile.detect for platform detection.
 
 include Makefile.libs
 
-########################################################################
-# Library config.
-#
-# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to
-# automatically include the necessary compiler and linker flags in
-# addition to setting those features.  If not using GNU make just
-# comment out the ifs and use the else branches for the defaults.
-
-ifeq ($(SEXP_USE_BOEHM),1)
-GCLDFLAGS := -lgc
-XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
-else
-GCLDFLAGS :=
-XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
-endif
-
-ifeq ($(SEXP_USE_DL),0)
-XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
-XCFLAGS   := -Wall -DSEXP_USE_DL=0 -g -g3 -O3 $(CFLAGS)
-else
-XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
-XCFLAGS   := -Wall -g -g3 -O3 $(CFLAGS)
-endif
-
 ########################################################################
 
 all: chibi-scheme$(EXE) all-libs chibi-scheme.pc $(META_FILES)
 
-include/chibi/install.h: Makefile
+# Please run this if you want to contribute.
+init-dev:
+	git config core.hooksPath .githooks
+
+js: js/chibi.js
+
+js/chibi.js: chibi-scheme-emscripten chibi-scheme-static.bc js/pre.js js/post.js js/exported_functions.json
+	emcc -O0 chibi-scheme-static.bc -o $@ -s ALLOW_MEMORY_GROWTH=1 -s MODULARIZE=1 -s EXPORT_NAME=\"Chibi\" -s EXPORTED_FUNCTIONS=@js/exported_functions.json `find  lib -type f \( -name "*.scm" -or -name "*.sld" \) -printf " --preload-file %p"` -s 'EXTRA_EXPORTED_RUNTIME_METHODS=["ccall", "cwrap"]' --pre-js js/pre.js --post-js js/post.js
+
+chibi-scheme-static.bc:
+	emmake $(MAKE) PLATFORM=emscripten CHIBI_DEPENDENCIES= CHIBI=./chibi-scheme-emscripten PREFIX= CFLAGS=-O2 SEXP_USE_DL=0 EXE=.bc SO=.bc STATICFLAGS=-shared CPPFLAGS="-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1 -DSEXP_USE_ALIGNED_BYTECODE=1 -DSEXP_USE_STATIC_LIBS=1 -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0" clibs.c chibi-scheme-static.bc VERBOSE=1
+
+chibi-scheme-emscripten: VERSION
+	$(MAKE) distclean
+	$(MAKE) chibi-scheme-static PLATFORM=emscripten SEXP_USE_DL=0
+	(tempfile="`mktemp -t chibi.XXXXXX`" && \
+	mv chibi-scheme-static$(EXE) "$$tempfile" && \
+	$(MAKE) distclean; \
+	mv "$$tempfile" chibi-scheme-emscripten)
+
+include/chibi/install.h: Makefile.libs Makefile.detect
 	echo '#define sexp_so_extension "'$(SO)'"' > $@
-	echo '#define sexp_default_module_path "'$(MODDIR):$(BINMODDIR)'"' >> $@
+	echo '#define sexp_default_module_path "'$(MODDIR):$(BINMODDIR):$(SNOWMODDIR):$(SNOWBINMODDIR)'"' >> $@
 	echo '#define sexp_platform "'$(PLATFORM)'"' >> $@
-	echo '#define sexp_version "'$(VERSION)'"' >> $@
+	echo '#define sexp_architecture "'$(ARCH)'"' >> $@
+	echo '#define sexp_version "'$(CHIBI_VERSION)'"' >> $@
 	echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@
 
+lib/chibi/snow/install.sld: Makefile.libs Makefile.detect
+	echo '(define-library (chibi snow install)' > $@
+	echo '  (import (scheme base))' >> $@
+	echo '  (export snow-module-directory snow-binary-module-directory)' >> $@
+	echo '  (begin' >> $@
+	echo '   (define snow-module-directory "'$(SNOWMODDIR)'")' >> $@
+	echo '   (define snow-binary-module-directory "'$(SNOWBINMODDIR)'")))' >> $@
+
 %.o: %.c $(BASE_INCLUDES)
 	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
 
@@ -101,8 +119,8 @@ sexp-ulimit.o: sexp.c $(BASE_INCLUDES)
 main.o: main.c $(INCLUDES)
 	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
 
-SEXP_OBJS = gc.o sexp.o bignum.o
-SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o
+SEXP_OBJS = gc.o sexp.o bignum.o gc_heap.o
+SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o gc_heap.o
 EVAL_OBJS = opcodes.o vm.o eval.o simplify.o
 
 libchibi-sexp$(SO): $(SEXP_OBJS)
@@ -112,25 +130,29 @@ libchibi-scheme$(SO_VERSIONED_SUFFIX): $(SEXP_OBJS) $(EVAL_OBJS)
 	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(LIBCHIBI_FLAGS) -o $@ $^ $(XLDFLAGS)
 
 libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX): libchibi-scheme$(SO_VERSIONED_SUFFIX)
-	$(LN) -sf $< $@
+	$(LN) $< $@
 
 libchibi-scheme$(SO): libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
-	$(LN) -sf $< $@
+	$(LN) $< $@
 
 libchibi-scheme.a: $(SEXP_OBJS) $(EVAL_OBJS)
 	$(AR) rcs $@ $^
 
 chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
-	$(CC) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. -lchibi-scheme
+	$(CC) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) -lchibi-scheme
 
 chibi-scheme-static$(EXE): main.o $(SEXP_OBJS) $(EVAL_OBJS)
-	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) $(STATIC_LDFLAGS)
 
 chibi-scheme-ulimit$(EXE): main.o $(SEXP_ULIMIT_OBJS) $(EVAL_OBJS)
-	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) $(STATIC_LDFLAGS)
 
 clibs.c: $(GENSTATIC) $(CHIBI_DEPENDENCIES) $(COMPILED_LIBS:%$(SO)=%.c)
-	$(FIND) lib -name \*.sld | $(CHIBI) -q $(GENSTATIC) > $@
+	if [ -d .git ]; then \
+		$(GIT) ls-files lib | $(GREP) .sld | $(CHIBI) -q $(GENSTATIC) > $@; \
+	else \
+		$(FIND) lib -name \*.sld | $(CHIBI) -q $(GENSTATIC) > $@; \
+	fi
 
 chibi-scheme.pc: chibi-scheme.pc.in
 	echo "# pkg-config" > chibi-scheme.pc
@@ -138,23 +160,39 @@ chibi-scheme.pc: chibi-scheme.pc.in
 	echo "exec_prefix=\$${prefix}" >> chibi-scheme.pc
 	echo "libdir=$(LIBDIR)" >> chibi-scheme.pc
 	echo "includedir=\$${prefix}/include" >> chibi-scheme.pc
-	echo "version=$(VERSION)" >> chibi-scheme.pc
+	echo "version=$(CHIBI_VERSION)" >> chibi-scheme.pc
 	echo "" >> chibi-scheme.pc
 	cat chibi-scheme.pc.in >> chibi-scheme.pc
 
 # A special case, this needs to be linked with the LDFLAGS in case
 # we're using Boehm.
 lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES) libchibi-scheme$(SO)
-	-$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< $(GCLDFLAGS) -L. -lchibi-scheme
+	-$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< $(GCLDFLAGS) -L. $(RLDFLAGS) -lchibi-scheme
+
+lib/chibi/crypto/crypto.c: lib/chibi/crypto/sha2.c
+lib/chibi/filesystem.c: lib/chibi/filesystem_win32_shim.c
+lib/chibi/io/io.c: lib/chibi/io/port.c
+lib/chibi/net.c: lib/chibi/accept.c
+lib/chibi/process.c: lib/chibi/signal.c
+lib/srfi/144/math.c: lib/srfi/144/lgamma_r.c
+
+lib/chibi.img: $(CHIBI_DEPENDENCIES) all-libs
+	$(CHIBI) -d $@
+
+lib/snow.img: $(CHIBI_DEPENDENCIES) all-libs
+	$(CHIBI) -mchibi.snow.commands -d $@
+
+lib/red.img: $(CHIBI_DEPENDENCIES) all-libs
+	$(CHIBI) -xscheme.red -mchibi.repl -d $@
 
 doc: doc/chibi.html doc-libs
 
 %.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
 	$(CHIBI_DOC) --html $< > $@
 
-lib/.%.meta: lib/%/ tools/generate-install-meta.scm
+lib/.%.meta: lib/%/ tools/generate-install-meta.scm $(CHIBI_DEPENDENCIES)
 	-$(FIND) $< -name \*.sld | \
-	 $(CHIBI) tools/generate-install-meta.scm $(VERSION) > $@
+	 $(CHIBI) tools/generate-install-meta.scm $(CHIBI_VERSION) > $@
 
 ########################################################################
 # Dist builds - rules to build generated files included in distribution
@@ -167,14 +205,25 @@ data/%.txt:
 build-lib/chibi/char-set/derived.scm: data/UnicodeData.txt data/DerivedCoreProperties.txt chibi-scheme$(EXE)
 	$(CHIBI) tools/extract-unicode-props.scm --default > $@
 
+build-lib/chibi/char-set/width.scm: data/UnicodeData.txt data/EastAsianWidth.txt chibi-scheme$(EXE)
+	$(CHIBI) tools/extract-unicode-props.scm Zero-Width=Mn > $@
+	$(CHIBI) tools/extract-unicode-props.scm -d data/EastAsianWidth.txt Full-Width=F@1,W@1 Ambiguous-Width=A@1 >> $@
+
 lib/chibi/char-set/ascii.scm: build-lib/chibi/char-set/derived.scm chibi-scheme$(EXE)
 	$(CHIBI) -Abuild-lib tools/optimize-char-sets.scm --ascii chibi.char-set.compute > $@
 
 lib/chibi/char-set/full.scm: build-lib/chibi/char-set/derived.scm chibi-scheme$(EXE)
 	$(CHIBI) -Abuild-lib tools/optimize-char-sets.scm chibi.char-set.compute > $@
 
-lib/scheme/char/case-offsets.scm: data/CaseFolding.txt chibi-scheme$(EXE) all-libs
-	$(CHIBI) tools/extract-case-offsets.scm $< > $@
+lib/chibi/show/width.scm: build-lib/chibi/char-set/width.scm chibi-scheme$(EXE)
+	$(CHIBI) -Abuild-lib tools/optimize-char-sets.scm --predicate chibi.char-set.width > $@
+
+lib/scheme/char/case-offsets.scm: data/UnicodeData.txt data/CaseFolding.txt chibi-scheme$(EXE) all-libs
+	$(CHIBI) tools/extract-case-offsets.scm data/UnicodeData.txt data/CaseFolding.txt > $@
+
+# WARNING: this has a line for ß added by hand
+lib/scheme/char/special-casing.scm: data/CaseFolding.txt data/SpecialCasing.txt chibi-scheme$(EXE) all-libs
+	$(CHIBI) tools/extract-special-casing.scm data/CaseFolding.txt data/SpecialCasing.txt > $@
 
 ########################################################################
 # Tests
@@ -202,22 +251,23 @@ test-memory: chibi-scheme-ulimit$(EXE)
 test-build:
 	MAKE=$(MAKE) ./tests/build/build-tests.sh
 
+test-run:
+	./tests/run/command-line-tests.sh
+
 test-ffi: chibi-scheme$(EXE)
 	$(CHIBI) tests/ffi/ffi-tests.scm
 
-test-snow: chibi-scheme$(EXE)
+test-snow: chibi-scheme$(EXE) $(IMAGE_FILES)
 	$(CHIBI) tests/snow/snow-tests.scm
 
-test-numbers: chibi-scheme$(EXE)
-	$(CHIBI) -xchibi tests/numeric-tests.scm
-
-test-flonums: chibi-scheme$(EXE)
-	$(CHIBI) -xchibi tests/flonum-tests.scm
-
 test-unicode: chibi-scheme$(EXE)
 	$(CHIBI) -xchibi tests/unicode-tests.scm
 
+test-division: chibi-scheme$(EXE)
+	$(CHIBI) tests/division-tests.scm
+
 test-libs: chibi-scheme$(EXE)
+	@echo "\e[1mloading tests first, it may take a while to see output...\e[0m"
 	$(CHIBI) tests/lib-tests.scm
 
 test-r5rs: chibi-scheme$(EXE)
@@ -226,9 +276,16 @@ test-r5rs: chibi-scheme$(EXE)
 test-r7rs: chibi-scheme$(EXE)
 	$(CHIBI) tests/r7rs-tests.scm
 
+test-syntax: chibi-scheme$(EXE)
+	$(CHIBI) tests/syntax-tests.scm
+
 test: test-r7rs
 
-test-all: test test-libs test-ffi
+test-safe-string-cursors: chibi-scheme$(EXE)
+	$(CHIBI) -Dsafe-string-cursors tests/r7rs-tests.scm
+	$(CHIBI) -Dsafe-string-cursors tests/lib-tests.scm
+
+test-all: test test-syntax test-libs test-ffi test-division
 
 test-dist: test-all test-memory test-build
 
@@ -239,25 +296,33 @@ bench-gabriel: chibi-scheme$(EXE)
 # Packaging
 
 clean: clean-libs
-	-$(RM) *.o *.i *.s *.8 tests/basic/*.out tests/basic/*.err
+	-$(RM) *.o *.i *.s *.bc *.8 tests/basic/*.out tests/basic/*.err \
+	    tests/run/*.out tests/run/*.err
 
 cleaner: clean
 	-$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \
-	    libchibi-scheme$(SO)* *.a *.pc include/chibi/install.h lib/.*.meta \
+	    $(IMAGE_FILES) libchibi-scheme*$(SO) *.a *.pc \
+	    libchibi-scheme$(SO_VERSIONED_SUFFIX) \
+	    libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX) \
+	    include/chibi/install.h lib/.*.meta \
+	    chibi-scheme-emscripten \
+	    js/chibi.* \
 	    $(shell $(FIND) lib -name \*.o)
 
-dist-clean: dist-clean-libs cleaner
+distclean: dist-clean-libs cleaner
+dist-clean: distclean
 
-install: all
+install-base: all
 	$(MKDIR) $(DESTDIR)$(BINDIR)
-	$(INSTALL) -m0755 chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
+	$(INSTALL_EXE) -m0755 chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 tools/chibi-ffi $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 tools/chibi-doc $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 tools/snow-chibi $(DESTDIR)$(BINDIR)/
-	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term
+	$(INSTALL) -m0755 tools/snow-chibi.scm $(DESTDIR)$(BINDIR)/
+	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(MODDIR)/chibi/text
 	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
 	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
-	$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
+	$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(MODDIR)/srfi/179 $(DESTDIR)$(MODDIR)/srfi/211 $(DESTDIR)$(MODDIR)/srfi/231
 	$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
 	$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
 	$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
@@ -276,51 +341,87 @@ install: all
 	$(INSTALL) -m0644 lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
 	$(INSTALL) -m0644 lib/chibi/snow/*.sld lib/chibi/snow/*.scm $(DESTDIR)$(MODDIR)/chibi/snow/
 	$(INSTALL) -m0644 lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
+	$(INSTALL) -m0644 lib/chibi/text/*.sld lib/chibi/text/*.scm $(DESTDIR)$(MODDIR)/chibi/text/
 	$(INSTALL) -m0644 lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
 	$(INSTALL) -m0644 lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
 	$(INSTALL) -m0644 lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/
 	$(INSTALL) -m0644 lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/
+	$(INSTALL) -m0644 lib/srfi/1/*.sld $(DESTDIR)$(MODDIR)/srfi/1/
 	$(INSTALL) -m0644 lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
 	$(INSTALL) -m0644 lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
 	$(INSTALL) -m0644 lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
-	$(INSTALL) -m0644 lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
 	$(INSTALL) -m0644 lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
 	$(INSTALL) -m0644 lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
 	$(INSTALL) -m0644 lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
 	$(INSTALL) -m0644 lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
 	$(INSTALL) -m0644 lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
+	$(INSTALL) -m0644 lib/srfi/113/*.scm $(DESTDIR)$(MODDIR)/srfi/113/
+	$(INSTALL) -m0644 lib/srfi/117/*.scm $(DESTDIR)$(MODDIR)/srfi/117/
+	$(INSTALL) -m0644 lib/srfi/121/*.scm $(DESTDIR)$(MODDIR)/srfi/121/
+	$(INSTALL) -m0644 lib/srfi/125/*.scm $(DESTDIR)$(MODDIR)/srfi/125/
+	$(INSTALL) -m0644 lib/srfi/128/*.scm $(DESTDIR)$(MODDIR)/srfi/128/
+	$(INSTALL) -m0644 lib/srfi/129/*.scm $(DESTDIR)$(MODDIR)/srfi/129/
+	$(INSTALL) -m0644 lib/srfi/132/*.scm $(DESTDIR)$(MODDIR)/srfi/132/
+	$(INSTALL) -m0644 lib/srfi/133/*.scm $(DESTDIR)$(MODDIR)/srfi/133/
+	$(INSTALL) -m0644 lib/srfi/135/*.sld lib/srfi/135/*.scm $(DESTDIR)$(MODDIR)/srfi/135/
+	$(INSTALL) -m0644 lib/srfi/143/*.scm $(DESTDIR)$(MODDIR)/srfi/143/
+	$(INSTALL) -m0644 lib/srfi/144/*.scm $(DESTDIR)$(MODDIR)/srfi/144/
+	$(INSTALL) -m0644 lib/srfi/151/*.scm $(DESTDIR)$(MODDIR)/srfi/151/
+	$(INSTALL) -m0644 lib/srfi/159/*.scm $(DESTDIR)$(MODDIR)/srfi/159/
+	$(INSTALL) -m0644 lib/srfi/159/*.sld $(DESTDIR)$(MODDIR)/srfi/159/
+	$(INSTALL) -m0644 lib/srfi/160/*.sld $(DESTDIR)$(MODDIR)/srfi/160/
+	$(INSTALL) -m0644 lib/srfi/160/*.scm $(DESTDIR)$(MODDIR)/srfi/160/
+	$(INSTALL) -m0644 lib/srfi/166/*.sld $(DESTDIR)$(MODDIR)/srfi/166/
+	$(INSTALL) -m0644 lib/srfi/166/*.scm $(DESTDIR)$(MODDIR)/srfi/166/
+	$(INSTALL) -m0644 lib/srfi/146/*.sld $(DESTDIR)$(MODDIR)/srfi/146/
+	$(INSTALL) -m0644 lib/srfi/146/*.scm $(DESTDIR)$(MODDIR)/srfi/146/
+	$(INSTALL) -m0644 lib/srfi/179/*.sld $(DESTDIR)$(MODDIR)/srfi/179/
+	$(INSTALL) -m0644 lib/srfi/179/*.scm $(DESTDIR)$(MODDIR)/srfi/179/
+	$(INSTALL) -m0644 lib/srfi/211/*.sld $(DESTDIR)$(MODDIR)/srfi/211/
+	$(INSTALL) -m0644 lib/srfi/231/*.sld lib/srfi/231/*.scm $(DESTDIR)$(MODDIR)/srfi/231/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
-	$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
-	$(INSTALL) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
-	$(INSTALL) -m0755 $(CHIBI_CRYPTO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
-	$(INSTALL) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
-	$(INSTALL) -m0755 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
-	$(INSTALL) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
-	$(INSTALL) -m0755 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
-	$(INSTALL) -m0755 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
-	$(INSTALL) -m0755 lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
-	$(INSTALL) -m0755 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
-	$(INSTALL) -m0755 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
-	$(INSTALL) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
-	$(INSTALL) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/151 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/144 $(DESTDIR)$(BINMODDIR)/srfi/160
+	$(INSTALL_EXE) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
+	$(INSTALL_EXE) -m0755 $(CHIBI_CRYPTO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
+	$(INSTALL_EXE) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
+	$(INSTALL_EXE) -m0755 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
+	$(INSTALL_EXE) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(INSTALL_EXE) -m0755 lib/scheme/bytevector$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(INSTALL_EXE) -m0755 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
+	$(INSTALL_EXE) -m0755 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
+	$(INSTALL_EXE) -m0755 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
+	$(INSTALL_EXE) -m0755 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
+	$(INSTALL_EXE) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
+	$(INSTALL_EXE) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(INSTALL_EXE) -m0755 lib/srfi/144/math$(SO) $(DESTDIR)$(BINMODDIR)/srfi/144
+	$(INSTALL_EXE) -m0755 lib/srfi/151/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/151
+	$(INSTALL_EXE) -m0755 lib/srfi/160/uvprims$(SO) $(DESTDIR)$(BINMODDIR)/srfi/160
 	$(MKDIR) $(DESTDIR)$(INCDIR)
 	$(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/
 	$(MKDIR) $(DESTDIR)$(LIBDIR)
 	$(MKDIR) $(DESTDIR)$(SOLIBDIR)
-	$(INSTALL) -m0755 libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/
-	$(LN) -s -f libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
-	$(LN) -s -f libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
-	-$(INSTALL) -m0644 libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/
-	$(MKDIR) $(DESTDIR)$(SOLIBDIR)/pkgconfig
-	$(INSTALL) -m0644 chibi-scheme.pc $(DESTDIR)$(SOLIBDIR)/pkgconfig/
+	$(INSTALL_EXE) -m0755 libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/
+	$(LN) libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
+	$(LN) libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
+	-if test -f libchibi-scheme.a; then $(INSTALL) -m0644 libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/; fi
+	$(MKDIR) $(DESTDIR)$(PKGCONFDIR)
+	$(INSTALL) -m0644 chibi-scheme.pc $(DESTDIR)$(PKGCONFDIR)
 	$(MKDIR) $(DESTDIR)$(MANDIR)
 	$(INSTALL) -m0644 doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
 	$(INSTALL) -m0644 doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
 	$(INSTALL) -m0644 doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
-	-if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
+	-if type $(LDCONFIG) >/dev/null 2>/dev/null; then $(LDCONFIG) >/dev/null 2>/dev/null; fi
+
+install: install-base
+ifneq "$(IMAGE_FILES)" ""
+	echo "Generating images"
+	-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.repl -d $(MODDIR)/chibi.img
+	-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -xscheme.red -mchibi.repl -d $(MODDIR)/red.img
+	-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils -d $(DESTDIR)$(MODDIR)/snow.img
+endif
 
 uninstall:
 	-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
@@ -328,15 +429,20 @@ uninstall:
 	-$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi
 	-$(RM) $(DESTDIR)$(BINDIR)/chibi-doc
 	-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi
+	-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi.scm
 	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
 	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_VERSIONED_SUFFIX)
 	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
 	-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
-	-$(RM) $(DESTDIR)$(SOLIBDIR)/pkgconfig/chibi-scheme.pc
-	-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
-	-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm}
+	-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
+	-$(CD) $(DESTDIR)$(PREFIX) && $(RM) $(INCLUDES)
+	-$(RMDIR) $(DESTDIR)$(INCDIR)
+	-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.sld
+	-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.scm
 	-$(RM) $(DESTDIR)$(MODDIR)/.*.meta
-	-$(RM) $(DESTDIR)$(MODDIR)/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*/*.{sld,scm}
+	-$(RM) $(DESTDIR)$(MODDIR)/*.img
+	-$(RM) $(DESTDIR)$(MODDIR)/*.sld $(DESTDIR)$(MODDIR)/*/*.sld $(DESTDIR)$(MODDIR)/*/*/*.sld
+	-$(RM) $(DESTDIR)$(MODDIR)/*.scm $(DESTDIR)$(MODDIR)/*/*.scm $(DESTDIR)$(MODDIR)/*/*/*.scm
 	-$(CD) $(DESTDIR)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
 	-$(CD) $(DESTDIR)$(BINMODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(BINMODDIR)/chibi/char-set
@@ -354,6 +460,7 @@ uninstall:
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(BINMODDIR)/chibi/snow
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/text $(DESTDIR)$(BINMODDIR)/chibi/text
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/time $(DESTDIR)$(BINMODDIR)/scheme/time
@@ -361,26 +468,44 @@ uninstall:
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27
-	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/33
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/39
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(BINMODDIR)/srfi/113
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(BINMODDIR)/srfi/117
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(BINMODDIR)/srfi/121
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(BINMODDIR)/srfi/125
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(BINMODDIR)/srfi/128
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(BINMODDIR)/srfi/129
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(BINMODDIR)/srfi/132
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(BINMODDIR)/srfi/133
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(BINMODDIR)/srfi/135
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(BINMODDIR)/srfi/143
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(BINMODDIR)/srfi/151
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(BINMODDIR)/srfi/144
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(BINMODDIR)/srfi/146
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(BINMODDIR)/srfi/159
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(BINMODDIR)/srfi/160
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(BINMODDIR)/srfi/166
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/179 $(DESTDIR)$(BINMODDIR)/srfi/179
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/211 $(DESTDIR)$(BINMODDIR)/srfi/211
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/231 $(DESTDIR)$(BINMODDIR)/srfi/231
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
 	-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
 	-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
-	-$(RM) $(DESTDIR)$(SOLIBDIR)/pkgconfig/chibi-scheme.pc
+	-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
 
-dist: dist-clean
-	$(RM) chibi-scheme-$(VERSION).tgz
-	$(MKDIR) chibi-scheme-$(VERSION)
-	@for f in `git ls-files | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-$(VERSION)/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-$(VERSION)/$$f; done
-	$(TAR) cphzvf chibi-scheme-$(VERSION).tgz chibi-scheme-$(VERSION)
-	$(RM) -r chibi-scheme-$(VERSION)
+dist: distclean
+	$(RM) chibi-scheme-$(CHIBI_VERSION).tgz
+	$(MKDIR) chibi-scheme-$(CHIBI_VERSION)
+	@for f in `git ls-files | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-$(CHIBI_VERSION)/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-$(CHIBI_VERSION)/$$f; done
+	$(TAR) cphzvf chibi-scheme-$(CHIBI_VERSION).tgz chibi-scheme-$(CHIBI_VERSION)
+	$(RM) -r chibi-scheme-$(CHIBI_VERSION)
 
-mips-dist: dist-clean
+mips-dist: distclean
 	$(RM) chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`.tgz
 	$(MKDIR) chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`
 	@for f in `git ls-files | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`/$$f; done
@@ -388,33 +513,47 @@ mips-dist: dist-clean
 	$(RM) -r chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`
 
 debian:
-	sudo checkinstall -D --pkgname chibi-scheme --pkgversion $(VERSION) --maintainer "http://groups.google.com/group/chibi-scheme" -y make PREFIX=/usr install
+	sudo checkinstall -D --pkgname chibi-scheme --pkgversion $(CHIBI_VERSION) --maintainer "http://groups.google.com/group/chibi-scheme" -y make PREFIX=/usr install
 
 # Libraries in the standard distribution we want to make available to
 # other Scheme implementations.  Note this is run with my own
-# ~/.snow/config.scm, which specifies myself own settings regarding
+# ~/.snow/config.scm, which specifies my own settings regarding
 # author, license, extracting docs from scribble, etc.
 snowballs:
 	$(SNOW_CHIBI) package --license public-domain lib/chibi/char-set/boundary.sld
 	$(SNOW_CHIBI) package --license public-domain lib/chibi/match.sld
 	$(SNOW_CHIBI) package -r lib/chibi/char-set.sld
-	$(SNOW_CHIBI) package -r lib/chibi/iset.sld
-	$(SNOW_CHIBI) package -r lib/chibi/show.sld lib/chibi/show/pretty.sld
+	$(SNOW_CHIBI) package -r lib/chibi/iset.sld lib/chibi/iset/optimize.sld
+	$(SNOW_CHIBI) package --doc https://srfi.schemers.org/srfi-115/srfi-115.html --test-library lib/srfi/115.sld
+	$(SNOW_CHIBI) package -r --doc https://srfi.schemers.org/srfi-166/srfi-166.html --test-library lib/srfi/166/test.sld lib/srfi/166.sld lib/chibi/show/shared.sld
+	$(SNOW_CHIBI) package -r --doc https://srfi.schemers.org/srfi-179/srfi-179.html --test-library lib/srfi/179/test.sld lib/srfi/179.sld
 	$(SNOW_CHIBI) package lib/chibi/app.sld
+	$(SNOW_CHIBI) package lib/chibi/assert.sld
+	$(SNOW_CHIBI) package lib/chibi/base64.sld
+	$(SNOW_CHIBI) package lib/chibi/binary-record.sld
 	$(SNOW_CHIBI) package lib/chibi/bytevector.sld
 	$(SNOW_CHIBI) package lib/chibi/config.sld
 	$(SNOW_CHIBI) package lib/chibi/crypto/md5.sld
 	$(SNOW_CHIBI) package lib/chibi/crypto/rsa.sld
 	$(SNOW_CHIBI) package lib/chibi/crypto/sha2.sld
+	$(SNOW_CHIBI) package lib/chibi/diff.sld
+	$(SNOW_CHIBI) package lib/chibi/edit-distance.sld
+	$(SNOW_CHIBI) package lib/chibi/filesystem.sld
 	$(SNOW_CHIBI) package lib/chibi/math/prime.sld
+	$(SNOW_CHIBI) package lib/chibi/mime.sld
 	$(SNOW_CHIBI) package lib/chibi/monad/environment.sld
 	$(SNOW_CHIBI) package lib/chibi/optional.sld
 	$(SNOW_CHIBI) package lib/chibi/parse.sld lib/chibi/parse/common.sld
 	$(SNOW_CHIBI) package lib/chibi/pathname.sld
+	$(SNOW_CHIBI) package lib/chibi/quoted-printable.sld
 	$(SNOW_CHIBI) package lib/chibi/regexp.sld lib/chibi/regexp/pcre.sld
 	$(SNOW_CHIBI) package lib/chibi/scribble.sld
 	$(SNOW_CHIBI) package lib/chibi/string.sld
 	$(SNOW_CHIBI) package lib/chibi/sxml.sld
+	$(SNOW_CHIBI) package lib/chibi/tar.sld
+	$(SNOW_CHIBI) package lib/chibi/temp-file.sld
 	$(SNOW_CHIBI) package lib/chibi/term/ansi.sld
+	$(SNOW_CHIBI) package lib/chibi/term/edit-line.sld
 	$(SNOW_CHIBI) package lib/chibi/test.sld
 	$(SNOW_CHIBI) package lib/chibi/uri.sld
+	$(SNOW_CHIBI) package lib/chibi/zlib.sld

Makefile.detect

@@ -9,6 +9,7 @@ PLATFORM=macosx
 else
 ifeq ($(shell uname),FreeBSD)
 PLATFORM=bsd
+LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
 else
 ifeq ($(shell uname),NetBSD)
 PLATFORM=bsd
@@ -20,7 +21,7 @@ ifeq ($(shell uname),DragonFly)
 PLATFORM=bsd
 else
 ifeq ($(shell uname -o),Msys)
-PLATFORM=mingw
+PLATFORM=windows
 SOLIBDIR = $(BINDIR)
 DIFFOPTS = -b
 else
@@ -29,9 +30,15 @@ PLATFORM=cygwin
 SOLIBDIR = $(BINDIR)
 DIFFOPTS = -b
 else
+ifeq ($(shell uname -o),Android)
+PLATFORM=android
+else
 ifeq ($(shell uname -o),GNU/Linux)
 PLATFORM=linux
 else
+ifeq ($(shell uname),SunOS)
+PLATFORM=solaris
+else
 PLATFORM=unix
 endif
 endif
@@ -41,6 +48,13 @@ endif
 endif
 endif
 endif
+endif
+endif
+endif
+
+ifndef ARCH
+ARCH = $(shell uname -m)
+endif
 
 ########################################################################
 # Set default variables for the platform.
@@ -48,6 +62,7 @@ endif
 LIBDL = -ldl
 SO_VERSIONED_SUFFIX = $(SO).$(SOVERSION)
 SO_MAJOR_VERSIONED_SUFFIX = $(SO).$(SOVERSION_MAJOR)
+STATIC_LDFLAGS = -lm -ldl -lutil
 
 ifeq ($(PLATFORM),macosx)
 SO  = .dylib
@@ -65,17 +80,37 @@ EXE =
 CLIBFLAGS = -fPIC
 CLINKFLAGS = -shared
 LIBDL = 
+RLDFLAGS=-Wl,-R$(LIBDIR)
 else
-ifeq ($(PLATFORM),mingw)
+ifeq ($(PLATFORM),solaris)
+SO = .so
+EXE =
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
+LIBDL = -ldl
+RLDFLAGS=-Wl,-R$(LIBDIR)
+else
+ifeq ($(PLATFORM),windows)
+SO  = .dll
+EXE = .exe
+CC ?= gcc
+CLIBFLAGS =
+CLINKFLAGS = -shared
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DSEXP_USE_GREEN_THREADS=0 -DSEXP_USE_GC_FILE_DESCRIPTORS=0 -DBUILDING_DLL
+LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATICFLAGS =
+STATIC_LDFLAGS = -lm -ldl
+LIBDL = -lws2_32
+else
+ifeq ($(PLATFORM),msys)
 SO  = .dll
 EXE = .exe
 CC = gcc
 CLIBFLAGS =
 CLINKFLAGS = -shared
-CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
 LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
-STATICFLAGS = -DSEXP_USE_DL=0
-LIBDL = 
+STATIC_LDFLAGS = -lm -ldl
 else
 ifeq ($(PLATFORM),cygwin)
 SO  = .dll
@@ -85,6 +120,7 @@ CLIBFLAGS =
 CLINKFLAGS = -shared
 CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
 LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATIC_LDFLAGS = -lm -ldl
 else
 SO  = .so
 EXE =
@@ -92,9 +128,6 @@ CLIBFLAGS = -fPIC
 CLINKFLAGS = -shared
 STATICFLAGS = -static -DSEXP_USE_DL=0
 LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
-ifeq ($(PLATFORM),BSD)
-LIBDL=
-RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
 endif
 endif
 endif
@@ -102,26 +135,83 @@ endif
 endif
 endif
 
+ifeq ($(PLATFORM),emscripten)
+STATIC_LDFLAGS = -lm -ldl
+endif
+
 ifeq ($(PLATFORM),unix)
 #RLDFLAGS=-rpath $(LIBDIR)
-RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
+RLDFLAGS=-Wl,-R$(LIBDIR)
+endif
+
+########################################################################
+# Library config.
+#
+# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to
+# automatically include the necessary compiler and linker flags in
+# addition to setting those features.  If not using GNU make just
+# comment out the ifs and use the else branches for the defaults.
+
+ifeq ($(SEXP_USE_BOEHM),1)
+GCLDFLAGS := -lgc
+XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
+else
+GCLDFLAGS :=
+XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
+endif
+
+ifeq ($(SEXP_USE_DL),0)
+XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
+XCFLAGS   := -Wall -DSEXP_USE_DL=0 -g -g3 -O3 $(CFLAGS)
+else
+XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
+XCFLAGS   := -Wall -g -g3 -O3 $(CFLAGS)
+endif
+
+ifeq ($(PLATFORM),solaris)
+XLDFLAGS += -lsocket
+XCPPFLAGS += -D_POSIX_PTHREAD_SEMANTICS
+endif
+
+# Choose compiled library on MSYS
+ifeq ($(OS), Windows_NT)
+ifeq ($(PLATFORM),msys)
+EXCLUDE_WIN32_LIBS=1
+else
+ifeq ($(shell uname -o),Cygwin)
+EXCLUDE_WIN32_LIBS=1
+else
+EXCLUDE_POSIX_LIBS=1
+endif
+endif
+endif
+
+CHIBI_POSIX_COMPILED_LIBS = lib/chibi/process$(SO) lib/chibi/time$(SO) \
+	lib/chibi/system$(SO) lib/chibi/stty$(SO) lib/chibi/pty$(SO) \
+	lib/chibi/net$(SO) lib/srfi/18/threads$(SO)
+CHIBI_WIN32_COMPILED_LIBS = lib/chibi/win32/process-win32$(SO)
+
+ifndef EXCLUDE_POSIX_LIBS
+CHIBI_COMPILED_LIBS += $(CHIBI_POSIX_COMPILED_LIBS)
+else
+CHIBI_COMPILED_LIBS += $(CHIBI_WIN32_COMPILED_LIBS)
 endif
 
 ########################################################################
 # Check for headers (who needs autoconf?)
 
-ifndef $(SEXP_USE_NTP_GETTIME)
-SEXP_USE_NTP_GETTIME := $(shell echo "main(){struct ntptimeval n; ntp_gettime(&n);}" | gcc -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+ifndef SEXP_USE_NTP_GETTIME
+SEXP_USE_NTP_GETTIME := $(shell echo "int main(){struct ntptimeval n; ntp_gettime(&n);}" | $(CC) -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
 endif
 
 ifeq ($(SEXP_USE_NTP_GETTIME),1)
-CPPFLAGS += -DSEXP_USE_NTPGETTIME
+XCPPFLAGS += -DSEXP_USE_NTPGETTIME
 endif
 
-ifndef $(SEXP_USE_INTTYPES)
-SEXP_USE_INTTYPES := $(shell echo "main(){int_least8_t x;}" | gcc -fsyntax-only -include inttypes.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+ifndef SEXP_USE_INTTYPES
+SEXP_USE_INTTYPES := $(shell echo "int main(){int_least8_t x;}" | $(CC) -fsyntax-only -include inttypes.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
 endif
 
 ifeq ($(SEXP_USE_INTTYPES),1)
-CPPFLAGS += -DSEXP_USE_INTTYPES
+XCPPFLAGS += -DSEXP_USE_INTTYPES
 endif

Makefile.libs

@@ -14,25 +14,49 @@ CD        ?= cd
 RM        ?= rm -f
 LS        ?= ls
 CP        ?= cp
-LN        ?= ln
+LN        ?= ln -sf
 INSTALL   ?= install
+INSTALL_EXE	?=	$(INSTALL)
 MKDIR     ?= $(INSTALL) -d
 RMDIR     ?= rmdir
 TAR       ?= tar
 DIFF      ?= diff
+GIT       ?= git
 GREP      ?= grep
 FIND      ?= find
 SYMLINK   ?= ln -s
+LDCONFIG  ?= ldconfig
 
-PREFIX    ?= /usr/local
-BINDIR    ?= $(PREFIX)/bin
-LIBDIR    ?= $(PREFIX)/lib
-SOLIBDIR  ?= $(PREFIX)/lib
-INCDIR    ?= $(PREFIX)/include/chibi
-MODDIR    ?= $(PREFIX)/share/chibi
-BINMODDIR ?= $(PREFIX)/lib/chibi
-MANDIR    ?= $(PREFIX)/share/man/man1
+# gnu coding standards
+prefix      ?= /usr/local
+PREFIX      ?= $(prefix)
+exec_prefix ?= $(PREFIX)
+bindir      ?= $(exec_prefix)/bin
+libdir      ?= $(exec_prefix)/lib
+includedir  ?= $(PREFIX)/include
+datarootdir ?= $(PREFIX)/share
+datadir     ?= $(datarootdir)
+mandir      ?= $(datarootdir)/man
+man1dir     ?= $(mandir)/man1
 
+# hysterical raisins
+BINDIR      ?= $(bindir)
+LIBDIR      ?= $(libdir)
+SOLIBDIR    ?= $(libdir)
+INCDIR      ?= $(includedir)/chibi
+MODDIR      ?= $(datadir)/chibi
+BINMODDIR   ?= $(SOLIBDIR)/chibi
+PKGCONFDIR  ?= $(SOLIBDIR)/pkgconfig
+MANDIR      ?= $(man1dir)
+
+# allow snow to be configured separately
+SNOWPREFIX    ?= /usr/local
+SNOWLIBDIR    ?= $(SNOWPREFIX)/lib
+SNOWSOLIBDIR  ?= $(SNOWLIBDIR)
+SNOWMODDIR    ?= $(SNOWPREFIX)/share/snow
+SNOWBINMODDIR ?= $(SNOWSOLIBDIR)/snow
+
+# for packaging tools
 DESTDIR       ?=
 
 ########################################################################
@@ -43,13 +67,16 @@ include Makefile.detect
 
 ########################################################################
 
-all-libs: $(COMPILED_LIBS)
+all-libs: $(COMPILED_LIBS) lib/chibi/snow/install.sld
 
 lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES)
 	$(CHIBI_FFI) $<
 
+lib/chibi/pty$(SO): lib/chibi/pty.c $(INCLUDES) libchibi-scheme$(SO)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) $(XLIBS) -lchibi-scheme -lutil
+
 lib/%$(SO): lib/%.c $(INCLUDES) libchibi-scheme$(SO)
-	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) $(XLIBS) -lchibi-scheme
 
 doc-libs: $(HTML_LIBS)
 

README

@@ -1,40 +0,0 @@
-
-                             Chibi-Scheme
-                            --------------
-                                   
-    Minimal Scheme Implementation for use as an Extension Language
-
-              http://synthcode.com/wiki/chibi-scheme/
-
-Chibi-Scheme is a very small library intended for use as an extension
-and scripting language in C programs.  In addition to support for
-lightweight VM-based threads, each VM itself runs in an isolated heap
-allowing multiple VMs to run simultaneously in different OS threads.
-
-The default repl language contains all bindings from R7RS small,
-available explicitly as the (scheme small) library.
-
-Support for additional languages such as JavaScript, Go, Lua and Bash
-are planned for future releases.  Scheme is chosen as a substrate
-because its first class continuations and guaranteed tail-call
-optimization makes implementing other languages easy.
-
-To build on most platforms just run "make && make test".  This will
-provide a shared library "libchibi-scheme", as well as a sample
-"chibi-scheme" command-line repl.  You can then run
-
-  sudo make install
-
-to install the binaries and libraries.  You can optionally specify a
-PREFIX for the installation directory:
-
-  make PREFIX=/path/to/install/
-  sudo make PREFIX=/path/to/install/ install
-
-By default files are installed in /usr/local.
-
-If you want to try out chibi-scheme without installing, be sure to set
-LD_LIBRARY_PATH so it can find the shared libraries.
-
-For more detailed documentation, run "make doc" and see the generated
-"doc/chibi.html".

README-win32.md

@@ -0,0 +1,81 @@
+Chibi-scheme for Windows
+========================
+
+Chibi-scheme provides limited support for native desktop Windows. To use 
+fully-featured Chibi-scheme on Windows, consider using POSIX layer such as
+Windows Subsytem for Linux(WSL), Cygwin or MSYS.
+
+Currently, only R7RS Small libraries are available for the platform. 
+
+Supported Environments
+----------------------
+
+Chibi-scheme can be compiled with following platforms:
+
+* Microsoft Visual Studio 2017
+* MinGW32
+* MinGW64
+* MSYS
+
+
+Known Issues
+------------
+
+Following libraries are not ported yet:
+
+* `(chibi net)`
+* `(chibi process)` : `exit` is available through `(scheme process-context)`
+* `(chibi stty)`
+* `(chibi system)`
+* `(chibi time)`
+
+Following library is not completely ported:
+
+* `(chibi filesystem)`
+
+Other issues:
+
+* SRFI-27: Due to C Runtime limitation, the library is not thread-safe
+* `make install` is not supported on Windows platforms
+* On MSVC, flonum precision is degraded when compared with other compilers
+* Cross compilation is not supported
+
+
+Build with MinGW(Makefile)
+--------------------------
+
+The top-level `Makefile` can be used with MinGW.
+
+1. Open MinGW64 or MinGW32 command prompt
+2. `make`
+3. `make test`
+
+Currently, `make doc` is not supported on these platforms.
+
+
+Build with MSYS(Makefile)
+-------------------------
+
+By default, the Makefile will compile against native Windows API. To use
+MSYS's own POSIX emulation layer, specify `PLATFORM=msys`.
+
+1. Open MSYS command prompt
+2. `make PLATFORM=msys`
+3. `make PLATFORM=msys test`
+
+
+Build with Visual Studio(CMake)
+-------------------------------
+
+Minimal `CMakeLists.txt` is provided as an example to build Chibi-scheme on
+Windows platforms. This is only intended to be used with Windows platforms;
+currently it does not provide features provided with standard `Makefile` nor
+it does not support UNIX/APPLE platforms either.
+
+1. (Make sure CMake was selected with Visual Studio installer)
+2. Open this directory with "Open with Visual Studio"
+3. Choose "x86-" or "x64-" configuration
+4. "CMake" => "Build all"
+5. "CMake" => "Tests" => "Run chibi-scheme Tests"
+
+

README.md

@@ -0,0 +1,60 @@
+# ![Chibi-Scheme](https://goo.gl/ZDtn4q)
+
+**Minimal Scheme Implementation for use as an Extension Language**
+
+https://github.com/ashinn/chibi-scheme
+
+Chibi-Scheme is a very small library intended for use as an extension
+and scripting language in C programs.  In addition to support for
+lightweight VM-based threads, each VM itself runs in an isolated heap
+allowing multiple VMs to run simultaneously in different OS threads.
+
+There are no external dependencies so is relatively easy to drop into
+any project.
+
+Despite the small size, Chibi-Scheme attempts to do The Right Thing.
+The default settings include:
+
+* a full numeric tower, with rational and complex numbers
+* full and seamless Unicode support
+* low-level and high-level hygienic macros
+* an extensible module system
+
+Specifically, the default repl language contains all bindings from
+[R7RS small](https://small.r7rs.org/), available explicitly as the
+`(scheme small)` library.  The language is built in layers, however -
+see the manual for instructions on compiling with fewer features or
+requesting a smaller language on startup.
+
+Chibi-Scheme is known to work on **32** and **64-bit** Linux, FreeBSD,
+NetBSD, OpenBSD, DragonFlyBSD, OS X, Plan 9, Windows, iOS, Android,
+ARM and [Emscripten](https://kripken.github.io/emscripten-site).  Basic
+support for native Windows desktop also exists. See README-win32.md
+for details and build instructions.
+
+To build on most platforms just run `make && make test`.  This has a
+few conditionals assuming GNU make.  If using another make, there are
+a few parameters in Makefile.detect you need to set by hand.
+
+This will provide a shared library *libchibi-scheme*, as well as a
+sample *chibi-scheme* command-line repl.  You can then run
+
+    sudo make install
+
+to install the binaries and libraries.  You can optionally specify a
+**PREFIX** for the installation directory:
+
+    make PREFIX=/path/to/install/
+    sudo make PREFIX=/path/to/install/ install
+
+By default files are installed in **/usr/local**.
+
+If you want to try out chibi-scheme without installing, be sure to set
+`LD_LIBRARY_PATH` (`DYLD_LIBRARY_PATH` on macOS) so it can find the
+shared libraries.
+
+To make the emscripten build run `make js` (_not_ `emmake make js`).
+
+For more detailed documentation, run `make doc` and see the generated
+*doc/chibi.html* or read the [manual](http://synthcode.com/scheme/chibi/)
+online.

RELEASE

@@ -1 +1 @@
-nitrogen
+sodium

TODO

@@ -10,7 +10,8 @@
 ** TODO native x86 backend
    API redesign in preparation complete, initial
    tests on native factorial and closures working.
-** TODO fasl/image files
+** DONE fasl/image files
+   - State "DONE"       from "TODO"       [2017-08-30 Wed 23:13]
    sexp_copy_context() can form the basis for images,
    FASL for arbitrary modules will need additional
    help with resolving external references.
@@ -18,7 +19,8 @@
     - State "DONE"       from "TODO"       [2011-11-10 Thu 20:44]
 *** TODO static image compiled into library
     With this you'll be able to run Chibi without any filesystem.
-*** TODO external tool to compact and optimize images
+*** DONE external tool to compact and optimize images
+    - State "DONE"       from "TODO"       [2017-08-30 Wed 23:13]
     The current GC is mark&sweep, which can cause fragmentation,
     but we can at at least compact the initial fixed image.
 *** TODO fasl versions of modules
@@ -89,8 +91,6 @@
    - State "DONE"       from "TODO"       [2010-07-11 Sun 15:31]
    VM now supports an optional hook for green threads,
    and a SRFI-18 interface is provided as a separate module.
-   I/O operations will currently block all threads though,
-   this needs to be addressed.
 *** DONE thread-local parameters
     CLOSED: [2010-12-06 Mon 21:52]
 *** TODO efficient priority queues
@@ -125,7 +125,8 @@
    - State "DONE"       [2009-12-08 Tue 14:39]
 ** DONE only/except/rename/prefix modifiers
    - State "DONE"       [2009-12-16 Wed 18:57]
-** TODO scheme-complete.el support
+** DONE scheme-complete.el support
+   - State "DONE"       from "TODO"       [2017-08-30 Wed 23:14]
 ** DONE access individual modules from repl
    - State "DONE"       [2009-12-26 Sat 01:49]
 
@@ -181,7 +182,8 @@
 * miscellaneous
 ** DONE user documentation
    - State "DONE"       from "TODO"       [2011-11-10 Thu 20:45]
-** TODO full test suite for libraries
+** DONE full test suite for libraries
+   - State "DONE"       from "TODO"       [2017-08-30 Wed 23:14]
 ** TODO thorough source documentation
 
 * distribution

VERSION

@@ -1 +1 @@
-0.7.3
+0.11.0

appveyor.yml

@@ -0,0 +1,53 @@
+image: Visual Studio 2017
+
+environment:
+    matrix:
+        - ARCH: x64
+          TOOLCHAIN: MinGW
+          BUILDSYSTEM: MSYS2
+        - ARCH: x64
+          TOOLCHAIN: MSYS
+          BUILDSYSTEM: MSYS2
+        - ARCH: x86
+          TOOLCHAIN: MinGW
+          BUILDSYSTEM: MSYS2
+        - ARCH: x86
+          TOOLCHAIN: MinGW
+          BUILDSYSTEM: CMAKE
+        - ARCH: x64
+          TOOLCHAIN: MinGW
+          BUILDSYSTEM: CMAKE
+        - ARCH: x86
+          TOOLCHAIN: MSVC
+          BUILDSYSTEM: CMAKE
+        - ARCH: x64
+          TOOLCHAIN: MSVC
+          BUILDSYSTEM: CMAKE
+
+install:
+    - if %BUILDSYSTEM%.==CMAKE. cinst ninja
+    - if %BUILDSYSTEM%.==CMAKE. set PATH=c:/tools/ninja;%PATH%
+    - if %TOOLCHAIN%%ARCH%.==MSVCx86. call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build\vcvars32.bat"
+    - if %TOOLCHAIN%%ARCH%.==MSVCx64. call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build\vcvars64.bat"
+
+before_build:
+    - set BUILDTYPE= %ARCH%%TOOLCHAIN%
+    - if %BUILDTYPE%.==x64MinGW. set PATH=c:\msys64\usr\bin;c:\msys64\mingw64\bin;%PATH%
+    - if %BUILDTYPE%.==x86MinGW. set PATH=c:\msys64\usr\bin;c:\msys64\mingw32\bin;%PATH%
+    - if %BUILDTYPE%.==x64MSYS. set PATH=c:\msys64\usr\bin;%PATH%
+    - if %BUILDTYPE%.==x64MinGW. set CC=c:/msys64/mingw64/bin/gcc
+    - if %BUILDTYPE%.==x86MinGW. set CC=c:/msys64/mingw32/bin/gcc
+    - if %BUILDTYPE%.==x64MSYS. set CC=gcc
+    - if %TOOLCHAIN%.==MSVC. set CC=cl.exe
+    - if %TOOLCHAIN%%BUILDSYSTEM%.==MinGWMSYS2. set EXARG=
+    - if %TOOLCHAIN%%BUILDSYSTEM%.==MSYSMSYS2. set EXARG=PLATFORM=msys
+    - if %BUILDSYSTEM%.==CMAKE. cmake -G Ninja .
+
+build_script:
+    - if %BUILDSYSTEM%.==MSYS2. make CC=%CC% %EXARG% 
+    - if %BUILDSYSTEM%.==CMAKE. ninja
+
+test_script:
+    - if %BUILDSYSTEM%.==MSYS2. make CC=%CC% %EXARG% test
+    - if %BUILDSYSTEM%.==CMAKE. ctest --verbose .
+

benchmarks/gabriel/chibi-prelude.scm

@@ -1,25 +1,47 @@
 
-(import (chibi time) (scheme cxr) (srfi 33) (srfi 39))
+(import (chibi ast) (chibi time) (scheme cxr) (srfi 33) (srfi 39))
 
 (define (timeval->milliseconds tv)
   (quotient (+ (* 1000000 (timeval-seconds tv)) (timeval-microseconds tv))
             1000))
 
+(define (timeval-diff start end)
+  (- (timeval->milliseconds end)
+     (timeval->milliseconds start)))
+
 (define (time* thunk)
   (call-with-output-string
     (lambda (out)
+      (gc)
       (let* ((start (car (get-time-of-day)))
+             (start-rusage (get-resource-usage))
+             (gc-start (gc-usecs))
+             (gc-start-count (gc-count))
+             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
              (result (parameterize ((current-output-port out)) (thunk)))
+             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
              (end (car (get-time-of-day)))
-             (msecs (- (timeval->milliseconds end)
-                       (timeval->milliseconds start))))
+             (end-rusage (get-resource-usage))
+             (gc-end (gc-usecs))
+             (gc-msecs (quotient (- gc-end gc-start) 1000))
+             (real-msecs (timeval-diff start end))
+             (user-msecs
+              (timeval-diff (resource-usage-time start-rusage)
+                            (resource-usage-time end-rusage)))
+             (system-msecs
+              (timeval-diff (resource-usage-system-time start-rusage)
+                            (resource-usage-system-time end-rusage))))
         (display "user: ")
-        (display msecs)
-        (display " system: 0")
+        (display user-msecs)
+        (display " system: ")
+        (display system-msecs)
         (display " real: ")
-        (display msecs)
-        (display " gc: 0")
-        (newline)
+        (display real-msecs)
+        (display " gc: ")
+        (display gc-msecs)
+        (display " (")
+        (display (- (gc-count) gc-start-count))
+        (display " times)\n")
         (display "result: ")
         (write result)
         (newline)

benchmarks/gabriel/difftimes.sh

@@ -0,0 +1,34 @@
+#!/bin/bash
+
+# set -ex
+
+BENCHDIR=$(dirname $0)
+if [ "${BENCHDIR%%/*}" = "." ]; then
+    BENCHDIR="$(pwd)${BENCHDIR#.}"
+fi
+
+TS1="${1:--2}"
+TS2="${2:--1}"
+DB="${3:-${BENCHDIR}/times.tsv}"
+
+if [ "$TS1" -lt 1000000000 ]; then
+    SORT_OPTS='-nu'
+    if [ "$TS1" -lt 0 ]; then
+        SORT_OPTS='-nru'
+        TS1=$((0 - TS1))
+    fi
+    TS1=$(cut -f 7 "$DB" | sort "$SORT_OPTS" | tail -n +$TS1 | head -1)
+fi
+if [ "$TS2" -lt 1000000000 ]; then
+    SORT_OPTS='-nu'
+    if [ "$TS2" -lt 0 ]; then
+        SORT_OPTS='-nru'
+        TS2=$((0 - TS2))
+    fi
+    TS2=$(cut -f 7 "$DB" | sort "$SORT_OPTS" | tail -n +$TS2 | head -1)
+fi
+
+join -t $'\t' \
+     <(grep $'\t'"$TS1"$'\t' "$DB" | cut -f 1-2,5) \
+     <(grep $'\t'"$TS2"$'\t' "$DB" | cut -f 1-2,5) \
+    | perl -F'\t' -ane 'sub gain{($_[0]<=0)?0:100*($_[1]-$_[0])/$_[0]} $u=gain($F[1], $F[3]); $g=gain($F[2], $F[4]); printf STDOUT "%s\t%d\t%d\t%.2f%%\t%d\t%d\t%.2f%%\n", $F[0], $F[1], $F[3], $u, $F[2], $F[4], $g'

benchmarks/gabriel/run.sh

@@ -1,16 +1,32 @@
 #!/bin/sh
 
-BENCHDIR=$(dirname $0)
-if [ "${BENCHDIR%%/*}" == "." ]; then
-    BENCHDIR=$(pwd)${BENCHDIR#.}
-fi
-CHIBIHOME=${BENCHDIR%%/benchmarks/gabriel}
-CHIBI="${CHIBI:-${CHIBIHOME}/chibi-scheme} -I$CHIBIHOME"
+# set -ex
 
-cd $BENCHDIR
+BENCHDIR=$(dirname $0)
+if [ "${BENCHDIR%%/*}" = "." ]; then
+    BENCHDIR="$(pwd)${BENCHDIR#.}"
+fi
+OUTPUT="$BENCHDIR/out.txt"
+DB="$BENCHDIR/times.tsv"
+CHIBIHOME="${BENCHDIR%%/benchmarks/gabriel}"
+CHIBI="${CHIBI:-${CHIBIHOME}/chibi-scheme} -I$CHIBIHOME"
+HEAP="2M"
+
+cd "$BENCHDIR"
 for t in *.sch; do
-    echo "${t%%.sch}"
+    echo "program: ${t%%.sch}"
     LD_LIBRARY_PATH="$CHIBIHOME" DYLD_LIBRARY_PATH="$CHIBIHOME" \
-        $CHIBI -I"$CHIBIHOME/lib" -q -lchibi-prelude.scm $t
-done
+        $CHIBI -I"$CHIBIHOME/lib" -h"$HEAP" -q -lchibi-prelude.scm "$t"
+done | tee "$OUTPUT"
 cd -
+
+if [ ! -f "$DB" ]; then
+    echo $'program\tuser_ms\tsystem_ms\treal_ms\tgc_ms\tgc_count\ttimestamp\tcommit\tfeatures\tinit_heap\tcpu' > "$DB"
+fi
+
+#DATE=$(date -Iseconds)
+DATE=$(date +%s)
+COMMIT=$(git -C "$CHIBIHOME" rev-parse HEAD)
+FEATURES=$(LD_LIBRARY_PATH="$CHIBIHOME" DYLD_LIBRARY_PATH="$CHIBIHOME" $CHIBI -q -p'(cddr *features*)' | tr ' ' , | tr -d '()')
+CPU=$(lscpu | perl -ne 'if (s/^Model name:\s*//){s/\b(Intel|Core|Atom|AMD|CPU)(\s*\(\w+\))?\s*//gi;s/\s*@\s*[.\d]+[KMGT]Hz\b\s*//gi;print}')
+perl -ane 'if (/^program:\s*(\w+)/) {$p=$1} elsif (/^user:\s*(\d+)\s*system:\s*(\d+)\s*real:\s*(\d+)(?:\s*gc:\s*(\d+)\s*(?:\((\d+)\s*times\))?)?/) {print"$p\t$1\t$2\t$3\t$4\t$5\t'"$DATE"'\t'"$COMMIT"'\t'"$FEATURES"'\t'"$HEAP"'\t'"$CPU"'\n"}' "$OUTPUT" >> "$DB"

bignum.c

@@ -35,38 +35,91 @@ sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) {
   return res;
 }
 
-sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) {
+sexp sexp_make_integer_from_lsint (sexp ctx, sexp_lsint_t x) {
   sexp res;
-  if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) {
-    res = sexp_make_fixnum(x);
-  } else {
+  if (lsint_is_fixnum(x)) {
+    res = sexp_make_fixnum(lsint_to_sint(x));
+  } else if (sexp_lsint_fits_sint(x)) {
     res = sexp_make_bignum(ctx, 1);
-    if (x < 0) {
+    if (lsint_lt_0(x)) {
       sexp_bignum_sign(res) = -1;
-      sexp_bignum_data(res)[0] = -x;
+      sexp_bignum_data(res)[0] = (sexp_uint_t)-lsint_to_sint(x);
     } else {
       sexp_bignum_sign(res) = 1;
-      sexp_bignum_data(res)[0] = x;
+      sexp_bignum_data(res)[0] = (sexp_uint_t)lsint_to_sint(x);
+    }
+  } else {
+    res = sexp_make_bignum(ctx, 2);
+    if (lsint_lt_0(x)) {
+      sexp_bignum_sign(res) = -1;
+      sexp_bignum_data(res)[0] = (sexp_uint_t)-lsint_to_sint(x);
+      sexp_bignum_data(res)[1] = (sexp_uint_t)~lsint_to_sint_hi(x);
+    } else {
+      sexp_bignum_sign(res) = 1;
+      sexp_bignum_data(res)[0] = (sexp_uint_t)lsint_to_sint(x);
+      sexp_bignum_data(res)[1] = (sexp_uint_t)lsint_to_sint_hi(x);
     }
   }
   return res;
 }
 
-sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
+sexp sexp_make_unsigned_integer_from_luint (sexp ctx, sexp_luint_t x) {
   sexp res;
-  if (x <= SEXP_MAX_FIXNUM) {
-    res = sexp_make_fixnum(x);
-  } else {
+  if (luint_is_fixnum(x)) {
+    res = sexp_make_fixnum(luint_to_uint(x));
+  } else if (sexp_luint_fits_uint(x)) {
     res = sexp_make_bignum(ctx, 1);
     sexp_bignum_sign(res) = 1;
-    sexp_bignum_data(res)[0] = x;
+    sexp_bignum_data(res)[0] = luint_to_uint(x);
+  } else {
+    res = sexp_make_bignum(ctx, 2);
+    sexp_bignum_sign(res) = 1;
+    sexp_bignum_data(res)[0] = luint_to_uint(x);
+    sexp_bignum_data(res)[1] = luint_to_uint_hi(x);
   }
   return res;
 }
 
+#if SEXP_USE_CUSTOM_LONG_LONGS
+sexp sexp_make_integer(sexp ctx, long long x) {
+  return sexp_make_integer_from_lsint(ctx, lsint_from_sint(x));
+}
+sexp sexp_make_unsigned_integer(sexp ctx, unsigned long long x) {
+  return sexp_make_unsigned_integer_from_luint(ctx, luint_from_uint(x));
+}
+#else
+sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) {
+  return sexp_make_integer_from_lsint(ctx, x);
+}
+sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
+  return sexp_make_unsigned_integer_from_luint(ctx, x);
+}
+#endif
+
+#if !SEXP_64_BIT
+long long sexp_bignum_to_sint(sexp x) {
+  if (!sexp_bignump(x))
+    return 0;
+  if (sexp_bignum_length(x) > 1)
+    return sexp_bignum_sign(x) * (
+      (((long long)(sexp_bignum_data(x)[1]))<<(8*sizeof(sexp_bignum_data(x)[0]))) + sexp_bignum_data(x)[0]);
+  return sexp_bignum_sign(x) * sexp_bignum_data(x)[0];
+}
+
+unsigned long long sexp_bignum_to_uint(sexp x) {
+  if (!sexp_bignump(x))
+    return 0;
+  if (sexp_bignum_length(x) > 1)
+    return (((unsigned long long)(sexp_bignum_data(x)[1]))<<(8*sizeof(sexp_bignum_data(x)[0]))) + sexp_bignum_data(x)[0];
+  return sexp_bignum_data(x)[0];
+}
+#endif
+
 #define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0)
 #define double_10s_digit(f) ((f)-double_trunc_10s_digit(f))
 
+#define double_16s_digit(f) fmod(f,16.0)
+
 sexp sexp_double_to_bignum (sexp ctx, double f) {
   int sign;
   sexp_gc_var3(res, scale, tmp);
@@ -74,10 +127,10 @@ sexp sexp_double_to_bignum (sexp ctx, double f) {
   res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
   scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
   sign = (f < 0 ? -1 : 1);
-  for (f=fabs(f); f >= 1.0; f=trunc(f/10)) {
-    tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0);
+  for (f=fabs(f); f >= 1.0; f=trunc(f/16)) {
+    tmp = sexp_bignum_fxmul(ctx, NULL, scale, (sexp_uint_t)double_16s_digit(f), 0);
     res = sexp_bignum_add(ctx, res, res, tmp);
-    scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0);
+    scale = sexp_bignum_fxmul(ctx, NULL, scale, 16, 0);
   }
   sexp_bignum_sign(res) = sign;
   sexp_gc_release3(ctx);
@@ -135,7 +188,8 @@ sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) {
 sexp_sint_t sexp_bignum_compare (sexp a, sexp b) {
   if (sexp_bignum_sign(a) != sexp_bignum_sign(b))
     return sexp_bignum_sign(a);
-  return sexp_bignum_compare_abs(a, b);
+  sexp_sint_t cmp = sexp_bignum_compare_abs(a, b);
+  return sexp_bignum_sign(a) < 0 ? -cmp : cmp;
 }
 
 sexp sexp_bignum_normalize (sexp a) {
@@ -198,9 +252,9 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
   tmp = d;
   data = sexp_bignum_data(d);
   for (i=0; i<len; i++) {
-    n = (sexp_luint_t)adata[i]*b + carry;
-    data[i+offset] = (sexp_uint_t)n;
-    carry = n >> (sizeof(sexp_uint_t)*8);
+    n = luint_add(luint_mul_uint(luint_from_uint(adata[i]), b), luint_from_uint(carry));
+    data[i+offset] = luint_to_uint(n);
+    carry = luint_to_uint(luint_shr(n, (sizeof(sexp_uint_t)*8)));
   }
   if (carry) {
     if (sexp_bignum_length(d) <= len+offset)
@@ -214,13 +268,13 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
 sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
   sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0;
   int i;
-  sexp_luint_t n = 0;
+  sexp_luint_t n = luint_from_uint(0);
   for (i=len-1; i>=offset; i--) {
-    n = (n << sizeof(sexp_uint_t)*8) + data[i];
-    q = n / b;
-    r = n - (sexp_luint_t)q * b;
+    n = luint_add(luint_shl(n,  sizeof(sexp_uint_t)*8), luint_from_uint(data[i]));
+    q = luint_to_uint(luint_div_uint(n, b));
+    r = luint_to_uint(luint_sub(n, luint_mul_uint(luint_from_uint(q),  b)));
     data[i] = q;
-    n = r;
+    n = luint_from_uint(r);
   }
   return r;
 }
@@ -228,32 +282,35 @@ sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
 sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) {
   sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, b0;
   int i;
-  sexp_luint_t n = 0;
+  sexp_luint_t n = luint_from_uint(0);
   if (b > 0) {
     q = b - 1;
     if ((b & q) == 0)
       return sexp_make_fixnum(sexp_bignum_sign(a) * (data[0] & q));
   }
   b0 = (b >= 0) ? b : -b;
-  for (i=len-1; i>=0; i--) {
-    n = (n << sizeof(sexp_uint_t)*8) + data[i];
-    q = n / b0;
-    n -= (sexp_luint_t)q * b0;
+  if (b0 == 0) {
+    return sexp_xtype_exception(ctx, NULL, "divide by zero", a);
   }
-  return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)n);
+  for (i=len-1; i>=0; i--) {
+    n = luint_add(luint_shl(n, sizeof(sexp_uint_t)*8), luint_from_uint(data[i]));
+    q = luint_to_uint(luint_div_uint(n, b0));
+    n = luint_sub(n, luint_mul_uint(luint_from_uint(q), b0));
+  }
+  return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)luint_to_uint(n));
 }
 
 sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
                        signed char sign, sexp_uint_t base) {
   int c, digit;
-  sexp_gc_var1(res);
-  sexp_gc_preserve1(ctx, res);
+  sexp_gc_var3(res, tmp, imag);
+  sexp_gc_preserve3(ctx, res, tmp, imag);
   res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE);
   sexp_bignum_sign(res) = sign;
   sexp_bignum_data(res)[0] = init;
   for (c=sexp_read_char(ctx, in); sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
     digit = digit_value(c);
-    if ((digit < 0) || (digit >= base))
+    if ((digit < 0) || (digit >= (int)base))
       break;
     res = sexp_bignum_fxmul(ctx, res, res, base, 0);
     res = sexp_bignum_fxadd(ctx, res, digit);
@@ -261,9 +318,32 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
   if (c=='.' || c=='e' || c=='E') {
     if (base != 10) {
       res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
-    } else {
-      if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */
+    } else if (c=='.') {
       res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1));
+    } else {
+      tmp = sexp_read_number(ctx, in, base, 0);
+#if SEXP_USE_COMPLEX
+      if (sexp_complexp(tmp)) {
+        imag = sexp_complex_imag(tmp);
+        tmp = sexp_complex_real(tmp);
+      } else {
+        imag = SEXP_ZERO;
+      }
+#endif
+      if (sexp_exceptionp(tmp)) {
+        res = tmp;
+      } else if (sexp_fixnump(tmp) && labs(sexp_unbox_fixnum(tmp)) < 100*1024*1024) {
+        tmp = sexp_expt(ctx, SEXP_TEN, tmp);
+        res = sexp_mul(ctx, res, tmp);
+      } else {
+        tmp = sexp_exact_to_inexact(ctx, NULL, 2, tmp);
+        tmp = sexp_expt(ctx, SEXP_TEN, tmp);
+        res = sexp_mul(ctx, res, tmp);
+      }
+#if SEXP_USE_COMPLEX
+      if (imag != SEXP_ZERO && !sexp_exceptionp(res))
+        res = sexp_make_complex(ctx, res, imag);
+#endif
     }
 #if SEXP_USE_RATIOS
   } else if (c=='/') {
@@ -284,7 +364,7 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
   } else {
     sexp_push_char(ctx, c, in);
   }
-  sexp_gc_release1(ctx);
+  sexp_gc_release3(ctx);
   return sexp_bignum_normalize(res);
 }
 
@@ -303,6 +383,9 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) {
   sexp_gc_preserve2(ctx, b, str);
   b = sexp_copy_bignum(ctx, NULL, a, 0);
   sexp_bignum_sign(b) = 1;
+  if (lg_base < 1) {
+    return sexp_xtype_exception(ctx, NULL, "number base too small", a);
+  }
   i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1)
     / lg_base + 1;
   str = sexp_make_string(ctx, sexp_make_fixnum(str_len),
@@ -512,44 +595,44 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
   sexp_bignum_sign(b1) = 1;
   q = SEXP_ZERO;
   x = sexp_make_bignum(ctx, sexp_bignum_length(a));
-  while (sexp_bignum_compare_abs(a1, b1) > 0) { /* a1, b1 at least 2 bigits */
+  while (sexp_bignum_compare_abs(a1, b1) >= 0) { /* a1, b1 at least 2 bigits */
     /* guess divisor x */
     alen = sexp_bignum_hi(a1);
     sexp_bignum_data(x)[off] = 0;
     if (off > 0) sexp_bignum_data(x)[off-1] = 0;
     off = alen - blen + 1;
-    dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
-           << (sizeof(sexp_uint_t)*8))
-          + sexp_bignum_data(a1)[alen-2]);
-    dd = (((sexp_luint_t)sexp_bignum_data(b1)[blen-1]
-           << (sizeof(sexp_uint_t)*8))
-          + sexp_bignum_data(b1)[blen-2]);
+    dn = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(a1)[alen-1])
+           , (sizeof(sexp_uint_t)*8))
+          , sexp_bignum_data(a1)[alen-2]);
+    dd = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(b1)[blen-1])
+           , (sizeof(sexp_uint_t)*8))
+          , sexp_bignum_data(b1)[blen-2]);
     if (alen > 2 && blen > 2 &&
-        sexp_bignum_data(a1)[alen-1] < (1uL<<(sizeof(sexp_uint_t)*4)) &&
-        sexp_bignum_data(b1)[blen-1] < (1uL<<(sizeof(sexp_uint_t)*4))) {
-      dn = (dn << (sizeof(sexp_uint_t)*4))
-        + (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4));
-      dd = (dd << (sizeof(sexp_uint_t)*4))
-        + (sexp_bignum_data(b1)[blen-3] >> (sizeof(sexp_uint_t)*4));
+        luint_lt(luint_from_uint(sexp_bignum_data(a1)[alen-1]), luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4))) &&
+        luint_lt(luint_from_uint(sexp_bignum_data(b1)[blen-1]), luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4)))) {
+      dn = luint_add_uint(luint_shl(dn, (sizeof(sexp_uint_t)*4))
+        , (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4)));
+      dd = luint_add_uint(luint_shl(dd, (sizeof(sexp_uint_t)*4))
+        , (sexp_bignum_data(b1)[blen-3] >> (sizeof(sexp_uint_t)*4)));
     }
-    d = dn / dd;
-    if (d == 0) {
-      dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
-             << (sizeof(sexp_uint_t)*8))
-            + sexp_bignum_data(a1)[alen-2]);
-      dd = sexp_bignum_data(b1)[blen-1];
-      if (sexp_bignum_data(a1)[alen-1] < (1uL<<(sizeof(sexp_uint_t)*4)) &&
-          sexp_bignum_data(b1)[blen-1] < (1uL<<(sizeof(sexp_uint_t)*4))) {
-        dn = (dn << (sizeof(sexp_uint_t)*4))
-          + (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4));
-        dd = (dd << (sizeof(sexp_uint_t)*4))
-          + (sexp_bignum_data(b1)[blen-2] >> (sizeof(sexp_uint_t)*4));
+    d = luint_div(dn, dd);
+    if (luint_eq(d, luint_from_uint(0))) {
+      dn = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(a1)[alen-1])
+             , (sizeof(sexp_uint_t)*8))
+            , sexp_bignum_data(a1)[alen-2]);
+      dd = luint_from_uint(sexp_bignum_data(b1)[blen-1]);
+      if (luint_lt(luint_from_uint(sexp_bignum_data(a1)[alen-1]), (luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4)))) &&
+          luint_lt(luint_from_uint(sexp_bignum_data(b1)[blen-1]), (luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4))))) {
+        dn = luint_add_uint(luint_shl(dn, (sizeof(sexp_uint_t)*4))
+          , (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4)));
+        dd = luint_add_uint(luint_shl(dd, (sizeof(sexp_uint_t)*4))
+          , (sexp_bignum_data(b1)[blen-2] >> (sizeof(sexp_uint_t)*4)));
       }
-      d = dn / dd;
+      d = luint_div(dn, dd);
       off--;
     }
-    dhi = d >> (sizeof(sexp_uint_t)*8);
-    dlo = d & (((sexp_luint_t)1<<(sizeof(sexp_uint_t)*8))-1);
+    dhi = luint_to_uint(luint_shr(d, (sizeof(sexp_uint_t)*8)));
+    dlo = luint_to_uint(luint_and(d, luint_sub(luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*8)), luint_from_uint(1))));
     sexp_bignum_data(x)[off] = dhi;
     if (off > 0) sexp_bignum_data(x)[off-1] = dlo;
     /* update quotient q and remainder a1 estimates */
@@ -563,12 +646,13 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
     }
     /* flip the sign if we overshot in our estimate */
     if (sexp_bignum_sign(a1) != sign) {
-      sexp_bignum_sign(a1) = -sign;
+      sexp_bignum_sign(a1) = (char)(-sign);
       sign *= -1;
     }
   }
   /* adjust signs */
-  if (sign < 0) {
+  a1 = sexp_bignum_normalize(a1);
+  if (sign < 0 && a1 != SEXP_ZERO) {
     q = sexp_sub(ctx, q, SEXP_ONE);
     a1 = sexp_add(ctx, a1, b1);
   }
@@ -601,14 +685,21 @@ sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) {
 }
 
 sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) {
-  sexp_sint_t e = sexp_unbox_fx_abs(b);
+  sexp_sint_t e = sexp_unbox_fixnum(b);
+  sexp_sint_t abs_e;
+  if (e < 0)
+    abs_e = -e;
+  else
+    abs_e = e;
   sexp_gc_var2(res, acc);
   sexp_gc_preserve2(ctx, res, acc);
   res = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
   acc = sexp_copy_bignum(ctx, NULL, a, 0);
-  for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
-    if (e & 1)
+  for (; abs_e; abs_e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
+    if (abs_e & 1)
       res = sexp_bignum_mul(ctx, NULL, res, acc);
+  if (e < 0)
+    res = sexp_div(ctx, sexp_fixnum_to_bignum(ctx, SEXP_ONE), res);
   sexp_gc_release2(ctx);
   return sexp_bignum_normalize(res);
 }
@@ -644,7 +735,7 @@ sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) {
   if (! sexp_bignump(a)) return sexp_type_exception(ctx, NULL, SEXP_BIGNUM, a);
   sexp_gc_preserve4(ctx, res, rem, tmp, tmpa);
   /* initial estimate via flonum, ignoring signs */
-  if (sexp_negativep(a)) {
+  if (sexp_exact_negativep(a)) {
     tmpa = sexp_copy_bignum(ctx, NULL, a, 0);
     a = tmpa;
     sexp_negate(a);
@@ -688,12 +779,25 @@ sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) {
 
 #if SEXP_USE_RATIOS
 
-double sexp_ratio_to_double (sexp rat) {
+double sexp_ratio_to_double (sexp ctx, sexp rat) {
+  sexp_gc_var1(quot);
   sexp num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
-  return (sexp_bignump(num) ? sexp_bignum_to_double(num)
+  double res = (sexp_bignump(num) ? sexp_bignum_to_double(num)
           : sexp_fixnum_to_double(num))
     / (sexp_bignump(den) ? sexp_bignum_to_double(den)
        : sexp_fixnum_to_double(den));
+  if (!isfinite(res)) {
+    sexp_gc_preserve1(ctx, quot);
+    if (sexp_unbox_fixnum(sexp_compare(ctx, sexp_ratio_numerator(rat),  sexp_ratio_denominator(rat))) < 0) {
+      quot = sexp_quotient(ctx, sexp_ratio_denominator(rat),  sexp_ratio_numerator(rat));
+      res = 1 / sexp_to_double(ctx, quot);
+    } else {
+      quot = sexp_quotient(ctx, sexp_ratio_numerator(rat),  sexp_ratio_denominator(rat));
+      res = sexp_to_double(ctx, quot);
+    }
+    sexp_gc_release1(ctx);
+  }
+  return res;
 }
 
 sexp sexp_double_to_ratio (sexp ctx, double f) {
@@ -709,7 +813,7 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
   for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) {
     res = sexp_bignum_fxmul(ctx, NULL, res, 10, 0);
     f = f * 10;
-    res = sexp_bignum_fxadd(ctx, res, double_10s_digit(f));
+    res = sexp_bignum_fxadd(ctx, res, (sexp_uint_t)double_10s_digit(f));
     f = f - trunc(f);
     scale = sexp_mul(ctx, scale, SEXP_TEN);
   }
@@ -723,6 +827,41 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
   return res;
 }
 
+/*
+ * For conversion that does not introduce round-off error,
+ * no matter what FLT_RADIX is.
+ */
+sexp sexp_double_to_ratio_2 (sexp ctx, double f) {
+  int sign,i;
+  sexp_gc_var3(res, whole, scale);
+  if (f == trunc(f))
+    return sexp_bignum_normalize(sexp_double_to_bignum(ctx, f));
+  sexp_gc_preserve3(ctx, res, whole, scale);
+  whole = sexp_double_to_bignum(ctx, trunc(f));
+  res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
+  scale = SEXP_ONE;
+  sign = (f < 0 ? -1 : 1);
+  f = fabs(f-trunc(f));
+  while(f) {
+    res = sexp_bignum_fxmul(ctx, NULL, res, FLT_RADIX, 0);
+    scale = sexp_mul(ctx, scale, sexp_make_fixnum(FLT_RADIX));
+    f *= FLT_RADIX;
+    i = trunc(f);
+    if (i) {
+      f -= i;
+      res = sexp_bignum_fxadd(ctx, res, i);
+    }
+  }
+  sexp_bignum_sign(res) = sign;
+  res = sexp_bignum_normalize(res);
+  scale = sexp_bignum_normalize(scale);
+  res = sexp_make_ratio(ctx, res, scale);
+  res = sexp_ratio_normalize(ctx, res, SEXP_FALSE);
+  res = sexp_add(ctx, res, whole);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
 sexp sexp_ratio_add (sexp ctx, sexp a, sexp b) {
   sexp_gc_var3(res, num, den);
   sexp_gc_preserve3(ctx, res, num, den);
@@ -773,13 +912,13 @@ sexp sexp_ratio_round (sexp ctx, sexp a) {
   sexp_gc_preserve2(ctx, q, r);
   q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
   if ((sexp_ratio_denominator(a) == SEXP_TWO) && sexp_oddp(q)) {
-    q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
+    q = sexp_add(ctx, q, (sexp_exact_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
   } else {
     r = sexp_remainder(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
     r = sexp_mul(ctx, r, SEXP_TWO);
-    if (sexp_negativep(r)) {sexp_negate(r);}
+    if (sexp_exact_negativep(r)) {sexp_negate(r);}
     if (sexp_unbox_fixnum(sexp_compare(ctx, r, sexp_ratio_denominator(a))) > 0)
-      q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
+      q = sexp_add(ctx, q, (sexp_exact_negativep(sexp_ratio_numerator(a)) ? SEXP_NEG_ONE : SEXP_ONE));
   }
   sexp_gc_release2(ctx);
   return q;
@@ -793,7 +932,7 @@ sexp sexp_ratio_floor (sexp ctx, sexp a) {
   sexp_gc_var1(q);
   sexp_gc_preserve1(ctx, q);
   q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
-  if (sexp_negativep(sexp_ratio_numerator(a)))
+  if (sexp_exact_negativep(sexp_ratio_numerator(a)))
     q = sexp_add(ctx, q, SEXP_NEG_ONE);
   sexp_gc_release1(ctx);
   return q;
@@ -803,7 +942,7 @@ sexp sexp_ratio_ceiling (sexp ctx, sexp a) {
   sexp_gc_var1(q);
   sexp_gc_preserve1(ctx, q);
   q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
-  if (sexp_positivep(sexp_ratio_numerator(a)))
+  if (sexp_exact_positivep(sexp_ratio_numerator(a)))
     q = sexp_add(ctx, q, SEXP_ONE);
   sexp_gc_release1(ctx);
   return q;
@@ -811,6 +950,21 @@ sexp sexp_ratio_ceiling (sexp ctx, sexp a) {
 
 #endif
 
+double sexp_to_double (sexp ctx, sexp x) {
+  if (sexp_flonump(x))
+    return sexp_flonum_value(x);
+  else if (sexp_fixnump(x))
+    return sexp_fixnum_to_double(x);
+  else if (sexp_bignump(x))
+    return sexp_bignum_to_double(x);
+#if SEXP_USE_RATIOS
+  else if (sexp_ratiop(x))
+    return sexp_ratio_to_double(ctx, x);
+#endif
+  else
+    return 0.0;
+}
+
 /************************ complex numbers ****************************/
 
 #if SEXP_USE_COMPLEX
@@ -845,8 +999,8 @@ sexp sexp_complex_sub (sexp ctx, sexp a, sexp b) {
   sexp_gc_var2(res, tmp);
   sexp_gc_preserve2(ctx, res, tmp);
   tmp = sexp_complex_copy(ctx, b);
-  sexp_negate(sexp_complex_real(tmp));
-  sexp_negate(sexp_complex_imag(tmp));
+  sexp_negate_maybe_ratio(sexp_complex_real(tmp));
+  sexp_negate_maybe_ratio(sexp_complex_imag(tmp));
   res = sexp_complex_add(ctx, a, tmp);
   sexp_gc_release2(ctx);
   return res;
@@ -892,21 +1046,6 @@ sexp sexp_complex_div (sexp ctx, sexp a, sexp b) {
   return sexp_complex_normalize(res);
 }
 
-static double sexp_to_double (sexp x) {
-  if (sexp_flonump(x))
-    return sexp_flonum_value(x);
-  else if (sexp_fixnump(x))
-    return sexp_fixnum_to_double(x);
-  else if (sexp_bignump(x))
-    return sexp_bignum_to_double(x);
-#if SEXP_USE_RATIOS
-  else if (sexp_ratiop(x))
-    return sexp_ratio_to_double(x);
-#endif
-  else
-    return 0.0;
-}
-
 static sexp sexp_to_complex (sexp ctx, sexp x) {
 #if SEXP_USE_RATIOS
   sexp_gc_var1(tmp);
@@ -917,7 +1056,7 @@ static sexp sexp_to_complex (sexp ctx, sexp x) {
   } else if (sexp_ratiop(x)) {
     sexp_gc_preserve1(ctx, tmp);
     tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
-    sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(x));
+    sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(ctx, x));
     sexp_gc_release1(ctx);
     return tmp;
 #endif
@@ -927,8 +1066,8 @@ static sexp sexp_to_complex (sexp ctx, sexp x) {
 }
 
 sexp sexp_complex_exp (sexp ctx, sexp z) {
-  double e2x = exp(sexp_to_double(sexp_complex_real(z))),
-    y = sexp_to_double(sexp_complex_imag(z));
+  double e2x = exp(sexp_to_double(ctx, sexp_complex_real(z))),
+    y = sexp_to_double(ctx, sexp_complex_imag(z));
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
   res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
@@ -939,8 +1078,8 @@ sexp sexp_complex_exp (sexp ctx, sexp z) {
 }
 
 sexp sexp_complex_log (sexp ctx, sexp z) {
-  double x = sexp_to_double(sexp_complex_real(z)),
-    y = sexp_to_double(sexp_complex_imag(z));
+  double x = sexp_to_double(ctx, sexp_complex_real(z)),
+    y = sexp_to_double(ctx, sexp_complex_imag(z));
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
   res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
@@ -964,21 +1103,21 @@ sexp sexp_complex_expt (sexp ctx, sexp a, sexp b) {
 #if SEXP_USE_MATH
 
 sexp sexp_complex_sqrt (sexp ctx, sexp z) {
-  double x = sexp_to_double(sexp_complex_real(z)),
-    y = sexp_to_double(sexp_complex_imag(z)), r;
+  double x = sexp_to_double(ctx, sexp_complex_real(z)),
+    y = sexp_to_double(ctx, sexp_complex_imag(z)), r;
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
   r = sqrt(x*x + y*y);
   res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
   sexp_complex_real(res) = sexp_make_flonum(ctx, sqrt((x+r)/2));
-  sexp_complex_imag(res) = sexp_make_flonum(ctx, (y<0?-1:1)*sqrt((-x+r)/2));
+  sexp_complex_imag(res) = sexp_make_flonum(ctx, ((y<-0.0)?-1:1)*sqrt((-x+r)/2));
   sexp_gc_release1(ctx);
   return res;
 }
 
 sexp sexp_complex_sin (sexp ctx, sexp z) {
-  double x = sexp_to_double(sexp_complex_real(z)),
-    y = sexp_to_double(sexp_complex_imag(z));
+  double x = sexp_to_double(ctx, sexp_complex_real(z)),
+    y = sexp_to_double(ctx, sexp_complex_imag(z));
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
   res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
@@ -989,8 +1128,8 @@ sexp sexp_complex_sin (sexp ctx, sexp z) {
 }
 
 sexp sexp_complex_cos (sexp ctx, sexp z) {
-  double x = sexp_to_double(sexp_complex_real(z)),
-    y = sexp_to_double(sexp_complex_imag(z));
+  double x = sexp_to_double(ctx, sexp_complex_real(z)),
+    y = sexp_to_double(ctx, sexp_complex_imag(z));
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
   res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
@@ -1012,22 +1151,19 @@ sexp sexp_complex_tan (sexp ctx, sexp z) {
 }
 
 sexp sexp_complex_asin (sexp ctx, sexp z) {
-  sexp_gc_var2(res, tmp);
-  sexp_gc_preserve2(ctx, res, tmp);
+  sexp_gc_var3(res, tmp, tmp2);
+  sexp_gc_preserve3(ctx, res, tmp, tmp2);
   res = sexp_complex_mul(ctx, z, z);
-  tmp = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO);
-  res = sexp_complex_sub(ctx, tmp, res);
-  res = sexp_complex_sqrt(ctx, res);
-  /* tmp = iz */
-  sexp_complex_real(tmp) = sexp_complex_imag(z);
-  sexp_negate(sexp_complex_real(tmp));
+  res = sexp_sub(ctx, SEXP_ONE, res);
+  res = sexp_sqrt(ctx, NULL, 1, res);
+  tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+  sexp_complex_real(tmp) = sexp_mul(ctx, SEXP_NEG_ONE, sexp_complex_imag(z));
   sexp_complex_imag(tmp) = sexp_complex_real(z);
-  res = sexp_complex_add(ctx, tmp, res);
-  tmp = sexp_complex_log(ctx, res);
-  /* res = -i*tmp */
-  res = sexp_complex_copy(ctx, tmp);
-  sexp_negate(sexp_complex_imag(res));
-  sexp_gc_release2(ctx);
+  res = sexp_add(ctx, tmp, res);
+  res = sexp_log(ctx, NULL, 1, res);
+  tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_NEG_ONE);
+  res = sexp_mul(ctx, res, tmp);
+  sexp_gc_release3(ctx);
   return res;
 }
 
@@ -1191,7 +1327,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
       r = sexp_make_fixnum(sum);
     break;
   case SEXP_NUM_FIX_FLO:
-    r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
+    r = a == SEXP_ZERO ? b : sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
     break;
   case SEXP_NUM_FIX_BIG:
     r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a));
@@ -1207,7 +1343,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
     break;
 #if SEXP_USE_RATIOS
   case SEXP_NUM_FLO_RAT:
-    r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_ratio_to_double(b));
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_ratio_to_double(ctx, b));
     break;
   case SEXP_NUM_FIX_RAT:
   case SEXP_NUM_BIG_RAT:
@@ -1267,7 +1403,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
     r = sexp_fx_sub(a, b);      /* VM catches this case */
     break;
   case SEXP_NUM_FIX_FLO:
-    r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b));
+    r = sexp_make_flonum(ctx, a==SEXP_ZERO ? -sexp_flonum_value(b) : sexp_fixnum_to_double(a)-sexp_flonum_value(b));
     break;
   case SEXP_NUM_FIX_BIG:
     tmp1 = sexp_fixnum_to_bignum(ctx, a);
@@ -1296,10 +1432,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
     break;
 #if SEXP_USE_RATIOS
   case SEXP_NUM_FLO_RAT:
-    r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_ratio_to_double(b));
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_ratio_to_double(ctx, b));
     break;
   case SEXP_NUM_RAT_FLO:
-    r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) - sexp_flonum_value(b));
+    r = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a) - sexp_flonum_value(b));
     break;
   case SEXP_NUM_RAT_FIX:
   case SEXP_NUM_RAT_BIG:
@@ -1317,21 +1453,17 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
     sexp_negate_exact(sexp_ratio_numerator(tmp2));
     r = sexp_ratio_add(ctx, a, tmp2);
     if (negatep) {
-      if (sexp_ratiop(r)) {
-        sexp_negate_exact(sexp_ratio_numerator(r));
-      } else {
-        sexp_negate_exact(r);
-      }
+      sexp_negate_maybe_ratio(r);
     }
     break;
 #endif
 #if SEXP_USE_COMPLEX
 #if SEXP_USE_RATIOS
   case SEXP_NUM_RAT_CPX:
-    a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
+    a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a));
     goto complex_sub;
   case SEXP_NUM_CPX_RAT:
-    b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
+    b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, b));
     /* ... FALLTHROUGH ... */
 #endif
   case SEXP_NUM_CPX_FLO:
@@ -1353,10 +1485,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
     if (negatep) {
       if (sexp_complexp(r)) {
         r = sexp_complex_copy(ctx, r);
-        sexp_negate(sexp_complex_real(r));
-        sexp_negate(sexp_complex_imag(r));
+        sexp_negate_maybe_ratio(sexp_complex_real(r));
+        sexp_negate_maybe_ratio(sexp_complex_imag(r));
       } else {
-        sexp_negate(r);
+        sexp_negate_maybe_ratio(r);
       }
     }
     break;
@@ -1382,11 +1514,11 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
     r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
     break;
   case SEXP_NUM_FIX_FIX:
-    prod = (sexp_lsint_t)sexp_unbox_fixnum(a) * sexp_unbox_fixnum(b);
-    if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM))
+    prod = lsint_mul_sint(lsint_from_sint(sexp_unbox_fixnum(a)), sexp_unbox_fixnum(b));
+    if (!lsint_is_fixnum(prod))
       r = sexp_mul(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
     else
-      r = sexp_make_fixnum(prod);
+      r = sexp_make_fixnum(lsint_to_sint(prod));
     break;
   case SEXP_NUM_FIX_FLO:
     r = (a==SEXP_ZERO ? a : sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)));
@@ -1407,7 +1539,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
     break;
 #if SEXP_USE_RATIOS
   case SEXP_NUM_FLO_RAT:
-    r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_ratio_to_double(b));
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_ratio_to_double(ctx, b));
     break;
   case SEXP_NUM_FIX_RAT:
   case SEXP_NUM_BIG_RAT:
@@ -1514,10 +1646,10 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
     break;
 #if SEXP_USE_RATIOS
   case SEXP_NUM_FLO_RAT:
-    r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_ratio_to_double(b));
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_ratio_to_double(ctx, b));
     break;
   case SEXP_NUM_RAT_FLO:
-    r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) / sexp_flonum_value(b));
+    r = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a) / sexp_flonum_value(b));
     break;
   case SEXP_NUM_RAT_FIX:
   case SEXP_NUM_RAT_BIG:
@@ -1535,7 +1667,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
 #if SEXP_USE_COMPLEX
 #if SEXP_USE_RATIOS
   case SEXP_NUM_CPX_RAT:
-    b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
+    b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, b));
     /* ... FALLTHROUGH ... */
 #endif
   case SEXP_NUM_CPX_FLO:
@@ -1546,7 +1678,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
 #if SEXP_USE_RATIOS
   case SEXP_NUM_RAT_CPX:
     if (sexp_ratiop(a))
-      a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
+      a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a));
     /* ... FALLTHROUGH ... */
 #endif
   case SEXP_NUM_FLO_CPX:
@@ -1630,6 +1762,9 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
     break;
   case SEXP_NUM_FIX_FIX:
     r = sexp_fx_div(a, b);
+    if ((sexp_sint_t)a < 0 && (sexp_sint_t)b < 0 && (sexp_sint_t)r < 0) {
+      r = sexp_quotient(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
+    }
     break;
   case SEXP_NUM_FIX_BIG:
     r = SEXP_ZERO;
@@ -1663,8 +1798,11 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
 #if SEXP_USE_RATIOS
   case SEXP_NUM_FLO_RAT:
 #endif
-    if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
+    if (isinf(sexp_flonum_value(a)) ||
+        sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
       r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
+    } else if (bt == SEXP_NUM_FLO && isinf(sexp_flonum_value(b))) {
+      r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
     } else {
       tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(a)));
       tmp = sexp_remainder(ctx, tmp, b);
@@ -1687,7 +1825,8 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
 #if SEXP_USE_RATIOS
   case SEXP_NUM_RAT_FLO:
 #endif
-    if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
+    if (isinf(sexp_flonum_value(b)) ||
+        sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
       r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
     } else {
       tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(b)));
@@ -1728,16 +1867,16 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
   sexp_gc_preserve1(ctx, tmp);
   if (at > bt) {
     r = sexp_compare(ctx, b, a);
-    sexp_negate(r);
+    if (!sexp_exceptionp(r)) { sexp_negate(r); }
   } else {
     switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
     case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
     case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
 #if SEXP_USE_COMPLEX
-    case SEXP_NUM_CPX_CPX: case SEXP_NUM_CPX_FIX:
-    case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG:
+    case SEXP_NUM_CPX_CPX: case SEXP_NUM_FIX_CPX:
+    case SEXP_NUM_FLO_CPX: case SEXP_NUM_BIG_CPX:
 #if SEXP_USE_RATIOS
-    case SEXP_NUM_CPX_RAT:
+    case SEXP_NUM_RAT_CPX:
 #endif
 #endif
       r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
@@ -1746,9 +1885,13 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
       r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b));
       break;
     case SEXP_NUM_FIX_FLO:
-      f = sexp_fixnum_to_double(a);
-      g = sexp_flonum_value(b);
-      r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
+      if (isinf(sexp_flonum_value(b))) {
+        r = sexp_flonum_value(b) > 0 ? SEXP_NEG_ONE : SEXP_ONE;
+      } else if (isnan(sexp_flonum_value(b))) {
+        r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
+      } else {
+        r = sexp_compare(ctx, a, tmp=sexp_inexact_to_exact(ctx, NULL, 1, b));
+      }
       break;
     case SEXP_NUM_FIX_BIG:
       if ((sexp_bignum_hi(b) > 1) ||
@@ -1760,6 +1903,11 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
     case SEXP_NUM_FLO_FLO:
       f = sexp_flonum_value(a);
       g = sexp_flonum_value(b);
+      if (isnan(f))
+        r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
+      else if (isnan(g))
+        r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
+      else
         r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
       break;
     case SEXP_NUM_FLO_BIG:
@@ -1785,8 +1933,7 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
       } else if (isnan(f)) {
         r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
       } else {
-        g = sexp_ratio_to_double(b);
-        r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
+        r = sexp_compare(ctx, tmp=sexp_inexact_to_exact(ctx, NULL, 1, a), b);
       }
       break;
     case SEXP_NUM_FIX_RAT:
@@ -1797,6 +1944,9 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
       r = sexp_ratio_compare(ctx, a, b);
       break;
 #endif
+    default:
+      r = sexp_xtype_exception(ctx, NULL, "unknown comparison", a);
+      break;
     }
   }
   sexp_gc_release1(ctx);

build-lib/chibi/char-set/width.sld

@@ -0,0 +1,12 @@
+
+;; Don't import this - it's temporarily used to compute optimized
+;; char-set representations.
+
+(define-library (chibi char-set width)
+  (import (chibi) (chibi iset) (chibi char-set))
+  (include "width.scm")
+  (export
+   char-set:zero-width
+   char-set:full-width
+   char-set:ambiguous-width
+   ))

chibi-scheme.vcproj

@@ -1,206 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<VisualStudioProject
-	ProjectType="Visual C++"
-	Version="9.00"
-	Name="chibi-scheme"
-	ProjectGUID="{38DC39DA-5328-4FFE-84E2-E16FF1864945}"
-	RootNamespace="chibi-scheme"
-	Keyword="Win32Proj"
-	TargetFrameworkVersion="0"
-	>
-	<Platforms>
-		<Platform
-			Name="Win32"
-		/>
-	</Platforms>
-	<ToolFiles>
-	</ToolFiles>
-	<Configurations>
-		<Configuration
-			Name="Debug|Win32"
-			OutputDirectory="Debug"
-			IntermediateDirectory="Debug"
-			ConfigurationType="2"
-			>
-			<Tool
-				Name="VCPreBuildEventTool"
-			/>
-			<Tool
-				Name="VCCustomBuildTool"
-			/>
-			<Tool
-				Name="VCXMLDataGeneratorTool"
-			/>
-			<Tool
-				Name="VCWebServiceProxyGeneratorTool"
-			/>
-			<Tool
-				Name="VCMIDLTool"
-			/>
-			<Tool
-				Name="VCCLCompilerTool"
-				Optimization="0"
-				AdditionalIncludeDirectories="include"
-				PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS;_USRDLL;CHIBISCHEME_EXPORTS"
-				MinimalRebuild="true"
-				BasicRuntimeChecks="3"
-				RuntimeLibrary="3"
-				UsePrecompiledHeader="0"
-				WarningLevel="3"
-				Detect64BitPortabilityProblems="true"
-				DebugInformationFormat="4"
-			/>
-			<Tool
-				Name="VCManagedResourceCompilerTool"
-			/>
-			<Tool
-				Name="VCResourceCompilerTool"
-			/>
-			<Tool
-				Name="VCPreLinkEventTool"
-			/>
-			<Tool
-				Name="VCLinkerTool"
-				LinkIncremental="2"
-				GenerateDebugInformation="true"
-				SubSystem="2"
-				TargetMachine="1"
-			/>
-			<Tool
-				Name="VCALinkTool"
-			/>
-			<Tool
-				Name="VCManifestTool"
-			/>
-			<Tool
-				Name="VCXDCMakeTool"
-			/>
-			<Tool
-				Name="VCBscMakeTool"
-			/>
-			<Tool
-				Name="VCFxCopTool"
-			/>
-			<Tool
-				Name="VCAppVerifierTool"
-			/>
-			<Tool
-				Name="VCPostBuildEventTool"
-			/>
-		</Configuration>
-		<Configuration
-			Name="Release|Win32"
-			OutputDirectory="Release"
-			IntermediateDirectory="Release"
-			ConfigurationType="2"
-			>
-			<Tool
-				Name="VCPreBuildEventTool"
-			/>
-			<Tool
-				Name="VCCustomBuildTool"
-			/>
-			<Tool
-				Name="VCXMLDataGeneratorTool"
-			/>
-			<Tool
-				Name="VCWebServiceProxyGeneratorTool"
-			/>
-			<Tool
-				Name="VCMIDLTool"
-			/>
-			<Tool
-				Name="VCCLCompilerTool"
-				PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS;_USRDLL;CHIBISCHEME_EXPORTS;"
-				RuntimeLibrary="2"
-				UsePrecompiledHeader="0"
-				WarningLevel="3"
-				Detect64BitPortabilityProblems="true"
-				DebugInformationFormat="3"
-			/>
-			<Tool
-				Name="VCManagedResourceCompilerTool"
-			/>
-			<Tool
-				Name="VCResourceCompilerTool"
-			/>
-			<Tool
-				Name="VCPreLinkEventTool"
-			/>
-			<Tool
-				Name="VCLinkerTool"
-				LinkIncremental="2"
-				GenerateDebugInformation="true"
-				SubSystem="2"
-				OptimizeReferences="2"
-				EnableCOMDATFolding="2"
-				TargetMachine="1"
-			/>
-			<Tool
-				Name="VCALinkTool"
-			/>
-			<Tool
-				Name="VCManifestTool"
-			/>
-			<Tool
-				Name="VCXDCMakeTool"
-			/>
-			<Tool
-				Name="VCBscMakeTool"
-			/>
-			<Tool
-				Name="VCFxCopTool"
-			/>
-			<Tool
-				Name="VCAppVerifierTool"
-			/>
-			<Tool
-				Name="VCPostBuildEventTool"
-			/>
-		</Configuration>
-	</Configurations>
-	<References>
-	</References>
-	<Files>
-		<Filter
-			Name="Header Files"
-			Filter="h;hpp;hxx;hm;inl;inc;xsd"
-			UniqueIdentifier="{93995380-89BD-4b04-88EB-625FBE52EBFB}"
-			>
-		</Filter>
-		<Filter
-			Name="Resource Files"
-			Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx"
-			UniqueIdentifier="{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}"
-			>
-		</Filter>
-		<Filter
-			Name="Source Files"
-			Filter="cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx"
-			UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}"
-			>
-			<File
-				RelativePath=".\eval.c"
-				>
-			</File>
-			<File
-				RelativePath=".\main.c"
-				>
-			</File>
-			<File
-				RelativePath=".\sexp.c"
-				>
-				<FileConfiguration
-					Name="Debug|Win32"
-					>
-					<Tool
-						Name="VCCLCompilerTool"
-						PreprocessorDefinitions="-DPLATFORM=mingw;-DSEXP_USE_STRING_STREAMS=0;-DSEXP_USE_DEBUG=0;-DSEXP_USE_DL=0;-DBUILDING_DLL"
-					/>
-				</FileConfiguration>
-			</File>
-		</Filter>
-	</Files>
-	<Globals>
-	</Globals>
-</VisualStudioProject>

configure

@@ -0,0 +1,5 @@
+#!/bin/sh
+
+echo "Autoconf is an evil piece bloatware encouraging cargo-cult programming."
+echo "Make, on the other hand, is a beautiful little prolog for the filesystem."
+echo "Just run 'make'."

contrib/chibi-generate-install-meta-helper.cmake

@@ -0,0 +1,10 @@
+
+execute_process(
+    COMMAND find ${LIBDIR} -name "*.sld"
+    COMMAND ${EXEC} ${GENMETA} ${VERSION}
+    OUTPUT_FILE ${OUT}
+    RESULT_VARIABLE error)
+
+if(error)
+    message(FATAL_ERROR "${error}")
+endif()

contrib/chibi-genstatic-helper.cmake

@@ -0,0 +1,27 @@
+#
+# chibi-genstatic-helper.cmake
+#
+#  INPUT:
+#   ROOT=<DIR>
+#   EXEC=<EXECUTABLE>
+#   GENSTATIC=<FILE>
+#   STUBS=<FILE>
+#   OUT=<FILE>
+if(NOT EXEC)
+    message(FATAL_ERROR "huh?")
+endif()
+
+if(NOT OUT)
+    message(FATAL_ERROR "huh?")
+endif()
+
+execute_process(
+    COMMAND ${EXEC} ${GENSTATIC} --no-inline
+    INPUT_FILE ${STUBS}
+    OUTPUT_FILE ${OUT}
+    RESULT_VARIABLE rr
+    )
+
+if(rr)
+    message(FATAL_ERROR "Error: ${rr}")
+endif()

contrib/chibi-scheme-config.cmake

@@ -0,0 +1,2 @@
+
+include(${CMAKE_CURRENT_LIST_DIR}/chibi-scheme-targets.cmake)

contrib/chibi-scheme.pc.cmake.in

@@ -0,0 +1,14 @@
+# pkg-config
+prefix=@CMAKE_INSTALL_PREFIX@
+exec_prefix=@CMAKE_INSTALL_FULL_BINDIR@
+libdir=@CMAKE_INSTALL_FULL_LIBDIR@
+includedir=@CMAKE_INSTALL_FULL_INCLUDEDIR@
+version=@CMAKE_PROJECT_VERSION@
+
+Name: chibi-scheme
+URL: http://synthcode.com/scheme/chibi/
+Description: Minimal Scheme Implementation for use as an Extension Language
+Version: ${version}
+Libs: -L${libdir} -lchibi-scheme
+Libs.private: -dl -lm
+Cflags: -I${includedir}

contrib/scheme-keywords.el

@@ -0,0 +1,439 @@
+;; scheme-keywords.el
+;; Scheme R7RS-small syntax highlighting and keyword completion for GNU Emacs
+;; Copyright (c) 2015 Frère Jérôme. Contributed to the `Chibi-Scheme' project
+;; under the same BSD-style license: http://synthcode.com/license.txt
+
+;; The *optional* keyword completion is provided by the `company' framework
+;; See: https://company-mode.github.io
+
+;; Installation:
+
+;; If necessary, add the location of this file to your Emacs `load-path':
+;; (add-to-list 'load-path "FILE LOCATION")
+
+;; Add the following lines to your `.emacs' configuration file:
+;; (when (require 'scheme-keywords nil t)
+;;   (add-to-list 'auto-mode-alist '("\\.sld\\'" . scheme-mode))
+;;   ;; CUSTOMIZATION HERE
+;; )
+
+;; Customization:
+
+;; (scheme-add-keywords 'LIST 'FACE) ;; define additional highlights
+;; (setq scheme-keywords-completions 'LIST) ;; define additional completions
+
+(require 'company nil t)
+(require 'cl)
+
+(defconst scheme-procedures-list
+  '("and"
+    "begin"
+    "call\/cc"
+    "call-with-current-continuation"
+    "call-with-input-file"
+    "call-with-output-file"
+    "call-with-port"
+    "call-with-values"
+    "case"
+    "case-lambda"
+    "cond"
+    "cond-expand"
+    "cons"
+    "define"
+    "define-library"
+    "define-record-type"
+    "define-syntax"
+    "define-values"
+    "delay"
+    "delay-force"
+    "do"
+    "dynamic-wind"
+    "else"
+    "eof-object"
+    "export"
+    "features"
+    "force"
+    "for-each"
+    "if"
+    "import"
+    "include"
+    "include-ci"
+    "lambda"
+    "let"
+    "let\*"
+    "letrec"
+    "letrec\*"
+    "letrec-syntax"
+    "let-syntax"
+    "let-values"
+    "let\*-values"
+    "library"
+    "list"
+    "load"
+    "not"
+    "or"
+    "quasiquote"
+    "quote"
+    "scheme-report-environment"
+    "syntax-error"
+    "syntax-rules"
+    "unless"
+    "unquote"
+    "unquote-splicing"
+    "values"
+    "when"))
+
+(defconst scheme-operators-list
+  '("\<"
+    "\<\="
+    "\="
+    "\=\>"
+    "\>"
+    "\>\="
+    "\_"
+    "\-"
+    "\/"
+    "\.\.\."
+    "\*"
+    "\+"
+    "caaaar"
+    "caaadr"
+    "caaar"
+    "caadar"
+    "caaddr"
+    "caadr"
+    "caar"
+    "cadaar"
+    "cadadr"
+    "cadar"
+    "caddar"
+    "cadddr"
+    "caddr"
+    "cadr"
+    "car"
+    "cdaaar"
+    "cdaadr"
+    "cdaar"
+    "cdadar"
+    "cdaddr"
+    "cdadr"
+    "cdar"
+    "cddaar"
+    "cddadr"
+    "cddar"
+    "cdddar"
+    "cddddr"
+    "cdddr"
+    "cddr"
+    "cdr"
+    "\#f"
+    "\#false"
+    "\#t"
+    "\#true"))
+
+(defconst scheme-predicates-list
+  '("binary-port\?"
+    "boolean\=\?"
+    "boolean\?"
+    "bytevector"
+    "bytevector\?"
+    "char\<\=\?"
+    "char\<\?"
+    "char\=\?"
+    "char\>\=\?"
+    "char\>\?"
+    "char\?"
+    "char-alphabetic\?"
+    "char-ci\<\=\?"
+    "char-ci\<\?"
+    "char-ci\=\?"
+    "char-ci\>\=\?"
+    "char-ci\>\?"
+    "char-numeric\?"
+    "char-ready\?"
+    "char-lower-case\?"
+    "char-upper-case\?"
+    "char-whitespace\?"
+    "complex\?"
+    "eof-object\?"
+    "eq\?"
+    "equal\?"
+    "eqv\?"
+    "error-object\?"
+    "even\?"
+    "exact\?"
+    "exact-integer\?"
+    "file-error\?"
+    "file-exists\?"
+    "finite\?"
+    "inexact\?"
+    "infinite\?"
+    "input-port\?"
+    "input-port-open\?"
+    "integer\?"
+    "list\?"
+    "nan\?"
+    "negative\?"
+    "null\?"
+    "number\?"
+    "odd\?"
+    "output-port\?"
+    "output-port-open\?"
+    "pair\?"
+    "port\?"
+    "positive\?"
+    "procedure\?"
+    "promise\?"
+    "rational\?"
+    "read-error\?"
+    "real\?"
+    "string\<\=\?"
+    "string\<\?"
+    "string\=\?"
+    "string\>\=\?"
+    "string\>\?"
+    "string\?"
+    "string-ci\<\=\?"
+    "string-ci\<\?"
+    "string-ci\=\?"
+    "string-ci\>\=\?"
+    "string-ci\>\?"
+    "symbol\=\?"
+    "symbol\?"
+    "textual-port\?"
+    "u8-ready\?"
+    "vector\?"
+    "zero\?"))
+
+(defconst scheme-mutations-list
+  '("bytevector-copy\!"
+    "bytevector-u8-set\!"
+    "list-set\!"
+    "read-bytevector\!"
+    "set\!"
+    "set-car\!"
+    "set-cdr\!"
+    "string-copy\!"
+    "string-fill\!"
+    "string-set\!"
+    "vector-copy\!"
+    "vector-fill\!"
+    "vector-set\!"))
+
+(defconst scheme-exceptions-list
+  '("emergency-exit"
+    "error"
+    "error-object-message"
+    "error-object-irritants"
+    "exit"
+    "guard"
+    "raise"
+    "raise-continuable"
+    "with-exception-handler"))
+
+(defconst scheme-functions-list
+  '("abs"
+    "acos"
+    "angle"
+    "append"
+    "apply"
+    "asin"
+    "assoc"
+    "assq"
+    "assv"
+    "atan"
+    "bytevector"
+    "bytevector-append"
+    "bytevector-copy"
+    "bytevector-length"
+    "bytevector-u8-ref"
+    "ceiling"
+    "ceiling\/"
+    "ceiling-quotient"
+    "ceiling-remainder"
+    "centered\/"
+    "centered-quotient"
+    "centered-remainder"
+    "char-downcase"
+    "char-foldcase"
+    "char-\>integer"
+    "char-upcase"
+    "close-input-port"
+    "close-output-port"
+    "close-port"
+    "command-line"
+    "cos"
+    "current-error-port"
+    "current-input-port"
+    "current-jiffy"
+    "current-output-port"
+    "current-second"
+    "delete-file"
+    "denominator"
+    "digit-value"
+    "display"
+    "environment"
+    "euclidean\/"
+    "euclidean-quotient"
+    "euclidean-remainder"
+    "exact"
+    "exact-\>inexact"
+    "exact-integer-sqrt"
+    "exp"
+    "expt"
+    "floor"
+    "floor\/"
+    "floor-quotient"
+    "floor-remainder"
+    "flush-output-port"
+    "gcd"
+    "get-environment-variable"
+    "get-environment-variables"
+    "get-output-bytevector"
+    "get-output-string"
+    "imag-part"
+    "inexact"
+    "inexact-\>exact"
+    "integer-\>char"
+    "interaction-environment"
+    "jiffies-per-second"
+    "lcm"
+    "length"
+    "list-copy"
+    "list-ref"
+    "list-\>string"
+    "list-tail"
+    "list-\>vector"
+    "log"
+    "magnitude"
+    "make-bytevector"
+    "make-list"
+    "make-parameter"
+    "make-polar"
+    "make-promise"
+    "make-rectangular"
+    "make-string"
+    "make-vector"
+    "map"
+    "max"
+    "member"
+    "memq"
+    "memv"
+    "min"
+    "modulo"
+    "newline"
+    "null-environment"
+    "number-\>string"
+    "numerator"
+    "open-binary-input-file"
+    "open-binary-output-file"
+    "open-input-bytevector"
+    "open-input-file"
+    "open-input-string"
+    "open-output-bytevector"
+    "open-output-file"
+    "open-output-string"
+    "parameterize"
+    "peek-char"
+    "peek-u8"
+    "quotient"
+    "rationalize"
+    "read"
+    "read-bytevector"
+    "read-char"
+    "read-line"
+    "read-string"
+    "read-u8"
+    "real-part"
+    "remainder"
+    "reverse"
+    "round"
+    "round\/"
+    "round-quotient"
+    "round-remainder"
+    "sin"
+    "sqrt"
+    "square"
+    "string"
+    "string-append"
+    "string-copy"
+    "string-downcase"
+    "string-foldcase"
+    "string-for-each"
+    "string-length"
+    "string-\>list"
+    "string-map"
+    "string-\>number"
+    "string-ref"
+    "string-\>symbol"
+    "string-upcase"
+    "string-\>utf8"
+    "string-\>vector"
+    "substring"
+    "symbol-\>string"
+    "tan"
+    "truncate"
+    "truncate\/"
+    "truncate-quotient"
+    "truncate-remainder"
+    "utf8-\>string"
+    "vector"
+    "vector-append"
+    "vector-copy"
+    "vector-for-each"
+    "vector-length"
+    "vector-\>list"
+    "vector-map"
+    "vector-ref"
+    "vector-\>string"
+    "with-input-from-file"
+    "with-output-to-file"
+    "write"
+    "write-bytevector"
+    "write-char"
+    "write-shared"
+    "write-simple"
+    "write-string"
+    "write-u8"))
+
+(defvar scheme-keywords-completions '())
+
+(defun scheme-add-keywords (keywords face)
+  "Add keywords to Scheme mode."
+  (interactive (list 'interactive))
+  (let ((keyword-list (concat "\\<\\(" (regexp-opt keywords) "\\)\\>")))
+    (font-lock-add-keywords 'scheme-mode
+                            `((,keyword-list 1 ',face)))))
+
+(scheme-add-keywords scheme-procedures-list
+                     'font-lock-keyword-face)
+(scheme-add-keywords scheme-operators-list
+                     'font-lock-builtin-face)
+(scheme-add-keywords scheme-predicates-list
+                     'font-lock-type-face)
+(scheme-add-keywords scheme-mutations-list
+                     'font-lock-type-face)
+(scheme-add-keywords scheme-exceptions-list
+                     'font-lock-warning-face)
+(scheme-add-keywords scheme-functions-list
+                     'font-lock-function-name-face)
+
+(defun scheme-keywords-hook ()
+  (when (featurep 'company)
+    (defun company-scheme-keywords
+        (command &optional argument &rest ignored)
+      (interactive (list 'interactive))
+      (case command
+        (interactive (company-begin-backend 'company-scheme-keywords))
+        (prefix (and (eq major-mode 'scheme-mode) (company-grab-symbol)))
+        (candidates (remove-if-not
+                     (lambda (candidate)
+                       (string-prefix-p argument candidate))
+                     (append scheme-procedures-list scheme-operators-list
+                             scheme-predicates-list scheme-mutations-list
+                             scheme-exceptions-list scheme-functions-list
+                             scheme-keywords-completions)))))
+    (add-to-list 'company-backends 'company-scheme-keywords)))
+(add-hook 'scheme-mode-hook 'scheme-keywords-hook)
+
+(provide 'scheme-keywords)

doc/chibi-doc.1

@@ -52,4 +52,4 @@ Alex Shinn (alexshinn @ gmail . com)
 .PP
 The chibi-scheme home-page:
 .BR
-http://code.google.com/p/chibi-scheme/
+https://github.com/ashinn/chibi-scheme/

doc/chibi-ffi.1

@@ -42,4 +42,4 @@ Alex Shinn (alexshinn @ gmail . com)
 .PP
 The chibi-scheme home-page:
 .BR
-http://code.google.com/p/chibi-scheme/
+https://github.com/ashinn/chibi-scheme/

doc/chibi-scheme.1

@@ -6,13 +6,16 @@ chibi-scheme \- a tiny Scheme interpreter
 
 .SH SYNOPSIS
 .B chibi-scheme
-[-qQrRfV]
+[-qQrRfTV]
 [-I
 .I path
 ]
 [-A
 .I path
 ]
+[-D
+.I feature
+]
 [-m
 .I module
 ]
@@ -76,8 +79,14 @@ module.  This can be launched automatically with:
 .I chibi-scheme -R
 \[char46]
 
-The default language the R7RS
-(scheme base) module.  To get a mostly R5RS-compatible language, use
+For convenience the default language is the
+(scheme small) module, which includes every library in the R7RS
+small standard, and transitively some other dependencies.  All of this
+together is actually quite large, so for a more minimal startup
+language you'll want to use the
+.I -x module
+option described below.
+To get a mostly R5RS-compatible language, use
 .I chibi-scheme -xscheme.r5rs
 or to get just the core language used for bootstrapping, use
 .I chibi-scheme -xchibi
@@ -130,7 +139,7 @@ need not be exported) with a single argument of the list of command-line
 arguments as in SRFI-22.  The name "main" can be overridden with the -r
 option.
 .I [module]
-may be omitted, in which case it default to chibi.repl.  Thus
+may be omitted, in which case it defaults to chibi.repl.  Thus
 .I chibi-scheme -R
 is the recommended means to obtain the advanced REPL.
 .TP
@@ -140,6 +149,11 @@ Strict mode, escalating warnings to fatal errors.
 .BI -f
 Change the reader to case-fold symbols as in R5RS.
 .TP
+.BI -T
+Disables tail-call optimization.  This can be useful for
+debugging in some cases, but also makes it very likely to
+overflow the stack.
+.TP
 .BI -h size[/max_size]
 Specifies the initial size of the heap, in bytes,
 optionally followed by the maximum size the heap can
@@ -161,6 +175,12 @@ Appends
 .I path
 to the load path list.  
 .TP
+.BI -D feature
+Adds
+.I feature
+to the feature list, useful for cond-expanding different
+library code.  
+.TP
 .BI -m module
 .TP
 .BI -x module
@@ -205,13 +225,17 @@ Loads the Scheme heap from
 .I image-file
 instead of compiling the init file on the fly.
 This feature is still experimental.
+.TP
+.BI -b
+Makes stdio nonblocking (blocking by default). Only available when
+lightweight threads are enabled.
 
 .SH ENVIRONMENT
 .TP
 .B CHIBI_MODULE_PATH
 A colon separated list of directories to search for module
 files, inserted before the system default load paths.  chibi-scheme
-searchs for modules in directories in the following order:
+searches for modules in directories in the following order:
 
 .TP
           directories included with the -I path option
@@ -222,8 +246,14 @@ searchs for modules in directories in the following order:
 .TP
           directories included with -A path option
 
-If CHIBI_MODULE_PATH is unset, the directoriese "./lib", and "." are
-search in order.
+If CHIBI_MODULE_PATH is unset, the directories "./lib", and "." are
+searched in order. Set to empty to only consider -I, system
+directories and -A.
+
+.TP
+.B CHIBI_IGNORE_SYSTEM_PATH
+If set to anything but "0", system directories (as listed above) are
+not included in the search paths.
 
 .SH AUTHORS
 .PP
@@ -231,9 +261,9 @@ Alex Shinn (alexshinn @ gmail . com)
 
 .SH SEE ALSO
 .PP
-More detailed information can be found in the manuale included in
+More detailed information can be found in the manual included in
 doc/chibi.scrbl included in the distribution.
 
 The chibi-scheme home-page:
 .br
-http://code.google.com/p/chibi-scheme/
+https://github.com/ashinn/chibi-scheme/

doc/chibi.scrbl

@@ -4,7 +4,7 @@
 \author{Alex Shinn}
 
 \centered{\smaller{Minimal Scheme Implementation for use as an Extension Language}}
-\centered{\url{http://synthcode.com/wiki/chibi-scheme}}
+\centered{\url{https://github.com/ashinn/chibi-scheme}}
 
 \section{Introduction}
 
@@ -28,8 +28,8 @@ standard modules.  You can choose whichever layer suits your needs
 best and customize the rest.  Adding your own primitives or wrappers
 around existing C libraries is easy with the C FFI.
 
-Chibi is known to build and run on 32 and 64-bit Linux, FreeBSD,
-DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
+Chibi is known to build and run on 32 and 64-bit Linux, OpenBSD, FreeBSD,
+DragonFlyBSD, OS X, iOS, Windows (under Cygwin) and Plan9.
 
 \section{Installation}
 
@@ -69,6 +69,13 @@ To compile a static executable, use
 
 \command{make chibi-scheme-static SEXP_USE_DL=0}
 
+Note this static executable has none of the external binary libraries
+included, which means among other things you can't load the
+\scheme{(scheme base)} default language.  You need to specify the
+\scheme{(chibi)} or other Scheme-only language to run:
+
+\command{./chibi-scheme-static -q}
+
 To compile a static executable with all C libraries statically
 included, first you need to create a clibs.c file, which can be done
 with:
@@ -79,7 +86,8 @@ or edited manually.  Be sure to run this with a non-static
 chibi-scheme.  Then you can make the static executable with:
 
 \command{
-make -B chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS
+make -B chibi-scheme-static SEXP_USE_DL=0 \
+  CPPFLAGS="-DSEXP_USE_STATIC_LIBS -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0"
 }
 
 By default files are installed in /usr/local.  You can optionally
@@ -112,6 +120,7 @@ are listed below.
 \item{\ccode{SEXP_USE_RATIOS} - use exact ratios (enabled by default)}
 \item{\ccode{SEXP_USE_COMPLEX} - use complex numbers (enabled by default)}
 \item{\ccode{SEXP_USE_UTF8_STRINGS} - Unicode support (enabled by default)}
+\item{\ccode{SEXP_USE_STRING_INDEX_TABLE} - precompute offsets for O(1) \scheme{string-ref}}
 \item{\ccode{SEXP_USE_NO_FEATURES} - disable almost all features}
 ]
 
@@ -127,6 +136,8 @@ documentation system described in
 build this manual.  \ccode{chibi-ffi} is a tool to build wrappers for
 C libraries, described in the FFI section below.
 
+See the examples directory for some sample programs.
+
 \section{Default Language}
 
 \subsection{Scheme Standard}
@@ -137,9 +148,10 @@ superset of
 \hyperlink["http://www.schemers.org/Documents/Standards/R5RS/HTML/"]{R5RS}.
 
 The reader defaults to case-sensitive, like R6RS and R7RS but unlike
-R5RS.  The default configuration includes the full numeric tower:
-fixnums, flonums, bignums, exact rationals and complex numbers, though
-this can be customized at compile time.
+R5RS.  You can specify the -f option on the command-line to enable
+case-folding.  The default configuration includes the full numeric
+tower: fixnums, flonums, bignums, exact rationals and complex numbers,
+though this can be customized at compile time.
 
 Full continuations are supported, but currently continuations don't
 take C code into account.  This means that you can call from Scheme to
@@ -153,13 +165,14 @@ currently unspecified.
 In R7RS (and R6RS) semantics it is impossible to use two macros from
 different modules which both use the same auxiliary keywords (like
 \scheme{else} in \scheme{cond} forms) without renaming one of the
-keywords.  By default Chibi considers all top-level bindings
-effectively unbound when matching auxiliary keywords, so this case
-will "just work".  This decision was made because the chance of
-different modules using the same keywords seems more likely than user
-code unintentionally matching a top-level keyword with a different
-binding, however if you want to use R7RS semantics you can compile
-with \ccode{SEXP_USE_STRICT_TOPLEVEL_BINDINGS=1}.
+keywords.  To minimize conflicts Chibi offers a special module named
+\scheme{(auto)} which can export any identifier requested with
+\scheme{only}, e.g. \scheme{(import (only (auto) foo))} will import
+an auxiliary syntax \scheme{foo} binding.  Separate modules can use
+this to get the same binding without needing to know about each other
+in advance.  This is a Chibi-specific extension so is non-portable, but
+you can always define a static \scheme{(auto)} module exporting a list
+of all known bindings for other implementations.
 
 \scheme{load} is extended to accept an optional environment argument, like
 \scheme{eval}.  You can also \scheme{load} shared libraries in addition to
@@ -179,11 +192,12 @@ other languages.
 
 \subsection{Module System}
 
-Chibi uses the R7RS module system natively, which is a simple static
-module system in the style of the
-\hyperlink["http://s48.org/"]{Scheme48} module system.  As with most
-features this is optional, and can be ignored or completely disabled
-at compile time.
+Chibi supports the R7RS module system natively, which is a simple
+static module system.  The Chibi implementation is actually a
+hierarchy of languages in the style of the
+\hyperlink["http://s48.org/"]{Scheme48} module system, allowing easy
+extension of the module system itself.  As with most features this is
+optional, and can be ignored or completely disabled at compile time.
 
 Modules names are hierarchical lists of symbols or numbers.  A module
 definition uses the following form:
@@ -201,7 +215,8 @@ where \var{<library-declarations>} can be any of
   (begin <expr> ...)                   ;; inline Scheme code
   (include <file> ...)                 ;; load one or more files
   (include-ci <file> ...)              ;; as include, with case-folding
-  (include-shared <file> ...)          ;; dynamic load a library
+  (include-shared <file> ...)          ;; dynamic load a library (non-R7RS)
+  (alias-for <library>)                ;; a library alias (non-R7RS)
 }
 
 \var{<import-spec>} can either be a module name or any of
@@ -210,13 +225,23 @@ where \var{<library-declarations>} can be any of
   (only <import-spec> <id> ...)
   (except <import-spec> <id> ...)
   (rename <import-spec> (<from-id> <to-id>) ...)
-  (prefix <prefix-id> <import-spec>)
+  (prefix <import-spec> <prefix-id>)
+  (drop-prefix <import-spec> <prefix-id>)   ;; non-R7RS
 }
 
 These forms perform basic selection and renaming of individual
 identifiers from the given module. They may be composed to perform
 combined selection and renaming.
 
+Note while the repl provides default bindings as a convenience,
+programs have strict semantics as in R7RS and must start with at least
+one import, e.g.
+
+\schemeblock{
+(import (scheme base))
+(write-string "Hello world!\n")
+}
+
 Some modules can be statically included in the initial configuration,
 and even more may be included in image files, however in general
 modules are searched for in a module load path.  The definition of the
@@ -225,7 +250,7 @@ module \scheme{(foo bar baz)} is searched for in the file
 installed directories, \scheme{"."} and \scheme{"./lib"}.  Additional
 directories can be specified with the command-line options \ccode{-I}
 and \ccode{-A} (see the command-line options below) or with the
-\scheme{add-modue-directory} procedure at runtime.  You can search for
+\scheme{add-module-directory} procedure at runtime.  You can search for
 a module file with \scheme{(find-module-file <file>)}, or load it with
 \scheme{(load-module-file <file> <env>)}.
 
@@ -264,8 +289,8 @@ These are just syntactic sugar for the following more primitive type
 constructors:
 
 \schemeblock{
-(register-simple-type <name-string> <parent> <num-fields>)
- => <type>
+(register-simple-type <name-string> <parent> <field-names>)
+ => <type>    ; parent may be #f, field-names should be a list of symbols
 
 (make-type-predicate <opcode-name-string> <type>)
  => <opcode>  ; takes 1 arg, returns #t iff that arg is of the type
@@ -278,27 +303,38 @@ constructors:
 
 (make-setter <setter-name-string> <type> <field-index>)
  => <opcode>  ; takes 2 args, sets the field located at the index
+
+(type-slot-offset <type> <field-name>)
+ => <index>   ; returns the index of the field with the given name
 }
 
 \subsection{Unicode}
 
-Chibi supports Unicode strings, encoding them as utf8.  This provides easy
-interoperability with many C libraries, but means that \scheme{string-ref} and
-\scheme{string-set!} are O(n), so they should be avoided in
-performance-sensitive code.
+Chibi supports Unicode strings and I/O natively.  Case mappings and
+comparisons, character properties, formatting and regular expressions
+are all Unicode aware, supporting the latest version 13.0 of the
+Unicode standard.
+
+Internally strings are encoded as UTF-8.  This provides easy
+interoperability with many C libraries, but means that
+\scheme{string-ref} and \scheme{string-set!} are O(n), so they should
+be avoided in performance-sensitive code (unless you compile Chibi
+with SEXP_USE_STRING_INDEX_TABLE).
 
 In general you should use high-level APIs such as \scheme{string-map}
 to ensure fast string iteration.  String ports also provide a simple
-way to efficiently iterate and construct strings, by looping over an
-input string or accumulating characters in an output string.
+and portable way to efficiently iterate and construct strings, by
+looping over an input string or accumulating characters in an output
+string.
 
 The \scheme{in-string} and \scheme{in-string-reverse} iterators in the
 \scheme{(chibi loop)} module will also iterate over strings
 efficiently while hiding the low-level details.
 
 In the event that you do need a low-level interface, such as when
-writing your own iterator protocol, you should use the following
-string cursor API instead of indexes.
+writing your own iterator protocol, you should use string cursors.
+\scheme{(srfi 130)} provides a portable API for this, or you can use
+\scheme{(chibi string)} which builds on the following core procedures:
 
 \itemlist[
 \item{\scheme{(string-cursor-start str)}
@@ -334,9 +370,10 @@ To use Chibi-Scheme in a program you need to link against the
 
 \ccode{#include <chibi/eval.h>}
 
-All definitions begin with a "sexp_" prefix, or "SEXP_" for constants.
-In addition to the prototypes and utility macros, this includes the
-following type definitions:
+All definitions begin with a "sexp_" prefix, or "SEXP_" for constants
+(deliberately chosen not to conflict with other Scheme implementations
+which typically use "scm_").  In addition to the prototypes and
+utility macros, this includes the following type definitions:
 
 \itemlist[
 \item{\ctype{sexp} - an s-expression, used to represent all Scheme objects}
@@ -370,9 +407,10 @@ void dostuff(sexp ctx) {
 
 int main(int argc, char** argv) {
   sexp ctx;
+  sexp_scheme_init();
   ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
   sexp_load_standard_env(ctx, NULL, SEXP_SEVEN);
-  sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 0);
+  sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 1);
   dostuff(ctx);
   sexp_destroy_context(ctx);
 }
@@ -397,7 +435,7 @@ temporary values we may generate, which is what the
 \cmacro{sexp_gc_var2}, \cmacro{sexp_gc_preserve2} and
 \cmacro{sexp_gc_release2} macros do (there are similar macros for
 values 1-6).  Precise GCs prevent a class of memory leaks (and
-potential attackes based thereon), but if you prefer convenience then
+potential attacks based thereon), but if you prefer convenience then
 Chibi can be compiled with a conservative GC and you can ignore these.
 
 The interesting part is then the calls to \cfun{sexp_load},
@@ -438,6 +476,11 @@ using only the parent.
 
 Otherwise, a new heap is allocated with \var{size} bytes, expandable to a
 maximum of \var{max_size} bytes, using the system defaults if either is 0.
+
+Note this context is not a malloced pointer (it resides inside a
+malloced heap), and therefore can't be passed to \ccode{free()},
+or stored in a C++ smart pointer.  It can only be reclaimed with
+\ccode{sexp_destroy_context}.
 }}
 
 \item{\ccode{sexp_make_eval_context(sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size)}
@@ -469,7 +512,8 @@ the default context environment is used.  Any of the \ctype{FILE*} may
 be \cvar{NULL}, in which case the corresponding port is not set.  If
 \var{leave_open} is true, then the underlying \ctype{FILE*} is left
 open after the Scheme port is closed, otherwise they are both closed
-together.
+together.  If you want to reuse these streams from other vms, or from
+C, you should specify leave_open.
 }}
 
 \item{\ccode{sexp_load(sexp ctx, sexp file, sexp env)}
@@ -513,6 +557,11 @@ Returns the current binding of \var{sym} in \var{env}, or \var{dflt} if there
 is no binding.
 }}
 
+\item{\ccode{sexp_env_import(sexp ctx, sexp to, sexp from, sexp ls, sexp immutp)}
+\p{
+Imports the bindings from environment \var{from} into environment \var{to}.  \var{ls} is the list of bindings to import - if it is \scheme{#f} then import all bindings.  If \var{immutp} is true the imported bindings are immutable and cannot be redefined.
+}}
+
 \item{\ccode{sexp_parameter_ref(sexp ctx, sexp param)}
 \p{
 Returns the current dynamic value of the parameter \var{param} in the
@@ -617,13 +666,15 @@ sexp_release_object(ctx, obj)
 
 Decrement the absolute reference count for \var{obj}.
 
-\subsection{API Index}
+\subsection{C API Index}
 
 The above sections describe most everything you need for embedding in
 a typical application, notably creating environments and evaluating
 code from sexps, strings or files.  The following sections expand on
 additional macros and utilities for inspecting, accessing and creating
-different Scheme types, and for performing port and string I/O.
+different Scheme types, and for performing port and string I/O.  It is
+incomplete - see the macros and SEXP_API annotated functions in the
+include files (sexp.h, eval.h, bignum.h) for more bindings.
 
 Being able to convert from C string to sexp, evaluate it, and convert
 the result back to a C string forms the basis of the C API.  Because
@@ -651,10 +702,13 @@ need to check manually before applying the predicate.
 \item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer}
 \item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real}
 \item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer}
-\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer}
+\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer (or flonum truncating without loss)}
+\item{\ccode{sexp_ratiop(obj)} - \var{obj} is an exact rational (with SEXP_USE_RATIOS)}
+\item{\ccode{sexp_complexp(obj)} - \var{obj} is a complex number (with SEXP_USE_COMPLEX)}
 \item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number}
 \item{\ccode{sexp_charp(obj)} - \var{obj} is a character}
 \item{\ccode{sexp_stringp(obj)} - \var{obj} is a string}
+\item{\ccode{sexp_string_cursorp(obj)} - \var{obj} is a string cursor}
 \item{\ccode{sexp_bytesp(obj)} - \var{obj} is a bytevector}
 \item{\ccode{sexp_symbolp(obj)} - \var{obj} is a symbol}
 \item{\ccode{sexp_idp(obj)} - \var{obj} is a symbol or hygienic identifier}
@@ -712,7 +766,7 @@ check.  The runtime does not prevent embedded NULLs inside strings,
 however data after the NULL may be ignored.
 
 By default (unless you compile with -DSEXP_USE_UTF8_STRING=0), strings
-are interpreted as utf8 encoded on the Scheme side, as describe in
+are interpreted as UTF-8 encoded on the Scheme side, as describe in
 section Unicode above.  In many cases you can ignore this on the C
 side and just treat the string as an opaque sequence of bytes.
 However, if you need to you can use the following macros to safely
@@ -730,7 +784,7 @@ compiled with:
 \item{\ccode{sexp sexp_substring_cursor(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between raw offsets \var{i} and \var{j}}
 ]
 
-When UTF8 support is not compiled in the cursor and non-cursor
+When UTF-8 support is not compiled in the cursor and non-cursor
 variants are equivalent.
 
 \subsubsection{Accessors}
@@ -746,8 +800,12 @@ once.
 \item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise}
 \item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}}
 \item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer}
+\item{\ccode{sexp_make_flonum(sexp ctx, float f)} - creates a new floating point value}
+\item{\ccode{sexp_flonum_value(obj)} - converts a flonum to a C float}
 \item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}}
 \item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char}
+\item{\ccode{sexp sexp_make_string_cursor(int offset)} - creates a string cursor for the given byte offset}
+\item{\ccode{int sexp_unbox_string_cursor(sexp sc)} - returns the offset for the given string cursor}
 \item{\ccode{sexp_car(pair)} - the car of \var{pair}}
 \item{\ccode{sexp_cdr(pair)} - the cdr of \var{pair}}
 \item{\ccode{sexp_ratio_numerator(q)} - the numerator of the ratio \var{q}}
@@ -776,6 +834,7 @@ Any of these may fail and return the OOM exception object.
 \item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}}
 \item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)}
 \item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements}
+\item{\ccode{sexp_list3(sexp ctx, sexp obj1, sexp obj2, sexp obj3)} - create a list of three elements}
 \item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}}
 \item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}.  If \var{len} is -1, uses strlen(\var{str}).}
 \item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}.  If \var{len} is -1, uses strlen(\var{str}).}
@@ -791,7 +850,6 @@ Any of these may fail and return the OOM exception object.
 \item{\ccode{sexp_read(sexp ctx, sexp in)} - read a single datum from port \var{in}}
 \item{\ccode{sexp_write(sexp ctx, sexp obj, sexp out)} - write \var{obj} to port \var{out}}
 \item{\ccode{sexp_write_string(sexp ctx, char* str, sexp out)} - write the characters in \var{str} to port \var{out}}
-\item{\ccode{sexp_display(sexp ctx, sexp obj, sexp out)} - display \var{obj} to port \var{out}}
 \item{\ccode{sexp_newline(sexp ctx, sexp out)} - write a newline to port \var{out}}
 \item{\ccode{sexp_print_exception(sexp ctx, sexp exn, sexp out)} - print an error message for \var{exn} to port \var{out}}
 \item{\ccode{sexp_current_input_port(sexp ctx)} - the \scheme{current-input-port}}
@@ -802,7 +860,7 @@ Any of these may fail and return the OOM exception object.
 \item{\ccode{sexp_write_to_string(sexp ctx, sexp obj)} - return a Scheme string representation of \var{obj}}
 \item{\ccode{sexp_open_input_string(sexp ctx, sexp str)} - equivalent to \scheme{open-input-string}}
 \item{\ccode{sexp_open_output_string(sexp ctx)} - equivalent to \scheme{open-output-string}}
-\item{\ccode{sexp_get_output_string(sexp ctx, sexp port)} - equivalent to \scheme{open-output-string}}
+\item{\ccode{sexp_get_output_string(sexp ctx, sexp port)} - equivalent to \scheme{get-output-string}}
 ]
 
 \subsubsection{Utilities}
@@ -815,7 +873,7 @@ Any of these may fail and return the OOM exception object.
 \item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}}
 \item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}}
 \item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}}
-\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \scheme{append} for two arguments}
+\item{\ccode{sexp_append2(sexp ctx, sexp ls1, sexp ls2)} - \scheme{append} for two arguments}
 \item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}}
 \item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}}
 \item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}}
@@ -895,6 +953,39 @@ to any inherited from the parent type \var{parent}.  If \var{parent} is false,
 inherits from the default \var{object} record type.
 }}
 
+\item{\ccode{sexp sexp_register_c_type(sexp ctx, sexp name, sexp finalizer)}
+\p{
+Shortcut to defines a new type as a wrapper around a C pointer.
+Returns the type object, which can be used with sexp_make_cpointer to
+wrap instances of the type.  The finalizer may be sexp_finalize_c_type
+in which case managed pointers are freed as if allocated with malloc,
+NULL in which case the pointers are never freed, or otherwise a
+procedure of one argument which should release any resources.
+}}
+
+\item{\ccode{sexp sexp_make_cpointer(sexp ctx, sexp_uint_t type_tag, void* value, sexp parent, int freep)}
+\p{
+Creates a new instance of the type indicated by type_tag wrapping
+value. If parent is provided, references to the child will also
+preserve the parent, important e.g. to preserve an enclosing struct
+when wrapped references to nested structs are still in use.  If freep
+is true, then when reclaimed by the GC the finalizer for this type,
+if any, will be called on the instance.
+
+You can retrieve the tag from a type object with sexp_type_tag(type).
+}}
+
+\item{\ccode{sexp sexp_lookup_type(sexp ctx, sexp name, sexp tag_or_id)}
+\p{
+Returns the type whose name matches the string \var{name}.  If
+\var{tag_or_id} is an integer, it is taken as the tag and requires the
+numeric type tag (as from sexp_type_tag) to also match.
+}
+\p{If \var{tag_or_id} is a string, it is taken as the unique id of the
+type, and must match sexp_type_id(type).  However, currently
+sexp_type_id(type) is never set.
+}}
+
 ]
 
 See the C FFI for an easy way to automate adding bindings for C
@@ -1157,7 +1248,8 @@ A number of SRFIs are provided in the default installation.  Note that
 SRFIs 0, 6, 23, 46 and 62 are built into the default environment so
 there's no need to import them.  SRFI 22 is available with the "-r"
 command-line option.  This list includes popular SRFIs or SRFIs used
-in standard Chibi modules
+in standard Chibi modules (many other SRFIs are available on
+snow-fort):
 
 \itemlist[
 
@@ -1168,6 +1260,7 @@ in standard Chibi modules
 \item{\hyperlink["http://srfi.schemers.org/srfi-8/srfi-8.html"]{(srfi 8)  - receive}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{(srfi 9)  - define-record-type}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-11/srfi-11.html"]{(srfi 11) - let-values/let*-values}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-14/srfi-14.html"]{(srfi 14) - character-set library}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-16/srfi-16.html"]{(srfi 16) - case-lambda}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-18/srfi-18.html"]{(srfi 18) - multi-threading support}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-22/srfi-22.html"]{(srfi 22) - running scheme scripts on Unix}}
@@ -1177,13 +1270,53 @@ in standard Chibi modules
 \item{\hyperlink["http://srfi.schemers.org/srfi-33/srfi-33.html"]{(srfi 33) - bitwise operators}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-38/srfi-38.html"]{(srfi 38) - read/write shared structures}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-39/srfi-39.html"]{(srfi 39) - parameter objects}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-41/srfi-41.html"]{(srfi 41) - streams}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-46/srfi-46.html"]{(srfi 46) - basic syntax-rules extensions}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-55/srfi-55.html"]{(srfi 55) - require-extension}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-62/srfi-62.html"]{(srfi 62) - s-expression comments}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-64/srfi-64.html"]{(srfi 64) - a scheme API for test suites}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-69/srfi-69.html"]{(srfi 69) - basic hash tables}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-95/srfi-95.html"]{(srfi 95) - sorting and merging}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-98/srfi-98.html"]{(srfi 98) - environment access}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{(srfi 99) - ERR5RS records}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-101/srfi-101.html"]{(srfi 101) - purely functional random-access pairs and lists}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-111/srfi-111.html"]{(srfi 111) - boxes}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-113/srfi-113.html"]{(srfi 113) - sets and bags}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-115/srfi-115.html"]{(srfi 115) - Scheme regular expressions}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-116/srfi-116.html"]{(srfi 116) - immutable list library}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-117/srfi-117.html"]{(srfi 117) - mutable queues}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-121/srfi-121.html"]{(srfi 121) - generators}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-124/srfi-124.html"]{(srfi 124) - ephemerons}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-125/srfi-125.html"]{(srfi 125) - intermediate hash tables}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-127/srfi-127.html"]{(srfi 127) - lazy sequences}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-128/srfi-128.html"]{(srfi 128) - comparators (reduced)}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-129/srfi-129.html"]{(srfi 129) - titlecase procedures}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-130/srfi-130.html"]{(srfi 130) - cursor-based string library}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-132/srfi-132.html"]{(srfi 132) - sort libraries}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-133/srfi-133.html"]{(srfi 133) - vector library}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-134/srfi-134.html"]{(srfi 134) - immutable deques}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-135/srfi-135.html"]{(srfi 135) - immutable texts}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-139/srfi-139.html"]{(srfi 139) - syntax parameters}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-141/srfi-141.html"]{(srfi 141) - integer division}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-142.html"]{(srfi 142) - bitwise operations}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-143.html"]{(srfi 143) - fixnums}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-144/srfi-144.html"]{(srfi 144) - flonums}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-145/srfi-145.html"]{(srfi 145) - assumptions}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-147/srfi-147.html"]{(srfi 147) - custom macro transformers}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-151/srfi-151.html"]{(srfi 151) - bitwise operators}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-154/srfi-154.html"]{(srfi 154) - first-class dynamic extents}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-158/srfi-158.html"]{(srfi 158) - generators and accumulators}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-160/srfi-160.html"]{(srfi 160) - homogeneous numeric vector libraries}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-165/srfi-165.html"]{(srfi 165) - the environment Monad}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-166.html"]{(srfi 166) - monadic formatting}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-179/srfi-179.html"]{(srfi 179) - nonempty intervals and generalized arrays}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-188/srfi-188.html"]{(srfi 188) - splicing binding constructs for syntactic keywords}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-193/srfi-193.html"]{(srfi 193) - command-line}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-211/srfi-211.html"]{(srfi 211) - scheme macro libaries}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-219/srfi-219.html"]{(srfi 219) - define higher-order lambda}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-227/srfi-227.html"]{(srfi 227) - optional arguments}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-229/srfi-229.html"]{(srfi 229) - tagged procedures}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-231/srfi-231.html"]{(srfi 231) - intervals and generalized arrays}}
 
 ]
 
@@ -1196,10 +1329,30 @@ namespace.
 
 \item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}}
 
+\item{\hyperlink["lib/chibi/assert.html"]{(chibi assert) - A nicer assert macro}}
+
+\item{\hyperlink["lib/chibi/base64.html"]{(chibi base64) - Base64 encoding and decoding}}
+
+\item{\hyperlink["lib/chibi/binary-record.html"]{(chibi binary-record) - Record types with binary serialization}}
+
+\item{\hyperlink["lib/chibi/bytevector.html"]{(chibi bytevector) - Bytevector Utilities}}
+
 \item{\hyperlink["lib/chibi/config.html"]{(chibi config) - General configuration management}}
 
+\item{\hyperlink["lib/chibi/crypto/md5.html"]{(chibi crypto md5) - MD5 hash}}
+
+\item{\hyperlink["lib/chibi/crypto/rsa.html"]{(chibi crypto rsa) - RSA public key encryption}}
+
+\item{\hyperlink["lib/chibi/crypto/sha2.html"]{(chibi crypto sha2) - SHA-2 hash}}
+
+\item{\hyperlink["lib/chibi/diff.html"]{(chibi diff) - LCS Algorithm and diff utilities}}
+
 \item{\hyperlink["lib/chibi/disasm.html"]{(chibi disasm) - Disassembler for the virtual machine}}
 
+\item{\hyperlink["lib/chibi/doc.html"]{(chibi doc) - Chibi documentation utilities}}
+
+\item{\hyperlink["lib/chibi/edit-distance.html"]{(chibi edit-distance) - A levenshtein distance implementation}}
+
 \item{\hyperlink["lib/chibi/equiv.html"]{(chibi equiv) - A version of \scheme{equal?} which is guaranteed to terminate}}
 
 \item{\hyperlink["lib/chibi/filesystem.html"]{(chibi filesystem) - Interface to the filesystem and file descriptor objects}}
@@ -1210,16 +1363,36 @@ namespace.
 
 \item{\hyperlink["lib/chibi/io.html"]{(chibi io) - Various I/O extensions and custom ports}}
 
+\item{\hyperlink["lib/chibi/iset/base.html"]{(chibi iset base) - Compact integer sets}}
+
+\item{\hyperlink["lib/chibi/iset/base.html"]{(chibi iset base) - Compact integer sets}}
+
+\item{\hyperlink["lib/chibi/iset/constructors.html"]{(chibi iset constructors) - Compact integer set construction}}
+
+\item{\hyperlink["lib/chibi/iset/iterators.html"]{(chibi iset iterators) - Iterating over compact integer sets}}
+
+\item{\hyperlink["lib/chibi/json.html"]{(chibi json) - JSON reading and writing}}
+
 \item{\hyperlink["lib/chibi/loop.html"]{(chibi loop) - Fast and extensible loop syntax}}
 
 \item{\hyperlink["lib/chibi/match.html"]{(chibi match) - Intuitive and widely supported pattern matching syntax}}
 
+\item{\hyperlink["lib/chibi/math/prime.html"]{(chibi math prime) - Prime number utilities}}
+
+\item{\hyperlink["lib/chibi/memoize.html"]{(chibi memoize) - Procedure memoization}}
+
 \item{\hyperlink["lib/chibi/mime.html"]{(chibi mime) - Parse MIME files into SXML}}
 
 \item{\hyperlink["lib/chibi/modules.html"]{(chibi modules) - Introspection for the module system itself}}
 
 \item{\hyperlink["lib/chibi/net.html"]{(chibi net) - Simple networking interface}}
 
+\item{\hyperlink["lib/chibi/net/http-server.html"]{(chibi net http-server) - Simple http-server with servlet support}}
+
+\item{\hyperlink["lib/chibi/net/servlet.html"]{(chibi net servlet) - HTTP servlets for http-server or CGI}}
+
+\item{\hyperlink["lib/chibi/optional.html"]{(chibi optional) - Syntax to support optional and named keyword arguments}}
+
 \item{\hyperlink["lib/chibi/parse.html"]{(chibi parse) - Parser combinators with convenient syntax}}
 
 \item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}}
@@ -1228,16 +1401,22 @@ namespace.
 
 \item{\hyperlink["lib/chibi/repl.html"]{(chibi repl) - A full-featured Read/Eval/Print Loop}}
 
+\item{\hyperlink["lib/chibi/shell.html"]{(chibi shell) - Process combinators with high-level pipeline syntax in the spirit of SCSH.}}
+
+\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formatting.}}
+
 \item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}}
 
-\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - A combinator formatting library}}
-
-\item{\hyperlink["lib/chibi/show/base.scm"]{(chibi show base) - Base combinator formatting}}
+\item{\hyperlink["lib/chibi/string.html"]{(chibi string) - Cursor-based string library (predecessor to SRFI 130)}}
 
 \item{\hyperlink["lib/chibi/stty.html"]{(chibi stty) - A high-level interface to ioctl}}
 
+\item{\hyperlink["lib/chibi/sxml.html"]{(chibi sxml) - SXML utilities}}
+
 \item{\hyperlink["lib/chibi/system.html"]{(chibi system) - Access to the host system and current user information}}
 
+\item{\hyperlink["lib/chibi/temp-file.html"]{(chibi temp-file) - Temporary file and directory creation}}
+
 \item{\hyperlink["lib/chibi/test.html"]{(chibi test) - A simple unit testing framework}}
 
 \item{\hyperlink["lib/chibi/time.html"]{(chibi time) - An interface to the current system time}}
@@ -1255,17 +1434,23 @@ namespace.
 \section{Snow Package Manager}
 
 Beyond the distributed modules, Chibi comes with a package manager
-based on \hyperlink["http://trac.sacrideo.us/wg/wiki/Snow"]{Snow2}
+based on \hyperlink["https://small.r7rs.org/wiki/Snow/"]{Snow2}
 which can be used to share R7RS libraries.  Packages are distributed
 as tar gzipped files called "snowballs," and may contain multiple
-libraries.  The program is installed as \scheme{snow-chibi} and takes
-the following subcommands:
+libraries.  The program is installed as \scheme{snow-chibi}.  The
+"help" subcommand can be used to list all subcommands and options.
+Note by default \scheme{snow-chibi} uses an image file to speed-up
+loading (since it loads many libraries) - if you have any difficulties
+with image files on your platform you can run
+\command{snow-chibi --noimage} to disable this feature.
 
 \subsubsection{Querying Packages and Status}
 
 By default \scheme{snow-chibi} looks for packages in the public
 repository \hyperlink["http://snow-fort.org/"]{http://snow-fort.org/},
-though you can customize this with the \scheme{--repository-uri} option.
+though you can customize this with the \scheme{--repository-uri} or
+\scheme{--repo} option (e.g. "http://snow-fort.org/s/repo.scm").
+
 Packages can be browsed on the site, but you can also search and query
 from the command-line tool.
 
@@ -1297,6 +1482,11 @@ older version, a warning is printed.}}
 The basic package management functionality, installing upgrading and
 removing packages.
 
+By default the packages will be managed for Chibi. You can specify
+what Scheme implementation to install, upgrade... with
+\scheme{--implementations} or \scheme{--impls} option. Specify "all"
+to manage all supported implementations.
+
 \itemlist[
 
 \item{install names ... - install packages
@@ -1305,8 +1495,10 @@ use the dotted shorthand.  Explicit names for packages are optional,
 as a package can always be referred to by the name of any library it
 contains.  If multiple packages provide libraries with the same name,
 you will be asked to confirm which implementation to install.}
+
 \p{You can also bypass the repository and install a manually downloaded
-snowball by giving a path to that file instead of a name.}}
+snowball by giving a path to that file instead of a name. No package
+dependencies will be checked for install in this case}}
 
 \item{upgrade names ... - upgrade installed packages
 \p{Upgrade the packages if new versions are available.
@@ -1328,6 +1520,10 @@ update with this command.}}
 Creating packages can be done with the \scheme{package} command,
 though other commands allow for uploading to public repositories.
 
+By default the public repository is
+\hyperlink["http://snow-fort.org/"]{http://snow-fort.org/} but you can
+customize this with the \scheme{--host} option.
+
 \itemlist[
 
 \item{package files ... - create a package
@@ -1425,10 +1621,12 @@ command tells you which you currently have installed.  The following
 are currently supported:
 
 \itemlist[
-\item{chibi - native support as of version 0.7.3}
+\item{chibi - version >= 0.7.3}
 \item{chicken - version >= 4.9.0 with the \scheme{r7rs} egg}
+\item{cyclone - version >= 0.5.3}
 \item{foment - version >= 0.4}
 \item{gauche - version >= 0.9.4}
 \item{kawa - version >= 2.0; you need to add the install dir to the search path, e.g. \scheme{-Dkawa.import.path=/usr/local/share/kawa}}
 \item{larceny - version 0.98; you need to add "lib/Snow" to the paths in startup.sch}
+\item{sagittarius - version >= 0.98}
 ]

examples/hello.scm

@@ -0,0 +1,3 @@
+(import (scheme base))
+
+(write-string "Hello world!\n")

examples/simple-http-client.scm

@@ -0,0 +1,36 @@
+#! /usr/bin/env chibi-scheme
+
+; Simple HTTP client 
+; Retrieves the contents of the URL argument:
+
+; Usage:
+; simple-http-client.scm [URL]
+;
+; Example:
+; simple-http-client.scm http://localhost:8000
+
+(import (chibi) (chibi net) (chibi net http) (chibi io))
+
+(if (> (length (command-line)) 1) 
+  (let ((url (car (cdr (command-line)))))
+        (if (> (string-length url) 0) 
+          (begin
+            (display (read-string 65536 (http-get url)))  
+            (newline))))
+  (let ((progname (car (command-line))))
+    (display "Retrieve the contents of a URL.")
+    (newline)
+    (display "Usage:")
+    (newline)
+    (newline)
+    (display progname)
+    (display " [URL]")
+    (newline)))
+
+
+
+
+
+
+
+

examples/simple-http-server.scm

@@ -0,0 +1,16 @@
+#! /usr/bin/env chibi-scheme
+
+; Simple HTTP server
+; Returns a minimal HTML page with a single number incremented
+; every request. Binds to localhost port 8000.
+
+(import (chibi) (chibi net http-server) (chibi net servlet) (chibi sxml))
+
+(let ((count 0))
+   (run-http-server
+    8000
+    (lambda (cfg request next restart)
+      (set! count (+ 1 count))
+      (servlet-write request (sxml->xml `(html (body 
+        (p "Count: \n")
+        (p ,count))))))))

gc.c

@@ -6,14 +6,12 @@
 
 #include "chibi/sexp.h"
 
-#if SEXP_USE_MMAP_GC
-#include <sys/mman.h>
+#if SEXP_USE_TIME_GC
+#include <sys/resource.h>
 #endif
 
-#ifdef __APPLE__
-#define SEXP_RTLD_DEFAULT RTLD_SELF
-#else
-#define SEXP_RTLD_DEFAULT RTLD_DEFAULT
+#if SEXP_USE_MMAP_GC
+#include <sys/mman.h>
 #endif
 
 #define SEXP_BANNER(x) ("**************** GC "x"\n")
@@ -39,14 +37,52 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
   return h;
 }
 
+#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS && !SEXP_USE_MALLOC
 static size_t sexp_heap_total_size (sexp_heap h) {
   size_t total_size = 0;
   for (; h; h=h->next)
     total_size += h->size;
   return total_size;
 }
+#endif
 
 #if ! SEXP_USE_GLOBAL_HEAP
+#if SEXP_USE_DEBUG_GC
+void sexp_debug_heap_stats (sexp_heap heap) {
+  sexp_free_list ls;
+  size_t available = 0;
+  for (ls=heap->free_list; ls; ls=ls->next)
+    available += ls->size;
+#if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
+  sexp_debug_printf("free heap: %p (chunk size: %lu): %ld / %ld used (%.2f%%)", heap, heap->chunk_size, heap->size - available, heap->size, 100*(heap->size - available) / (float)heap->size);
+#else
+  sexp_debug_printf("free heap: %p: %ld / %ld used (%.2f%%)", heap, heap->size - available, heap->size, 100*(heap->size - available) / (float)heap->size);
+#endif
+  if (heap->next)
+    sexp_debug_heap_stats(heap->next);
+}
+#endif
+
+#if SEXP_USE_TRACK_ALLOC_TIMES
+void sexp_debug_alloc_times(sexp ctx) {
+  double mean = (double) sexp_context_alloc_usecs(ctx) / sexp_context_alloc_count(ctx);
+  double var = (double) sexp_context_alloc_usecs_sq(ctx) / sexp_context_alloc_count(ctx) - mean*mean;
+  fprintf(stderr, SEXP_BANNER("alloc: mean: %0.3lfμs var: %0.3lfμs (%ld times)"), mean, var, sexp_context_alloc_count(ctx));
+}
+#endif
+
+#if SEXP_USE_TRACK_ALLOC_SIZES
+void sexp_debug_alloc_sizes(sexp ctx) {
+  int i;
+  fprintf(stderr, "alloc size histogram: {");
+  for (i=0; i<SEXP_ALLOC_HISTOGRAM_BUCKETS; ++i) {
+    if ((i+1)*sexp_heap_align(1)<100 || sexp_context_alloc_histogram(ctx)[i]>0)
+      fprintf(stderr, "  %ld:%ld", (i+1)*sexp_heap_align(1), sexp_context_alloc_histogram(ctx)[i]);
+  }
+  fprintf(stderr, "}\n");
+}
+#endif
+
 void sexp_free_heap (sexp_heap heap) {
 #if SEXP_USE_MMAP_GC
   munmap(heap, sexp_heap_pad_size(heap->size));
@@ -92,7 +128,7 @@ void sexp_release_object(sexp ctx, sexp x) {
     }
 }
 
-sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
+SEXP_API sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
   sexp_uint_t res;
   sexp t;
   if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
@@ -101,7 +137,7 @@ sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
   res = sexp_type_size_of_object(t, x) + SEXP_GC_PAD;
 #if SEXP_USE_DEBUG_GC
   if (res == 0) {
-    fprintf(stderr, SEXP_BANNER("%p zero-size object: %p"), ctx, x);
+    fprintf(stderr, SEXP_BANNER("%p zero-size object: %p (type tag: %d)"), ctx, x, sexp_pointer_tag(x));
     return 1;
   }
 #endif
@@ -184,9 +220,40 @@ int sexp_valid_object_p (sexp ctx, sexp x) {
   return sexp_in_heap_p(ctx, x) && sexp_valid_object_type_p(ctx, x)
     && sexp_valid_header_magic_p(ctx, x);
 }
+#define sexp_gc_pass_ctx(x) x,
+#else
+#define sexp_gc_pass_ctx(x)
 #endif
 
-void sexp_mark (sexp ctx, sexp x) {
+static void sexp_mark_stack_push (sexp ctx, sexp *start, sexp *end) {
+  struct sexp_mark_stack_ptr_t *stack = sexp_context_mark_stack(ctx);
+  struct sexp_mark_stack_ptr_t **ptr = &sexp_context_mark_stack_ptr(ctx);
+  struct sexp_mark_stack_ptr_t *old = *ptr;
+
+  if (old == NULL) {
+    *ptr = stack;
+  } else if (old >= stack && old + 1 < stack + SEXP_MARK_STACK_COUNT) {
+    (*ptr)++;
+  } else {
+    *ptr = malloc(sizeof(**ptr));
+  }
+
+  (*ptr)->start = start;
+  (*ptr)->end = end;
+  (*ptr)->prev = old;
+}
+
+static void sexp_mark_stack_pop (sexp ctx) {
+  struct sexp_mark_stack_ptr_t *stack = sexp_context_mark_stack(ctx);
+  struct sexp_mark_stack_ptr_t *old = sexp_context_mark_stack_ptr(ctx);
+
+  sexp_context_mark_stack_ptr(ctx) = old->prev;
+  if (!(old >= stack && old < stack + SEXP_MARK_STACK_COUNT)) {
+    free(old);
+  }
+}
+
+static void sexp_mark_one (sexp ctx, sexp* types, sexp x) {
   sexp_sint_t len;
   sexp t, *p, *q;
   struct sexp_gc_var_t *saves;
@@ -196,24 +263,44 @@ void sexp_mark (sexp ctx, sexp x) {
   sexp_markedp(x) = 1;
   if (sexp_contextp(x)) {
     for (saves=sexp_context_saves(x); saves; saves=saves->next)
-      if (saves->var) sexp_mark(ctx, *(saves->var));
+      if (saves->var) sexp_mark_one(ctx, types, *(saves->var));
   }
-  t = sexp_object_type(ctx, x);
+  t = types[sexp_pointer_tag(x)];
   len = sexp_type_num_slots_of_object(t, x) - 1;
   if (len >= 0) {
     p = (sexp*) (((char*)x) + sexp_type_field_base(t));
     q = p + len;
-    while (p < q && ! (*q && sexp_pointerp(*q)))
+    while (p < q && (*q && sexp_pointerp(*q) ? sexp_markedp(*q) : 1))
       q--;                      /* skip trailing immediates */
     while (p < q && *q == q[-1])
       q--;                      /* skip trailing duplicates */
-    while (p < q)
-      sexp_mark(ctx, *p++);
-    x = *p;
+    if (p < q) {
+      sexp_mark_stack_push(ctx, p, q);
+    }
+    x = *q;
     goto loop;
   }
 }
 
+static void sexp_mark_one_start (sexp ctx, sexp* types, sexp x) {
+  struct sexp_mark_stack_ptr_t **ptr = &sexp_context_mark_stack_ptr(ctx);
+  sexp *p, *q;
+  sexp_mark_one(ctx, types, x);
+
+  while (*ptr) {
+    p = (*ptr)->start;
+    q = (*ptr)->end;
+    sexp_mark_stack_pop(ctx);
+    while (p < q) {
+      sexp_mark_one(ctx, types, *p++);
+    }
+  }
+}
+
+void sexp_mark (sexp ctx, sexp x) {
+  sexp_mark_one_start(ctx, sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)), x);
+}
+
 #if SEXP_USE_CONSERVATIVE_GC
 
 int stack_references_pointer_p (sexp ctx, sexp x) {
@@ -277,12 +364,16 @@ void sexp_conservative_mark (sexp ctx) {
 #endif
 
 #if SEXP_USE_WEAK_REFERENCES
-void sexp_reset_weak_references(sexp ctx) {
-  int i, len, all_reset_p;
-  sexp_heap h = sexp_context_heap(ctx);
+int sexp_reset_weak_references(sexp ctx) {
+  int i, len, broke, all_reset_p;
+  sexp_heap h;
   sexp p, t, end, *v;
   sexp_free_list q, r;
-  for ( ; h; h=h->next) {   /* just scan the whole heap */
+  if (sexp_not(sexp_global(ctx, SEXP_G_WEAK_OBJECTS_PRESENT)))
+    return 0;
+  broke = 0;
+  /* just scan the whole heap */
+  for (h = sexp_context_heap(ctx) ; h; h=h->next) {
     p = sexp_heap_first_block(h);
     q = h->free_list;
     end = sexp_heap_end(h);
@@ -309,6 +400,7 @@ void sexp_reset_weak_references(sexp ctx) {
             }
           }
           if (all_reset_p) {      /* ephemerons */
+            broke++;
             len += sexp_type_weak_len_extra(t);
             for ( ; i<len; i++) v[i] = SEXP_FALSE;
           }
@@ -317,11 +409,14 @@ void sexp_reset_weak_references(sexp ctx) {
       p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
     }
   }
+  sexp_debug_printf("%p (broke %d weak references)", ctx, broke);
+  return broke;
 }
 #else
-#define sexp_reset_weak_references(ctx)
+#define sexp_reset_weak_references(ctx) 0
 #endif
 
+#if SEXP_USE_FINALIZERS
 sexp sexp_finalize (sexp ctx) {
   size_t size;
   sexp p, t, end;
@@ -347,6 +442,9 @@ sexp sexp_finalize (sexp ctx) {
         continue;
       }
       size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
+      if (size == 0) {
+        return SEXP_FALSE;
+      }
       if (!sexp_markedp(p)) {
         t = sexp_object_type(ctx, p);
         finalizer = sexp_type_finalize(t);
@@ -368,6 +466,7 @@ sexp sexp_finalize (sexp ctx) {
 #endif
   return sexp_make_fixnum(finalize_count);
 }
+#endif
 
 sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
   size_t freed, max_freed=0, sum_freed=0, size;
@@ -388,7 +487,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
         continue;
       }
       size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
-#if SEXP_USE_DEBUG_GC
+#if SEXP_USE_DEBUG_GC > 1
       if (!sexp_valid_object_p(ctx, p))
         fprintf(stderr, SEXP_BANNER("%p sweep: invalid object at %p"), ctx, p);
       if ((char*)q + q->size > (char*)p)
@@ -453,17 +552,29 @@ void sexp_mark_global_symbols(sexp ctx) {
 
 sexp sexp_gc (sexp ctx, size_t *sum_freed) {
   sexp res, finalized SEXP_NO_WARN_UNUSED;
+#if SEXP_USE_TIME_GC
+  sexp_uint_t gc_usecs;
+  struct rusage start, end;
+  getrusage(RUSAGE_SELF, &start);
   sexp_debug_printf("%p (heap: %p size: %lu)", ctx, sexp_context_heap(ctx),
                     sexp_heap_total_size(sexp_context_heap(ctx)));
+#endif
   sexp_mark_global_symbols(ctx);
   sexp_mark(ctx, ctx);
   sexp_conservative_mark(ctx);
   sexp_reset_weak_references(ctx);
   finalized = sexp_finalize(ctx);
   res = sexp_sweep(ctx, sum_freed);
-  sexp_debug_printf("%p (freed: %lu max_freed: %lu finalized: %lu)", ctx,
-                    (sum_freed ? *sum_freed : 0), sexp_unbox_fixnum(res),
-                    sexp_unbox_fixnum(finalized));
+  ++sexp_context_gc_count(ctx);
+#if SEXP_USE_TIME_GC
+  getrusage(RUSAGE_SELF, &end);
+  gc_usecs = (end.ru_utime.tv_sec - start.ru_utime.tv_sec) * 1000000 +
+    end.ru_utime.tv_usec - start.ru_utime.tv_usec;
+  sexp_context_gc_usecs(ctx) += gc_usecs;
+  sexp_debug_printf("%p (freed: %lu max_freed: %lu finalized: %lu time: %luus)",
+                    ctx, (sum_freed ? *sum_freed : 0), sexp_unbox_fixnum(res),
+                    sexp_unbox_fixnum(finalized), gc_usecs);
+#endif
   return res;
 }
 
@@ -471,12 +582,13 @@ sexp_heap sexp_make_heap (size_t size, size_t max_size, size_t chunk_size) {
   sexp_free_list free, next;
   sexp_heap h;
 #if SEXP_USE_MMAP_GC
-  h =  mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE|PROT_EXEC,
-            MAP_ANON|MAP_PRIVATE, 0, 0);
+  h =  mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE,
+            MAP_ANON|MAP_PRIVATE, -1, 0);
+  if (h == MAP_FAILED) return NULL;
 #else
   h =  sexp_malloc(sexp_heap_pad_size(size));
-#endif
   if (! h) return NULL;
+#endif
   h->size = size;
   h->max_size = max_size;
   h->chunk_size = chunk_size;
@@ -501,24 +613,46 @@ sexp_heap sexp_make_heap (size_t size, size_t max_size, size_t chunk_size) {
 
 int sexp_grow_heap (sexp ctx, size_t size, size_t chunk_size) {
   size_t cur_size, new_size;
-  sexp_heap h = sexp_heap_last(sexp_context_heap(ctx));
+  sexp_heap tmp, h = sexp_heap_last(sexp_context_heap(ctx));
+#if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
+  for (tmp=sexp_context_heap(ctx); tmp; tmp=tmp->next)
+    if (tmp->chunk_size == size) {
+      while (tmp->next && tmp->next->chunk_size == size)
+        tmp = tmp->next;
+      h = tmp;
+      chunk_size = size;
+      break;
+    }
+#endif
   cur_size = h->size;
-  new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
-  h->next = sexp_make_heap(new_size, h->max_size, chunk_size);
+  new_size = (size_t) ceil(SEXP_GROW_HEAP_FACTOR * (double) (sexp_heap_align(((cur_size > size) ? cur_size : size))));
+  tmp = sexp_make_heap(new_size, h->max_size, chunk_size);
+  if (tmp) {
+    tmp->next = h->next;
+    h->next = tmp;
+  }
   return (h->next != NULL);
 }
 
 void* sexp_try_alloc (sexp ctx, size_t size) {
   sexp_free_list ls1, ls2, ls3;
   sexp_heap h;
+#if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
+  int found_fixed = 0;
+#endif
   for (h=sexp_context_heap(ctx); h; h=h->next) {
 #if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
-    if (h->chunk_size && h->chunk_size != size)
+    if (h->chunk_size) {
+      if (h->chunk_size != size)
         continue;
+      found_fixed = 1;
+    } else if (found_fixed) {   /* don't use a non-fixed heap */
+      return NULL;
+    }
 #endif
     for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) {
       if (ls2->size >= size) {
-#if SEXP_USE_DEBUG_GC
+#if SEXP_USE_DEBUG_GC > 1
         ls3 = (sexp_free_list) sexp_heap_end(h);
         if (ls2 >= ls3)
           fprintf(stderr, "alloced %lu bytes past end of heap: %p (%lu) >= %p"
@@ -541,15 +675,53 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
   return NULL;
 }
 
+#if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
+int sexp_find_fixed_chunk_heap_usage(sexp ctx, size_t size, size_t* sum_freed, size_t* total_size) {
+  sexp_heap h;
+  sexp_free_list ls;
+  size_t avail=0, total=0;
+  for (h=sexp_context_heap(ctx); h; h=h->next) {
+    if (h->chunk_size == size || !h->chunk_size) {
+      for (; h && (h->chunk_size == size || !h->chunk_size); h=h->next) {
+        total += h->size;
+        for (ls=h->free_list; ls; ls=ls->next)
+          avail += ls->size;
+      }
+      *sum_freed = avail;
+      *total_size = total;
+      return h && h->chunk_size > 0;
+    }
+  }
+  return 0;
+}
+#endif
+
+#if ! SEXP_USE_MALLOC
 void* sexp_alloc (sexp ctx, size_t size) {
   void *res;
-  size_t max_freed, sum_freed, total_size;
+  size_t max_freed, sum_freed, total_size=0;
   sexp_heap h = sexp_context_heap(ctx);
+#if SEXP_USE_TRACK_ALLOC_SIZES
+  size_t size_bucket;
+#endif
+#if SEXP_USE_TRACK_ALLOC_TIMES
+  sexp_uint_t alloc_time;
+  struct timeval start, end;
+  gettimeofday(&start, NULL);
+#endif
   size = sexp_heap_align(size) + SEXP_GC_PAD;
+#if SEXP_USE_TRACK_ALLOC_SIZES
+  size_bucket = (size - SEXP_GC_PAD) / sexp_heap_align(1) - 1;
+  ++sexp_context_alloc_histogram(ctx)[size_bucket >= SEXP_ALLOC_HISTOGRAM_BUCKETS ? SEXP_ALLOC_HISTOGRAM_BUCKETS-1 : size_bucket];
+#endif
   res = sexp_try_alloc(ctx, size);
   if (! res) {
     max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed));
+#if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
+    sexp_find_fixed_chunk_heap_usage(ctx, size, &sum_freed, &total_size);
+#else
     total_size = sexp_heap_total_size(sexp_context_heap(ctx));
+#endif
     if (((max_freed < size)
          || ((total_size > sum_freed)
              && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO)))
@@ -561,177 +733,17 @@ void* sexp_alloc (sexp ctx, size_t size) {
       sexp_debug_printf("ran out of memory allocating %lu bytes => %p", size, res);
     }
   }
+#if SEXP_USE_TRACK_ALLOC_TIMES
+  gettimeofday(&end, NULL);
+  alloc_time = 1000000*(end.tv_sec - start.tv_sec) + (end.tv_usec - start.tv_usec);
+  sexp_context_alloc_count(ctx) += 1;
+  sexp_context_alloc_usecs(ctx) += alloc_time;
+  sexp_context_alloc_usecs_sq(ctx) += alloc_time*alloc_time;
+#endif
   return res;
 }
-
-#if ! SEXP_USE_GLOBAL_HEAP
-
-void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags) {
-  sexp_sint_t i, off, len, freep, loadp;
-  sexp_free_list q;
-  sexp p, t, end, *v;
-#if SEXP_USE_DL
-  sexp name;
 #endif
-  freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP);
-  loadp = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_LOADP);
 
-  off = (sexp_sint_t)((sexp_sint_t)heap - (sexp_sint_t)from_heap);
-  heap->data += off;
-  end = (sexp) (heap->data + heap->size);
-
-  /* adjust the free list */
-  heap->free_list = (sexp_free_list) ((char*)heap->free_list + off);
-  for (q=heap->free_list; q->next; q=q->next)
-    q->next = (sexp_free_list) ((char*)q->next + off);
-
-  /* adjust data by traversing over the new heap */
-  p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
-  q = heap->free_list;
-  while (p < end) {
-    /* find the next free list pointer */
-    for ( ; q && ((char*)q < (char*)p); q=q->next)
-      ;
-    if ((char*)q == (char*)p) { /* this is a free block, skip it */
-      p = (sexp) (((char*)p) + q->size);
-    } else {
-      t = (sexp)((char*)(types[sexp_pointer_tag(p)])
-                 + ((char*)types > (char*)p ? off : 0));
-      len = sexp_type_num_slots_of_object(t, p);
-      v = (sexp*) ((char*)p + sexp_type_field_base(t));
-      /* offset any pointers in the _destination_ heap */
-      for (i=0; i<len; i++)
-        if (v[i] && sexp_pointerp(v[i]))
-          v[i] = (sexp) ((char*)v[i] + off);
-      /* don't free unless specified - only the original cleans up */
-      if (! freep)
-        sexp_freep(p) = 0;
-      /* adjust context heaps, don't copy saved sexp_gc_vars */
-      if (sexp_contextp(p)) {
-#if SEXP_USE_GREEN_THREADS
-        sexp_context_ip(p) += off;
-#endif
-        sexp_context_last_fp(p) += off;
-        sexp_stack_top(sexp_context_stack(p)) = 0;
-        sexp_context_saves(p) = NULL;
-        sexp_context_heap(p) = heap;
-      } else if (sexp_bytecodep(p) && off != 0) {
-        for (i=0; i<sexp_bytecode_length(p); ) {
-          switch (sexp_bytecode_data(p)[i++]) {
-            case SEXP_OP_FCALL0:      case SEXP_OP_FCALL1:
-            case SEXP_OP_FCALL2:      case SEXP_OP_FCALL3:
-            case SEXP_OP_FCALL4:      case SEXP_OP_CALL:
-            case SEXP_OP_TAIL_CALL:   case SEXP_OP_PUSH:
-            case SEXP_OP_GLOBAL_REF:  case SEXP_OP_GLOBAL_KNOWN_REF:
-#if SEXP_USE_GREEN_THREADS
-            case SEXP_OP_PARAMETER_REF:
-#endif
-#if SEXP_USE_EXTENDED_FCALL
-            case SEXP_OP_FCALLN:
-#endif
-              v = (sexp*)(&(sexp_bytecode_data(p)[i]));
-              if (v[0] && sexp_pointerp(v[0])) v[0] = (sexp) (((char*)v[0]) + off);
-              /* ... FALLTHROUGH ... */
-            case SEXP_OP_JUMP:        case SEXP_OP_JUMP_UNLESS:
-            case SEXP_OP_STACK_REF:   case SEXP_OP_CLOSURE_REF:
-            case SEXP_OP_LOCAL_REF:   case SEXP_OP_LOCAL_SET:
-            case SEXP_OP_TYPEP:
-#if SEXP_USE_RESERVE_OPCODE
-            case SEXP_OP_RESERVE:
-#endif
-              i += sizeof(sexp); break;
-            case SEXP_OP_MAKE: case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_SET:
-              i += 2*sizeof(sexp); break;
-            case SEXP_OP_MAKE_PROCEDURE:
-              v = (sexp*)(&(sexp_bytecode_data(p)[i]));
-              if (v[2] && sexp_pointerp(v[2])) v[2] = (sexp) (((char*)v[2]) + off);
-              i += 3*sizeof(sexp); break;
-          }
-        }
-      } else if (sexp_portp(p) && sexp_port_stream(p)) {
-        sexp_port_stream(p) = 0;
-        sexp_port_openp(p) = 0;
-        sexp_freep(p) = 0;
-#if SEXP_USE_DL
-      } else if (loadp && sexp_dlp(p)) {
-        sexp_dl_handle(p) = NULL;
-#endif
-      }
-      p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p))+SEXP_GC_PAD);
-    }
-  }
-
-  /* make a second pass to fix code references */
-  if (loadp) {
-    p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
-    q = heap->free_list;
-    while (p < end) {
-      /* find the next free list pointer */
-      for ( ; q && ((char*)q < (char*)p); q=q->next)
-        ;
-      if ((char*)q == (char*)p) { /* this is a free block, skip it */
-        p = (sexp) (((char*)p) + q->size);
-      } else {
-#if SEXP_USE_DL
-        if (sexp_opcodep(p) && sexp_opcode_func(p)) {
-          name = (sexp_opcode_data2(p) && sexp_stringp(sexp_opcode_data2(p))) ? sexp_opcode_data2(p) : sexp_opcode_name(p);
-          if (sexp_dlp(sexp_opcode_dl(p))) {
-            if (!sexp_dl_handle(sexp_opcode_dl(p)))
-              sexp_dl_handle(sexp_opcode_dl(p)) = dlopen(sexp_string_data(sexp_dl_file(sexp_opcode_dl(p))), RTLD_LAZY);
-            sexp_opcode_func(p) = dlsym(sexp_dl_handle(sexp_opcode_dl(p)), sexp_string_data(name));
-          } else {
-            sexp_opcode_func(p) = dlsym(SEXP_RTLD_DEFAULT, sexp_string_data(name));
-          }
-        } else
-#endif
-        if (sexp_typep(p)) {
-          if (sexp_type_finalize(p)) {
-            /* TODO: handle arbitrary finalizers in images */
-#if SEXP_USE_DL
-            if (sexp_type_tag(p) == SEXP_DL)
-              sexp_type_finalize(p) = SEXP_FINALIZE_DL;
-            else
-#endif
-              sexp_type_finalize(p) = SEXP_FINALIZE_PORT;
-          }
-        }
-        t = types[sexp_pointer_tag(p)];
-        p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)+SEXP_GC_PAD));
-      }
-    }
-  }
-}
-
-sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
-  sexp_sint_t off;
-  sexp_heap to, from = sexp_context_heap(ctx);
-
-  /* validate input, creating a new heap if needed */
-  if (from->next) {
-    return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx);
-  } else if (! dst || sexp_not(dst)) {
-    to = sexp_make_heap(from->size, from->max_size, from->chunk_size);
-    if (!to) return sexp_global(ctx, SEXP_G_OOM_ERROR);
-    dst = (sexp) ((char*)ctx + ((char*)to - (char*)from));
-  } else if (! sexp_contextp(dst)) {
-    return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst);
-  } else if (sexp_context_heap(dst)->size < from->size) {
-    return sexp_user_exception(ctx, NULL, "destination context too small", dst);
-  } else {
-    to = sexp_context_heap(dst);
-  }
-
-  /* copy the raw data */
-  off = (char*)to - (char*)from;
-  memcpy(to, from, sexp_heap_pad_size(from->size));
-
-  /* adjust the pointers */
-  sexp_offset_heap_pointers(to, from, sexp_context_types(ctx) + off, flags);
-
-  return dst;
-}
-
-#endif
 
 void sexp_gc_init (void) {
 #if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC
@@ -746,4 +758,4 @@ void sexp_gc_init (void) {
 #endif
 }
 
-#endif
+#endif  /* ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC */

gc_heap.c

@@ -0,0 +1,789 @@
+/* gc_heap.h -- heap packing, run-time image generation    */
+/* Copyright (c) 2016 Chris Walsh.  All rights reserved.   */
+/* BSD-style license: http://synthcode.com/license.txt     */
+
+#include "chibi/gc_heap.h"
+
+#if SEXP_USE_IMAGE_LOADING
+
+#define ERR_STR_SIZE 256
+static char gc_heap_err_str[ERR_STR_SIZE];
+
+
+static sexp_uint_t sexp_gc_allocated_bytes (sexp ctx, sexp *types, size_t types_cnt, sexp x) {
+  sexp_uint_t res = 0;
+  if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= types_cnt)) {
+    res = 1;
+  } else {
+    res = sexp_type_size_of_object(types[sexp_pointer_tag(x)], x) + SEXP_GC_PAD;
+  }
+  return sexp_heap_align(res);
+}
+
+
+sexp sexp_gc_heap_walk(sexp ctx,
+                       sexp_heap h,  /* normally set to sexp_context_heap(ctx) */
+                       sexp *t,      /* normally set to sexp_context_types(ctx) */
+                       size_t t_cnt, /* normally set to sexp_context_num_types(ctx) */
+                       void *user,
+                       sexp (*heap_callback)(sexp ctx, sexp_heap h, void *user),
+                       sexp (*free_callback)(sexp ctx, sexp_free_list f, void *user),
+                       sexp (*sexp_callback)(sexp ctx, sexp s, void *user))
+{
+  sexp res = SEXP_FALSE;
+
+  size_t size = 0;
+  while (h) {
+    sexp p = sexp_heap_first_block(h);
+    sexp_free_list q = h->free_list;
+    sexp end = sexp_heap_end(h);
+
+    while (p < end) {
+      /* find the preceding and succeeding free list pointers */
+      sexp_free_list r = q->next;
+      while (r && ((unsigned char*)r < (unsigned char*)p)) {
+        q = r;
+        r = r->next;
+      }
+      
+      if ( (unsigned char*)r == (unsigned char*)p ) {
+        if (free_callback && (res = free_callback(ctx, r, user)) != SEXP_TRUE) {
+          return res; }
+        size = r ? r->size : 0;
+      } else {
+        if (sexp_callback && (res = sexp_callback(ctx, p, user)) != SEXP_TRUE) {
+          return res; }
+        size = sexp_gc_allocated_bytes(ctx, t, t_cnt, p);
+        if (size == 0) {
+          snprintf(gc_heap_err_str, ERR_STR_SIZE, "Heap element with a zero size detected");
+          goto done;
+        }
+      }
+      p = (sexp)(((unsigned char*)p) + size);
+    }
+    
+    if (heap_callback && (res = heap_callback(ctx, h, user)) != SEXP_TRUE) {
+      return res; }
+    h = h->next;
+  }
+  res = SEXP_TRUE;
+done:
+  if (res != SEXP_TRUE) res = sexp_user_exception(ctx, NULL, gc_heap_err_str, SEXP_NULL);
+  return res;
+}
+
+
+struct sexp_remap {
+  sexp srcp;
+  sexp dstp;
+};
+
+struct sexp_remap_state {
+  size_t index, heaps_count, sexps_count, sexps_size;
+  sexp p, end, ctx_src, ctx_dst;
+  sexp_heap heap;
+  int mode;
+  struct sexp_remap *remap;
+};
+
+
+static sexp heap_callback_count(sexp ctx, sexp_heap h, void *user) {
+  struct sexp_remap_state* state = user;
+  state->heaps_count += 1;
+  return SEXP_TRUE;
+}
+
+static sexp sexp_callback_count(sexp ctx, sexp s, void *user) {
+  struct sexp_remap_state* state = user;
+  size_t size = sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx),
+                                        sexp_context_num_types(ctx), s);
+  state->sexps_count += 1;
+  state->sexps_size  += size;
+  return SEXP_TRUE;
+}
+
+static sexp heap_callback_remap(sexp ctx, sexp_heap h, void *user) {
+  return SEXP_NULL;
+}
+
+static sexp sexp_callback_remap(sexp ctx, sexp s, void *user) {
+  struct sexp_remap_state* state = user;
+  size_t size = sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx),
+                                        sexp_context_num_types(ctx), s);
+  if (state->p >= state->end) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "callback_remap i=%zu p>end internal error", state->index);
+    return SEXP_FALSE; }
+  memcpy(state->p, s, size);
+  
+  state->remap[state->index].srcp = s;
+  state->remap[state->index].dstp = state->p;
+  if (ctx == s) state->ctx_dst = state->p;
+  
+  state->p = (sexp)(((unsigned char*)state->p) + size);
+  state->index += 1;
+
+  return SEXP_TRUE;
+}
+
+
+
+/* Return a destination (remapped) pointer for a given source pointer */
+static sexp sexp_gc_heap_pack_src_to_dst(void* adata, sexp srcp) {
+
+  struct sexp_remap_state* state = adata;
+  sexp_sint_t imin = 0;
+  sexp_sint_t imax = state->sexps_count - 1;
+
+  while (imin <= imax) {
+    sexp_sint_t imid = ((imax - imin) / 2) + imin;
+    sexp midp = state->remap[imid].srcp;
+    if (midp == srcp) {
+      return state->remap[imid].dstp;
+    } else if (midp < srcp) {
+      imin = imid + 1;
+    } else {
+      imax = imid - 1;
+    }
+  }
+  snprintf(gc_heap_err_str, ERR_STR_SIZE, "Source SEXP not found in src->dst mapping");
+  return SEXP_FALSE;
+}
+
+
+static sexp sexp_adjust_fields(sexp dstp, sexp* types, sexp (* adjust_fn)(void *, sexp), void *adata) {
+  sexp_tag_t tag           = sexp_pointer_tag(dstp);
+  sexp       type_spec     = types[tag];
+  size_t     type_sexp_cnt = sexp_type_num_slots_of_object(type_spec, dstp);
+  sexp*      vec           = (sexp*)((unsigned char*)dstp + sexp_type_field_base(type_spec));
+  int        i;
+  
+  for (i = 0; i < type_sexp_cnt; i++) {
+    sexp src = vec[i];
+    sexp dst = src;
+    if (src && sexp_pointerp(src)) {
+      dst = adjust_fn(adata, src);
+      if (!sexp_pointerp(dst)) { 
+        size_t sz = strlen(gc_heap_err_str);
+        snprintf(gc_heap_err_str + sz, ERR_STR_SIZE - sz, " from adjust fields, tag=%u i=%d", tag, i);
+        return SEXP_FALSE; }
+    }
+    vec[i] = dst;
+  }
+  return SEXP_TRUE;
+}
+
+
+static sexp sexp_adjust_bytecode(sexp dstp, sexp (*adjust_fn)(void *, sexp), void *adata) {
+  sexp res = SEXP_FALSE;
+  sexp   src, dst;
+  sexp*  vec;
+  int    i;
+  
+  for (i=0; i < sexp_bytecode_length(dstp); ) {
+    switch (sexp_bytecode_data(dstp)[i++]) {
+    case SEXP_OP_FCALL0:      case SEXP_OP_FCALL1:
+    case SEXP_OP_FCALL2:      case SEXP_OP_FCALL3:
+    case SEXP_OP_FCALL4:      case SEXP_OP_CALL:
+    case SEXP_OP_TAIL_CALL:   case SEXP_OP_PUSH:
+    case SEXP_OP_GLOBAL_REF:  case SEXP_OP_GLOBAL_KNOWN_REF:
+#if SEXP_USE_GREEN_THREADS
+    case SEXP_OP_PARAMETER_REF:
+#endif
+#if SEXP_USE_EXTENDED_FCALL
+    case SEXP_OP_FCALLN:
+#endif
+      vec = (sexp*)(&(sexp_bytecode_data(dstp)[i]));
+      src = vec[0];
+      if (src && sexp_pointerp(src)) {
+        dst = adjust_fn(adata, src);
+        if (!sexp_pointerp(dst)) {
+          size_t sz = strlen(gc_heap_err_str);
+          snprintf(gc_heap_err_str + sz, ERR_STR_SIZE - sz, " from adjust bytecode, FCALLN");
+          goto done; }
+        vec[0] = dst;
+      }
+      /* ... FALLTHROUGH ... */
+    case SEXP_OP_JUMP:        case SEXP_OP_JUMP_UNLESS:
+    case SEXP_OP_STACK_REF:   case SEXP_OP_CLOSURE_REF:
+    case SEXP_OP_LOCAL_REF:   case SEXP_OP_LOCAL_SET:
+    case SEXP_OP_TYPEP:
+#if SEXP_USE_RESERVE_OPCODE
+    case SEXP_OP_RESERVE:
+#endif
+      i += sizeof(sexp); break;
+    case SEXP_OP_MAKE: case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_SET:
+      i += 2*sizeof(sexp); break;
+    case SEXP_OP_MAKE_PROCEDURE:
+      vec = (sexp*)(&(sexp_bytecode_data(dstp)[i]));
+      src = vec[2];
+      if (src && sexp_pointerp(src)) {
+        dst = adjust_fn(adata, src);
+        if (!sexp_pointerp(dst)) { 
+          size_t sz = strlen(gc_heap_err_str);
+          snprintf(gc_heap_err_str + sz, ERR_STR_SIZE - sz, " from adjust bytecode, PROCEDURE");
+          goto done; }
+        vec[2] = dst;
+      }
+      i += 3*sizeof(sexp); break;
+    }
+  }
+  res = SEXP_TRUE;
+done:
+  return res;
+}
+
+static sexp sexp_gc_heap_pack_adjust(sexp dstp, sexp* types, struct sexp_remap_state* state) {
+  sexp res = SEXP_FALSE;
+  /* Adjust internal types which contain fields of sexp pointer(s)
+     within in the heap */
+  if ((res = sexp_adjust_fields(dstp, types, sexp_gc_heap_pack_src_to_dst, state)) != SEXP_TRUE) {
+    goto done; }
+    
+  /* Other adjustments - context heap pointer, bytecode pointers */
+  if (sexp_contextp(dstp)) {
+    sexp_context_heap(dstp) = state->heap;
+  } else if (sexp_bytecodep(dstp)) {
+    if ((res = sexp_adjust_bytecode(dstp, sexp_gc_heap_pack_src_to_dst, state)) != SEXP_TRUE) {
+      goto done; }
+  }
+  res = SEXP_TRUE;
+done:
+  return res;
+}
+
+
+static sexp_heap sexp_gc_packed_heap_make(size_t packed_size, size_t free_size) {
+  if (free_size > 0 && free_size < 2*sexp_free_chunk_size) {
+    free_size = 2*sexp_free_chunk_size;
+  }
+  free_size = sexp_heap_align(free_size);
+  size_t req_size = packed_size + free_size + sexp_free_chunk_size + 128;
+  sexp_heap heap = sexp_make_heap(sexp_heap_align(req_size), 0, 0);
+  if (!heap) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "Could not allocate memory for heap");
+    return NULL;
+  }
+  sexp base = sexp_heap_first_block(heap);
+  size_t pad = (unsigned char *)base - (unsigned char *)heap->data;
+  heap->size = packed_size + free_size + pad;
+  heap->free_list->size = 0;
+  if (free_size == 0) {
+    heap->free_list->next = NULL;
+  } else {
+    heap->free_list->next = (sexp_free_list)((unsigned char *)base + packed_size);
+    heap->free_list->next->next = NULL;
+    heap->free_list->next->size = free_size;
+  }
+  return heap;
+}
+
+static int heaps_compar(const void* v1, const void* v2) {
+  sexp_heap h1 = *((sexp_heap*)v1);
+  sexp_heap h2 = *((sexp_heap*)v2);
+  return 
+    (h1 < h2) ? -1 : 
+    (h1 > h2) ?  1 : 0;
+}
+
+/* Pack the heap.  Return a new context with a unified, packed heap.  No change to original context. */
+sexp sexp_gc_heap_pack(sexp ctx_src, sexp_uint_t heap_free_size) {
+
+  sexp res = NULL;
+  sexp_gc(ctx_src, NULL);
+  sexp_heap* heaps = NULL;
+  int i = 0;
+
+  /* 1.  Collect statistics - sexp count, size, heap count */
+  
+  struct sexp_remap_state state;
+  memset(&state, 0, sizeof(struct sexp_remap_state));
+  state.ctx_src = ctx_src;
+  if ((res = sexp_gc_heap_walk(ctx_src, sexp_context_heap(ctx_src), 
+                               sexp_context_types(ctx_src), sexp_context_num_types(ctx_src),
+                               &state, heap_callback_count, NULL, sexp_callback_count)) != SEXP_TRUE) {
+    goto done; }
+
+  /* 2.  Make a new heap of the correct size to hold the sexps from the old heap. */
+
+  state.heap = sexp_gc_packed_heap_make(state.sexps_size, heap_free_size);
+  if (!state.heap) {
+    res = sexp_global(ctx_src, SEXP_G_OOM_ERROR);
+    goto done; }
+
+  /* 3.  Create a list of heaps sorted by increasing memory address, for srcp search lookup */
+
+  heaps = malloc(sizeof(sexp_heap) * state.heaps_count);
+  if (!heaps) {
+    res = sexp_global(ctx_src, SEXP_G_OOM_ERROR);
+    goto done; }
+  sexp_heap h = sexp_context_heap(ctx_src);
+  for (i = 0; h; i++, h=h->next) { heaps[i] = h; }
+  qsort(heaps, state.heaps_count, sizeof(sexp_heap), heaps_compar);
+
+  /* 4.  Pack the sexps into the new heap */
+
+  state.p     = sexp_heap_first_block(state.heap);
+  state.end   = sexp_heap_end(state.heap);
+  state.index = 0;
+  state.remap = malloc(sizeof(struct sexp_remap) * state.sexps_count);
+  if (!state.remap) {
+    res = sexp_global(ctx_src, SEXP_G_OOM_ERROR);
+    goto done; }
+  
+  for (i = 0; i < state.heaps_count; i++) {
+    res = sexp_gc_heap_walk(ctx_src, heaps[i],
+                            sexp_context_types(ctx_src), sexp_context_num_types(ctx_src),
+                            &state, heap_callback_remap, NULL, sexp_callback_remap);
+    if (!(res == SEXP_TRUE || res == SEXP_NULL)) { 
+      size_t sz = strlen(gc_heap_err_str);
+      snprintf(gc_heap_err_str + sz, ERR_STR_SIZE - sz, "; remap heap %d %p walk heap_pack", i, heaps[i]);
+      goto done; }
+  }
+
+  /* 5.  Adjust sexp pointers to new locations inside the new heap */
+
+  sexp* types = sexp_context_types(state.ctx_src);
+  int idx;
+  for (idx = 0; idx < state.sexps_count; idx++) {
+    sexp dstp = state.remap[idx].dstp;
+    res = sexp_gc_heap_pack_adjust(dstp, types, &state);
+    if (res != SEXP_TRUE) { 
+      size_t sz = strlen(gc_heap_err_str);
+      snprintf(gc_heap_err_str + sz, ERR_STR_SIZE - sz, "; src->dst idx=%d heap_pack", idx);
+      goto done; }
+  }
+
+  res = SEXP_TRUE;
+
+done:
+  /* 6. Clean up. */
+
+  if (state.heap && res != SEXP_TRUE) { sexp_free_heap(state.heap); }
+  if (state.remap) { free(state.remap); }
+  if (heaps) { free(heaps); }
+
+  return (res == SEXP_TRUE) ? state.ctx_dst : res;
+}
+
+
+#define SEXP_IMAGE_MAGIC "\a\achibi\n\0"
+#define SEXP_IMAGE_MAJOR_VERSION 1
+#define SEXP_IMAGE_MINOR_VERSION 1
+
+struct sexp_image_header_t {
+  char magic[8];
+  short major, minor;
+  sexp_abi_identifier_t abi;
+  sexp_uint_t size;
+  sexp base;
+  sexp context;
+};
+
+
+sexp sexp_save_image (sexp ctx_in, const char* filename) {
+  sexp_heap heap = NULL;
+  sexp res = NULL;
+  FILE *fp = fopen(filename, "wb");
+  if (!fp) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "Could not open image file for writing: %s", filename);
+    goto done;
+  }
+  
+  /* Save ONLY packed, active SEXPs.  No free list structures or padding. */
+  sexp ctx_out = sexp_gc_heap_pack(ctx_in, 0);
+  if (!ctx_out || !sexp_contextp(ctx_out)) {
+    goto done;
+  }
+  heap = sexp_context_heap(ctx_out);
+  sexp   base = sexp_heap_first_block(heap);
+  size_t pad  = (size_t)((unsigned char *)base - (unsigned char *)heap->data);
+  size_t size = heap->size - pad;
+  
+  struct sexp_image_header_t header;
+  memcpy(&header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic));
+  memcpy(&header.abi, SEXP_ABI_IDENTIFIER, sizeof(header.abi));
+  header.major   = SEXP_IMAGE_MAJOR_VERSION;
+  header.minor   = SEXP_IMAGE_MINOR_VERSION;
+  header.size    = size;
+  header.base    = base;
+  header.context = ctx_out;
+
+  if (! (fwrite(&header, sizeof(header), 1, fp) == 1 &&
+         fwrite(base, size, 1, fp) == 1)) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "Error writing image file: %s", filename);
+    goto done;
+  }
+  
+  res = SEXP_TRUE;
+done:
+  if (fp) fclose(fp);
+  if (heap) sexp_free_heap(heap);
+  if (res != SEXP_TRUE) res = sexp_user_exception(ctx_in, NULL, gc_heap_err_str, SEXP_NULL);
+  return res;
+}
+
+
+
+#if SEXP_USE_DL
+
+#ifdef __APPLE__
+#define SEXP_RTLD_DEFAULT RTLD_SELF
+#else
+#define SEXP_RTLD_DEFAULT RTLD_DEFAULT
+#endif
+
+struct load_image_state {
+  sexp_sint_t offset;
+  sexp_heap heap;
+  sexp *types;
+  size_t types_cnt;
+};
+
+/* Return a destination (remapped) pointer for a given source pointer */
+static sexp load_image_src_to_dst(void* adata, sexp srcp) {
+  struct load_image_state* state = adata;
+  return (sexp)((unsigned char *)srcp + state->offset);
+}
+
+
+static sexp load_image_callback_p1 (sexp ctx, sexp p, void *user) {
+  sexp res = NULL;
+  struct load_image_state* state = user;
+
+  if ((res = sexp_adjust_fields(p, state->types, load_image_src_to_dst, state)) != SEXP_TRUE) {
+    goto done; }
+    
+  if (sexp_contextp(p)) {
+#if SEXP_USE_GREEN_THREADS
+    sexp_context_ip(p) += state->offset;
+#endif
+    sexp_context_last_fp(p) += state->offset;
+    sexp_stack_top(sexp_context_stack(p)) = 0;
+    sexp_context_saves(p) = NULL;
+    sexp_context_heap(p) = state->heap;
+  
+  } else if (sexp_bytecodep(p)) {
+    if ((res = sexp_adjust_bytecode(p, load_image_src_to_dst, state)) != SEXP_TRUE) {
+      goto done; }
+    
+  } else if (sexp_portp(p) && sexp_port_stream(p)) {
+    sexp_port_stream(p) = 0;
+    sexp_port_openp(p) = 0;
+    sexp_freep(p) = 0;
+    
+  } else if (sexp_dlp(p)) {
+    sexp_dl_handle(p) = NULL;
+
+  }
+  res = SEXP_TRUE;
+done:
+  return res;
+}
+
+#ifdef _WIN32
+static void* load_image_fn(sexp ctx, sexp dl, sexp name) {
+  snprintf(gc_heap_err_str, ERR_STR_SIZE,
+           "load_image_fn: Needed to be ported to Win32");
+  return NULL;
+}
+#else
+static void* load_image_fn(sexp ctx, sexp dl, sexp name) {
+  sexp ls;
+  void *fn = NULL;
+  char *file_name, *rel_name=NULL, *new_file_name;
+  char *handle_name = "<static>";
+  char *symbol_name = sexp_string_data(name);
+  if (dl && sexp_dlp(dl)) {
+    if (!sexp_dl_handle(dl)) {
+      /* try exact file, then the search path */
+      file_name = sexp_string_data(sexp_dl_file(dl));
+      sexp_dl_handle(dl) = dlopen(file_name, RTLD_LAZY);
+      if (!sexp_dl_handle(dl)) {
+        for (ls = sexp_global(ctx, SEXP_G_MODULE_PATH); sexp_pairp(ls); ls=sexp_cdr(ls)) {
+          if (strstr(file_name, sexp_string_data(sexp_car(ls))) == file_name) {
+            rel_name = file_name + sexp_string_size(sexp_car(ls));
+            while (*rel_name == '/')
+              ++rel_name;
+            new_file_name = sexp_find_module_file_raw(ctx, rel_name);
+            if (new_file_name) {
+              sexp_dl_handle(dl) = dlopen(new_file_name, RTLD_LAZY);
+              free(new_file_name);
+              if (sexp_dl_handle(dl))
+                break;
+            }
+          }
+        }
+        if (!sexp_dl_handle(dl)) {
+          handle_name = sexp_string_data(sexp_dl_file(dl));
+          snprintf(gc_heap_err_str, ERR_STR_SIZE, "dlopen failure: %s",
+                   handle_name);
+          return NULL;
+        }
+      }
+    }
+    fn = dlsym(sexp_dl_handle(dl), symbol_name);
+  } else {
+    fn = dlsym(SEXP_RTLD_DEFAULT, symbol_name);
+  }
+  if (!fn) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE,
+             "dynamic function lookup failure: %s %s",
+             handle_name, symbol_name);
+  }
+  return fn;
+}
+#endif
+
+static sexp load_image_callback_p2 (sexp ctx, sexp dstp, void *user) {
+  sexp res = NULL;
+  sexp name = NULL;
+  void *fn = NULL;
+
+  if (sexp_opcodep(dstp) && sexp_opcode_func(dstp)) {
+    if (sexp_opcode_data2(dstp) && sexp_stringp(sexp_opcode_data2(dstp))) {
+      name = sexp_opcode_data2(dstp);
+    } else {
+      name = sexp_opcode_name(dstp);
+    }
+    if (!name) {
+      snprintf(gc_heap_err_str, ERR_STR_SIZE, "opcode func field missing function name");
+      return SEXP_FALSE;
+    }
+    
+    fn = load_image_fn(ctx, sexp_opcode_dl(dstp), name);
+    if (!fn) {
+      return SEXP_FALSE;
+    }
+    sexp_opcode_func(dstp) = fn;
+  
+  } else if (sexp_typep(dstp) && sexp_type_finalize(dstp)) {
+    name = sexp_type_finalize_name(dstp);
+    if (!name) {
+      snprintf(gc_heap_err_str, ERR_STR_SIZE, "type finalize field missing function name");
+      return SEXP_FALSE;
+    }
+    fn = load_image_fn(ctx, sexp_type_dl(dstp), name);
+    if (!fn) {
+      return SEXP_FALSE;
+    }
+    sexp_type_finalize(dstp) = fn;
+  }
+  res = SEXP_TRUE;
+  return res;
+}
+
+
+static int load_image_header(FILE *fp, struct sexp_image_header_t* header) {
+  if (!fp || !header) { return 0; }
+  
+  if (fread(header, sizeof(struct sexp_image_header_t), 1, fp) != 1) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "couldn't read image header");
+    return 0;
+  }
+  if (memcmp(header->magic, SEXP_IMAGE_MAGIC, sizeof(header->magic)) != 0) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "invalid image file magic %s\n", header->magic);
+    return 0;
+  } else if (header->major != SEXP_IMAGE_MAJOR_VERSION
+             || header->major < SEXP_IMAGE_MINOR_VERSION) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "unsupported image version: %d.%d\n",
+             header->major, header->minor);
+    return 0;
+  } else if (!sexp_abi_compatible(NULL, header->abi, SEXP_ABI_IDENTIFIER)) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "unsupported ABI: %s (expected %s)\n",
+             header->abi, SEXP_ABI_IDENTIFIER);
+    return 0;
+  }
+  return 1;
+}
+
+char* sexp_load_image_err() {
+  gc_heap_err_str[ERR_STR_SIZE-1] = 0;
+  return gc_heap_err_str;
+}
+
+static const char* all_paths[] = {sexp_default_module_path, sexp_default_user_module_path};
+
+sexp sexp_load_image (const char* filename, off_t offset, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size) {
+  struct load_image_state state;
+  struct sexp_image_header_t header;
+  const char *mod_path, *colon, *end;
+  char path[512];
+  FILE *fp;
+  int i, len;
+  sexp res = NULL, ctx = NULL, base, *ctx_globals, *ctx_types;
+
+  gc_heap_err_str[0] = 0;
+
+  memset(&state, 0, sizeof(struct load_image_state));
+
+  fp = fopen(filename, "rb");
+  /* fallback to the default search path (can't use sexp_find_module_file */
+  /* since there's no context yet) */
+  for (i=0; !fp && i<sizeof(all_paths)/sizeof(all_paths[0]); ++i) {
+    for (mod_path=all_paths[i]; *mod_path; mod_path=colon+1) {
+      colon = strchr(mod_path, ':');
+      end = colon ? colon : mod_path + strlen(mod_path);
+      snprintf(path, sizeof(path), "%s", mod_path);
+      if (end[-1] != '/') path[end-mod_path] = '/';
+      len = (end-mod_path) + (end[-1] == '/' ? 0 : 1);
+      snprintf(path + len, sizeof(path) - len, "%s", filename);
+      fp = fopen(path, "rb");
+      if (fp || !colon) break;
+    }
+  }
+  if (!fp) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "couldn't open image file for reading: %s\n", filename);
+    goto done;
+  }
+  if (offset > 0 && fseek(fp, offset, SEEK_SET) < 0) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "couldn't seek to image offset: %s -> %"SEXP_PRIdOFF": %s\n", filename, offset, strerror(errno));
+    goto done;
+  }
+
+  if (!load_image_header(fp, &header)) { goto done; }
+
+  state.heap = sexp_gc_packed_heap_make(header.size, heap_free_size);
+  if (!state.heap) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "couldn't malloc heap\n");
+    goto done;
+  }
+  base = sexp_heap_first_block(state.heap);
+
+  if (fread(base, 1, header.size, fp) != header.size) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "error reading image\n");
+    goto done;
+  }
+
+  /* Adjust pointers in loaded packed heap. */
+
+  state.offset = (sexp_sint_t)((sexp_sint_t)base - (sexp_sint_t)header.base);
+  ctx = (sexp)((unsigned char *)header.context + state.offset);
+  sexp_context_heap(ctx) = state.heap;
+
+  /* Type information (specifically, how big types are) is stored as sexps in the
+     heap.  This information is needed to sucessfully walk an arbitrary heap.  A
+     copy of the type array pointers with correct offsets is applied is created outside
+     of the new heap to be used with the pointer adjustment process.
+  */
+  ctx_globals = sexp_vector_data((sexp)((unsigned char*)sexp_context_globals(ctx) + state.offset));
+  ctx_types   = sexp_vector_data((sexp)((unsigned char*)(ctx_globals[SEXP_G_TYPES]) + state.offset));
+  state.types_cnt   = sexp_unbox_fixnum(ctx_globals[SEXP_G_NUM_TYPES]);
+  state.types = malloc(sizeof(sexp) * state.types_cnt);
+  if (!state.types) goto done;
+  for (i = 0; i < state.types_cnt; i++) {
+    state.types[i] = (sexp)((unsigned char *)ctx_types[i] + state.offset);
+  }
+
+  if (sexp_gc_heap_walk(ctx, sexp_context_heap(ctx), state.types, state.types_cnt,
+                        &state, NULL, NULL, load_image_callback_p1) != SEXP_TRUE)
+    goto done;
+
+  /* Second pass to fix code references */
+  if (sexp_gc_heap_walk(ctx, sexp_context_heap(ctx), state.types, state.types_cnt,
+                        &state, NULL, NULL, load_image_callback_p2) != SEXP_TRUE)
+    goto done;
+
+  if (heap_max_size > SEXP_INITIAL_HEAP_SIZE) {
+    sexp_context_heap(ctx)->max_size = heap_max_size;
+  }
+
+  res = ctx;
+done:
+  if (fp) fclose(fp);
+  if (state.heap && !ctx) free(state.heap);
+  if (state.types) free(state.types);
+  return res;
+}
+
+#else
+
+sexp sexp_load_image (const char* filename, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size) {
+  return NULL;
+}
+
+#endif
+
+
+
+
+/****************** Debugging ************************/
+
+/* you can use (chibi heap-stats) without debug enabled */
+#if SEXP_USE_DEBUG_GC
+
+#define SEXP_CORE_TYPES_MAX 255
+
+struct sexp_stats_entry {
+  size_t count;
+  size_t size_all;
+  size_t size_min;
+  size_t size_max;
+};
+
+struct sexp_stats {
+  struct sexp_stats_entry sexps[SEXP_CORE_TYPES_MAX+1];
+  struct sexp_stats_entry heaps;
+  struct sexp_stats_entry frees;
+  size_t sexp_count;
+};
+
+static void sexp_stats_entry_set(struct sexp_stats_entry *entry, size_t value) {
+  entry->count += 1;
+  entry->size_all += value;
+  if (entry->size_min == 0 || value < entry->size_min) entry->size_min = value;
+  if (value > entry->size_max) entry->size_max = value;
+}
+
+static sexp heap_stats_callback(sexp ctx, sexp_heap h, void *user) {
+  struct sexp_stats *stats = user;
+  sexp_stats_entry_set(&(stats->heaps), h->size);
+  return SEXP_TRUE;
+}
+
+static sexp free_stats_callback(sexp ctx, sexp_free_list f, void *user) {
+  struct sexp_stats *stats = user;
+  sexp_stats_entry_set(&(stats->frees), f->size);
+  return SEXP_TRUE;
+}
+
+static sexp sexp_stats_callback(sexp ctx, sexp s, void *user) {
+  struct sexp_stats *stats = user;
+  int tag = sexp_pointer_tag(s);
+  size_t size = sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx),
+                                        sexp_context_num_types(ctx), s);
+  if (tag > SEXP_CORE_TYPES_MAX) tag = SEXP_CORE_TYPES_MAX;
+  sexp_stats_entry_set(&(stats->sexps[tag]), size);
+  stats->sexp_count += 1;
+  return SEXP_TRUE;
+}
+
+void sexp_gc_heap_stats_print(sexp ctx)
+{
+  if (!ctx || !sexp_contextp(ctx)) return;
+  
+  struct sexp_stats stats;
+  memset(&stats, 0, sizeof(struct sexp_stats));
+  sexp_gc_heap_walk(ctx, sexp_context_heap(ctx), sexp_context_types(ctx), sexp_context_num_types(ctx),
+                    &stats, heap_stats_callback, free_stats_callback, sexp_stats_callback);
+  
+  printf("Heap Stats\n    %6zu %7zu\n",
+         stats.heaps.count, stats.heaps.size_all);
+  printf("Free Stats\n    %6zu %7zu %5zu %5zu\n",
+         stats.frees.count, stats.frees.size_all, stats.frees.size_min, stats.frees.size_max);
+  printf("Sexp Stats\n");
+  size_t total_count = 0;
+  size_t total_size = 0;
+  int i;
+  for (i = 0; i <= SEXP_CORE_TYPES_MAX; i++) {
+    if (stats.sexps[i].count == 0) continue;
+    printf("%3d %6zu %7zu %5zu %5zu\n", i,
+           stats.sexps[i].count, stats.sexps[i].size_all, stats.sexps[i].size_min, stats.sexps[i].size_max);
+    total_count += stats.sexps[i].count;
+    total_size  += stats.sexps[i].size_all;
+  }
+  printf(" ========================================\n");
+  printf("    %6zu %7zu\n", total_count, total_size);
+}
+#endif
+
+#endif  /* SEXP_USE_IMAGE_LOADING */

include/chibi/bignum.h

@@ -1,5 +1,5 @@
 /*  bignum.h -- header for bignum utilities                   */
-/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2020 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #ifndef SEXP_BIGNUM_H
@@ -7,7 +7,23 @@
 
 #include "chibi/eval.h"
 
-#if (SEXP_64_BIT) && defined(__GNUC__)
+#if SEXP_USE_CUSTOM_LONG_LONGS
+#ifdef PLAN9
+#include <ape/stdint.h>
+#else
+#include <stdint.h>
+#endif
+typedef struct
+{
+  uint64_t hi;
+  uint64_t lo;
+} sexp_luint_t;
+typedef struct
+{
+  int64_t  hi;
+  uint64_t lo;
+} sexp_lsint_t;
+#elif SEXP_64_BIT
 typedef unsigned int uint128_t __attribute__((mode(TI)));
 typedef int sint128_t __attribute__((mode(TI)));
 typedef uint128_t sexp_luint_t;
@@ -17,6 +33,364 @@ typedef unsigned long long sexp_luint_t;
 typedef long long sexp_lsint_t;
 #endif
 
+#if !SEXP_USE_CUSTOM_LONG_LONGS
+
+#define sexp_lsint_fits_sint(x) ((sexp_sint_t)x == x)
+#define sexp_luint_fits_uint(x) ((sexp_uint_t)x == x)
+#define lsint_from_sint(v) ((sexp_lsint_t)v)
+#define luint_from_uint(v) ((sexp_luint_t)v)
+#define lsint_to_sint(v) ((sexp_sint_t)v)
+#define luint_to_uint(v) ((sexp_uint_t)v)
+#define lsint_to_sint_hi(v) ((sexp_sint_t) ((v) >> (8*sizeof(sexp_sint_t))))
+#define luint_to_uint_hi(v) ((sexp_uint_t) ((v) >> (8*sizeof(sexp_uint_t))))
+#define lsint_negate(v) (-((sexp_lsint_t)v))
+#define luint_eq(a, b) (((sexp_luint_t)a)==((sexp_luint_t)b))
+#define luint_lt(a, b) (((sexp_luint_t)a)<((sexp_luint_t)b))
+#define lsint_lt_0(a) (((sexp_lsint_t)a)<0)
+#define luint_shl(a, shift) (((sexp_luint_t)a)<<(shift))
+#define luint_shr(a, shift) (((sexp_luint_t)a)>>(shift))
+#define luint_add(a, b) (((sexp_luint_t)a)+((sexp_luint_t)b))
+#define luint_add_uint(a, b) (((sexp_luint_t)a)+((sexp_uint_t)b))
+#define luint_sub(a, b) (((sexp_luint_t)a)-((sexp_luint_t)b))
+#define luint_mul_uint(a, b) (((sexp_luint_t)a)*((sexp_uint_t)b))
+#define lsint_mul_sint(a, b) (((sexp_lsint_t)a)*((sexp_sint_t)b))
+#define luint_div(a, b) (((sexp_luint_t)a)/((sexp_luint_t)b))
+#define luint_div_uint(a, b) (((sexp_luint_t)a)/((sexp_luint_t)b))
+#define luint_and(a, b) (((sexp_luint_t)a)&((sexp_luint_t)b))
+#define luint_is_fixnum(x) (((sexp_luint_t)x)<=SEXP_MAX_FIXNUM)
+#define lsint_is_fixnum(x) ((SEXP_MIN_FIXNUM <= ((sexp_lsint_t)x)) && (((sexp_lsint_t)x) <= SEXP_MAX_FIXNUM))
+
+#else
+
+static inline int lsint_lt_0(sexp_lsint_t a) {
+  return a.hi < 0;
+}
+
+static inline int sexp_lsint_fits_sint(sexp_lsint_t x) {
+  return x.hi == (((int64_t)x.lo)>>63) && ((sexp_sint_t)x.lo == x.lo);
+}
+static inline int sexp_luint_fits_uint(sexp_luint_t x) {
+  return x.hi == 0 && ((sexp_uint_t)x.lo == x.lo);
+}
+
+static inline sexp_luint_t luint_from_lsint(sexp_lsint_t v) {
+  sexp_luint_t result;
+  result.hi = v.hi;
+  result.lo = v.lo;
+  return result;
+}
+
+static inline sexp_lsint_t lsint_from_luint(sexp_luint_t v) {
+  sexp_lsint_t result;
+  result.hi = v.hi;
+  result.lo = v.lo;
+  return result;
+}
+
+static inline sexp_lsint_t lsint_from_sint(sexp_sint_t v) {
+  sexp_lsint_t result;
+  result.hi = v >> 63;
+  result.lo = v;
+  return result;
+}
+
+static inline sexp_luint_t luint_from_uint(sexp_uint_t v) {
+  sexp_luint_t result;
+  result.hi = 0;
+  result.lo = v;
+  return result;
+}
+
+static inline sexp_sint_t lsint_to_sint(sexp_lsint_t v) {
+  return v.lo;
+}
+
+static inline sexp_uint_t luint_to_uint(sexp_luint_t v) {
+  return v.lo;
+}
+
+static inline sexp_sint_t lsint_to_sint_hi(sexp_lsint_t v) {
+#if SEXP_64_BIT
+  return v.hi;
+#else
+  return v.lo >> 32;
+#endif
+}
+
+static inline sexp_uint_t luint_to_uint_hi(sexp_luint_t v) {
+#if SEXP_64_BIT
+  return v.hi;
+#else
+  return v.lo >> 32;
+#endif
+}
+
+static inline sexp_lsint_t lsint_negate(sexp_lsint_t v) {
+  sexp_luint_t a;
+  a.hi = ~v.hi;
+  a.lo = ~v.lo;
+
+  uint64_t aLoLo = a.lo & 0xFFFFFFFF;
+  uint64_t aLoHi = a.lo >> 32;
+  uint64_t aHiLo = a.hi & 0xFFFFFFFF;
+  uint64_t aHiHi = a.hi >> 32;
+
+  uint64_t carry;
+  uint64_t sumLoLo = aLoLo + 1;
+  carry = sumLoLo >> 32;
+  uint64_t resultLoLo = sumLoLo & 0xFFFFFFFF;
+
+  uint64_t sumLoHi = aLoHi + carry;
+  uint64_t resultLoHi = sumLoHi & 0xFFFFFFFF;
+  carry = sumLoHi >> 32;
+
+  uint64_t sumHiLo = aHiLo + carry;
+  uint64_t resultHiLo = sumHiLo & 0xFFFFFFFF;
+  carry = sumHiLo >> 32;
+
+  uint64_t sumHiHi = aHiHi + carry;
+  uint64_t resultHiHi = sumHiHi & 0xFFFFFFFF;
+  /* carry = sumHiHi >> 32; */
+
+  sexp_lsint_t result;
+  result.hi = (resultHiHi << 32) | resultHiLo;
+  result.lo = (resultLoHi << 32) | resultLoLo;
+  return result;
+}
+
+static inline int luint_eq(sexp_luint_t a, sexp_luint_t b) {
+  return (a.hi == b.hi) && (a.lo == b.lo);
+}
+
+static inline int luint_lt(sexp_luint_t a, sexp_luint_t b) {
+  if (a.hi < b.hi)
+    return 1;
+  else if (a.hi > b.hi)
+    return 0;
+  else
+    return a.lo < b.lo;
+}
+
+static inline sexp_luint_t luint_shl(sexp_luint_t v, size_t shift) {
+  if (shift == 0)
+    return v;
+  sexp_luint_t result;
+  if (shift >= 64) {
+    result.hi = v.lo << (shift - 64);
+    result.lo = 0;
+  } else {
+    result.hi = (v.hi << shift) | (v.lo >> (64-shift));
+    result.lo = v.lo << shift;
+  }
+  return result;
+}
+
+static inline sexp_luint_t luint_shr(sexp_luint_t v, size_t shift) {
+  if (shift == 0)
+    return v;
+  sexp_luint_t result;
+  if (shift >= 64) {
+    result.hi = 0;
+    result.lo = v.hi >> (shift - 64);
+  } else {
+    result.hi = v.hi >> shift;
+    result.lo = (v.lo >> shift) | (v.hi << (64-shift));
+  }
+  return result;
+}
+
+static inline sexp_luint_t luint_add(sexp_luint_t a, sexp_luint_t b) {
+  uint64_t aLoLo = a.lo & 0xFFFFFFFF;
+  uint64_t aLoHi = a.lo >> 32;
+  uint64_t aHiLo = a.hi & 0xFFFFFFFF;
+  uint64_t aHiHi = a.hi >> 32;
+  uint64_t bLoLo = b.lo & 0xFFFFFFFF;
+  uint64_t bLoHi = b.lo >> 32;
+  uint64_t bHiLo = b.hi & 0xFFFFFFFF;
+  uint64_t bHiHi = b.hi >> 32;
+
+  uint64_t carry;
+  uint64_t sumLoLo = (aLoLo + bLoLo);
+  carry = sumLoLo >> 32;
+  uint64_t resultLoLo = sumLoLo & 0xFFFFFFFF;
+
+  uint64_t sumLoHi = (aLoHi + bLoHi) + carry;
+  uint64_t resultLoHi = sumLoHi & 0xFFFFFFFF;
+  carry = sumLoHi >> 32;
+
+  uint64_t sumHiLo = (aHiLo + bHiLo) + carry;
+  uint64_t resultHiLo = sumHiLo & 0xFFFFFFFF;
+  carry = sumHiLo >> 32;
+
+  uint64_t sumHiHi = (aHiHi + bHiHi) + carry;
+  uint64_t resultHiHi = sumHiHi & 0xFFFFFFFF;
+  /* carry = sumHiHi >> 32; */
+
+  sexp_luint_t result;
+  result.hi = (resultHiHi << 32) | resultHiLo;
+  result.lo = (resultLoHi << 32) | resultLoLo;
+  return result;
+}
+
+static inline sexp_luint_t luint_add_uint(sexp_luint_t a, sexp_uint_t b) {
+  uint64_t aLoLo = a.lo & 0xFFFFFFFF;
+  uint64_t aLoHi = a.lo >> 32;
+  uint64_t aHiLo = a.hi & 0xFFFFFFFF;
+  uint64_t aHiHi = a.hi >> 32;
+  uint64_t bLoLo = b & 0xFFFFFFFF;
+  uint64_t bLoHi = b >> 32;
+
+  uint64_t carry;
+  uint64_t sumLoLo = (aLoLo + bLoLo);
+  carry = sumLoLo >> 32;
+  uint64_t resultLoLo = sumLoLo & 0xFFFFFFFF;
+
+  uint64_t sumLoHi = (aLoHi + bLoHi) + carry;
+  uint64_t resultLoHi = sumLoHi & 0xFFFFFFFF;
+  carry = sumLoHi >> 32;
+
+  uint64_t sumHiLo = aHiLo + carry;
+  uint64_t resultHiLo = sumHiLo & 0xFFFFFFFF;
+  carry = sumHiLo >> 32;
+
+  uint64_t sumHiHi = aHiHi + carry;
+  uint64_t resultHiHi = sumHiHi & 0xFFFFFFFF;
+  /* carry = sumHiHi >> 32; */
+
+  sexp_luint_t result;
+  result.hi = (resultHiHi << 32) | resultHiLo;
+  result.lo = (resultLoHi << 32) | resultLoLo;
+  return result;
+}
+
+static inline sexp_luint_t luint_sub(sexp_luint_t a, sexp_luint_t b) {
+  sexp_luint_t negB;
+  negB.hi = ~b.hi;
+  negB.lo = ~b.lo;
+  return luint_add(a, luint_add_uint(negB, 1));
+}
+
+static inline sexp_luint_t luint_mul_uint(sexp_luint_t a, sexp_uint_t b) {
+  uint64_t aLoLo = a.lo & 0xFFFFFFFF;
+  uint64_t aLoHi = a.lo >> 32;
+  uint64_t aHiLo = a.hi & 0xFFFFFFFF;
+  uint64_t aHiHi = a.hi >> 32;
+
+  uint64_t bLo = b & 0xFFFFFFFF;
+  uint64_t bHi = b >> 32;
+
+  sexp_luint_t resultBLo, resultBHi;
+  {
+    sexp_luint_t prodLoLo;
+    prodLoLo.hi = 0;
+    prodLoLo.lo = aLoLo * bLo;
+
+    sexp_luint_t prodLoHi;
+    prodLoHi.hi = (aLoHi * bLo) >> 32;
+    prodLoHi.lo = (aLoHi * bLo) << 32;
+
+    sexp_luint_t prodHiLo;
+    prodHiLo.hi = aHiLo * bLo;
+    prodHiLo.lo = 0;
+
+    sexp_luint_t prodHiHi;
+    prodHiHi.hi = (aHiHi * bLo) << 32;
+    prodHiHi.lo = 0;
+
+    resultBLo = luint_add(luint_add(luint_add(prodLoLo, prodLoHi), prodHiLo), prodHiHi);
+  }
+  {
+    sexp_luint_t prodLoLo;
+    prodLoLo.hi = 0;
+    prodLoLo.lo = aLoLo * bHi;
+
+    sexp_luint_t prodLoHi;
+    prodLoHi.hi = (aLoHi * bHi) >> 32;
+    prodLoHi.lo = (aLoHi * bHi) << 32;
+
+    sexp_luint_t prodHiLo;
+    prodHiLo.hi = aHiLo * bHi;
+    prodHiLo.lo = 0;
+
+    sexp_luint_t prodHiHi;
+    prodHiHi.hi = (aHiHi * bHi) << 32;
+    prodHiHi.lo = 0;
+
+    resultBHi = luint_add(luint_add(luint_add(prodLoLo, prodLoHi), prodHiLo), prodHiHi);
+  }
+
+  sexp_luint_t result = luint_add(resultBLo, luint_shl(resultBHi, 32));
+
+  return result;
+}
+
+static inline sexp_lsint_t lsint_mul_sint(sexp_lsint_t a, sexp_sint_t b) {
+  if (lsint_lt_0(a)) {
+    sexp_luint_t minusA = luint_from_lsint(lsint_negate(a));
+    if (b < 0)
+      return lsint_from_luint(luint_mul_uint(minusA, (sexp_uint_t)-b));
+    else
+      return lsint_negate(lsint_from_luint(luint_mul_uint(minusA, (sexp_uint_t)b)));
+  } else {
+    if (b < 0)
+      return lsint_negate(lsint_from_luint(luint_mul_uint(luint_from_lsint(a), (sexp_uint_t)-b)));
+    else
+      return lsint_from_luint(luint_mul_uint(luint_from_lsint(a), (sexp_uint_t)b));
+  }
+}
+
+static inline sexp_luint_t luint_div(sexp_luint_t a, sexp_luint_t b) {
+  if (luint_lt(a, b))
+    return luint_from_uint(0);
+  else if (luint_eq(a, b))
+    return luint_from_uint(1);
+
+  sexp_luint_t quotient = luint_from_uint(0);
+  sexp_luint_t remainder = luint_from_uint(0);
+
+  for (int i = 0; i < 128; i++) {
+    quotient = luint_shl(quotient, 1);
+
+    remainder = luint_shl(remainder, 1);
+    remainder.lo |= (a.hi >> 63) & 1;
+    a = luint_shl(a, 1);
+
+    if (!(luint_lt(remainder, b))) {
+      remainder = luint_sub(remainder, b);
+      quotient.lo |= 1;
+    }
+  }
+
+  return quotient;
+}
+
+static inline sexp_luint_t luint_div_uint(sexp_luint_t a, sexp_uint_t b) {
+  return luint_div(a, luint_from_uint(b));
+}
+
+static inline sexp_luint_t luint_and(sexp_luint_t a, sexp_luint_t b) {
+  sexp_luint_t result;
+  result.hi = a.hi & b.hi;
+  result.lo = a.lo & b.lo;
+  return result;
+}
+
+static inline int luint_is_fixnum(sexp_luint_t x) {
+  return (x.hi == 0) && (x.lo <= SEXP_MAX_FIXNUM);
+}
+
+static inline int lsint_is_fixnum(sexp_lsint_t x) {
+  if (x.hi > 0)
+      return 0;
+  else if (x.hi == 0)
+      return x.lo <= SEXP_MAX_FIXNUM;
+  else if (x.hi == -1)
+      return SEXP_MIN_FIXNUM <= x.lo;
+  else return 0;
+}
+
+#endif
+
 SEXP_API sexp_sint_t sexp_bignum_compare (sexp a, sexp b);
 SEXP_API sexp sexp_compare (sexp ctx, sexp a, sexp b);
 SEXP_API sexp sexp_make_bignum (sexp ctx, sexp_uint_t len);
@@ -26,7 +400,9 @@ SEXP_API sexp_uint_t sexp_bignum_hi (sexp a);
 SEXP_API sexp sexp_fixnum_to_bignum (sexp ctx, sexp a);
 SEXP_API double sexp_bignum_to_double (sexp a);
 SEXP_API sexp sexp_double_to_bignum (sexp ctx, double f);
+SEXP_API double sexp_to_double (sexp ctx, sexp x);
 SEXP_API sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b);
+SEXP_API sexp sexp_bignum_fxsub (sexp ctx, sexp a, sexp_uint_t b);
 SEXP_API sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset);
 SEXP_API sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset);
 SEXP_API sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b);
@@ -43,7 +419,8 @@ SEXP_API sexp sexp_quotient (sexp ctx, sexp a, sexp b);
 SEXP_API sexp sexp_remainder (sexp ctx, sexp a, sexp b);
 #if SEXP_USE_RATIOS
 SEXP_API sexp sexp_double_to_ratio (sexp ctx, double f);
-SEXP_API double sexp_ratio_to_double (sexp rat);
+SEXP_API sexp sexp_double_to_ratio_2 (sexp ctx, double f);
+SEXP_API double sexp_ratio_to_double (sexp ctx, sexp rat);
 SEXP_API sexp sexp_make_ratio (sexp ctx, sexp num, sexp den);
 SEXP_API sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in);
 SEXP_API sexp sexp_ratio_round (sexp ctx, sexp a);

include/chibi/eval.h

@@ -46,8 +46,6 @@ enum sexp_opcode_classes {
   SEXP_OPC_NUM_OP_CLASSES
 };
 
-SEXP_API struct sexp_opcode_struct* sexp_primitive_opcodes;
-
 #if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
 SEXP_API const char** sexp_opcode_names;
 #endif
@@ -76,7 +74,7 @@ SEXP_API void sexp_bless_bytecode (sexp ctx, sexp bc);
 #endif
 SEXP_API sexp sexp_complete_bytecode (sexp ctx);
 SEXP_API void sexp_shrink_bcode (sexp ctx, sexp_uint_t i);
-SEXP_API void sexp_expand_bcode (sexp ctx, sexp_uint_t size);
+SEXP_API void sexp_expand_bcode (sexp ctx, sexp_sint_t size);
 SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
 SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
 SEXP_API int sexp_param_index (sexp ctx, sexp lambda, sexp name);
@@ -94,6 +92,7 @@ SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n,
 SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value);
 SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close);
 SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
+SEXP_API char* sexp_find_module_file_raw (sexp ctx, const char *file);
 SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file);
 SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
 SEXP_API sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
@@ -129,13 +128,15 @@ SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from
 SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
 SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
 SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
-SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
 SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
 #if SEXP_USE_AUTO_FORCE
 SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
 #endif
 #if SEXP_USE_UTF8_STRINGS
 SEXP_API sexp sexp_read_utf8_char (sexp ctx, sexp port, int i);
+SEXP_API void sexp_push_utf8_char (sexp ctx, int i, sexp port);
 SEXP_API void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch);
 SEXP_API sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i);
 SEXP_API sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch);
@@ -189,10 +190,13 @@ SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
 SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
 #endif
 
-#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL)
-#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d)
+SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name, int num_args, const char *fname, sexp_proc1 f, const char *param);
 
-SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param);
+#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p)
+#define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p)
+#define sexp_define_foreign_proc(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_NONE,(const char*)#f,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_proc_rest(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_VARIADIC,(const char*)#f,(sexp_proc1)f,NULL)
 
 #define sexp_env_key(x) sexp_car(x)
 #define sexp_env_value(x) sexp_cdr(x)
@@ -236,6 +240,7 @@ SEXP_API sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sex
 SEXP_API sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req);
 #else
 SEXP_API sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_stream_portp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
 #endif
 
 #if SEXP_USE_SIMPLIFY

include/chibi/features.h

@@ -1,5 +1,5 @@
 /*  features.h -- general feature configuration               */
-/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2021 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 /* uncomment this to disable most features */
@@ -23,16 +23,27 @@
 /*   sexp_init_library(ctx, env) function provided. */
 /* #define SEXP_USE_DL 0 */
 
-/* uncomment this to statically compile all C libs */
-/*   If set, this will statically include the clibs.c file */
-/*   into the standard environment, so that you can have */
-/*   access to a predefined set of C libraries without */
-/*   needing dynamic loading.  The clibs.c file is generated */
-/*   automatically by searching the lib directory for */
-/*   modules with include-shared, but can be hand-tailored */
-/*   to your needs. */
+/* uncomment this to support statically compiled C libs */
+/*   Unless SEXP_USE_STATIC_LIBS_EMPTY is set (see below), this */
+/*   will statically include the clibs.c file into the standard */
+/*   environment, so that you can have access to a predefined set */
+/*   of C libraries without needing dynamic loading.  The clibs.c */
+/*   file is generated automatically by searching the lib directory */
+/*   for modules with include-shared, but can be hand-tailored to */
+/*   your needs.  You can also register your own C libraries using */
+/*   sexp_add_static_libraries (see below). */
 /* #define SEXP_USE_STATIC_LIBS 1 */
 
+/* uncomment this to enable user exported C libs */
+/*   You can register your own C libraries using */
+/*   sexp_add_static_libraries.  Each entry in the supplied table, */
+/*   is a name/entry point pair.  These work as if they were */
+/*   dynamically loaded libraries, so naming follows the same */
+/*   conventions.  An entry {"foo", init_foo} will register a */
+/*   library that can be loaded with (load "foo"), or */
+/*   (include-shared "foo"), both of which will call init_foo. */
+/* #define SEXP_USE_STATIC_LIBS_EMPTY 1 */
+
 /* uncomment this to disable detailed source info for debugging */
 /*   By default Chibi will associate source info with every */
 /*   bytecode offset.  By disabling this only lambda-level source */
@@ -64,6 +75,15 @@
 /*   if you suspect a bug in the native GC. */
 /* #define SEXP_USE_BOEHM 1 */
 
+/* uncomment this to enable automatic file descriptor unification */
+/*   File descriptors as returned by C functions are raw integers, */
+/*   which are convereted to GC'ed first-class objects on the Scheme */
+/*   side.  By default we assume that each fd is new, however if this */
+/*   option is enabled and an fd is returned which matches an existing */
+/*   open fd, they are assumed to refer to the same descriptor and */
+/*   unified. */
+/* #define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 1 */
+
 /* uncomment this to disable weak references */
 /* #define SEXP_USE_WEAK_REFERENCES 0 */
 
@@ -84,6 +104,11 @@
 /*   go away and you're not working on your own C extension. */
 /* #define SEXP_USE_CONSERVATIVE_GC 1 */
 
+/* uncomment this to disable automatic running of finalizers */
+/*   You will need to close ports and file descriptors manually */
+/*   (as you should anyway) and some C extensions may break. */
+/* #define SEXP_USE_FINALIZERS 0 */
+
 /* uncomment this to add additional native checks to only mark objects in the heap */
 /* #define SEXP_USE_SAFE_GC_MARK 1 */
 
@@ -100,6 +125,9 @@
 /* uncomment this to add very verbose debugging stats to the native GC */
 /* #define SEXP_USE_DEBUG_GC 1 */
 
+/* uncomment this to add instrumentation to the native GC */
+/* #define SEXP_USE_TIME_GC 1 */
+
 /* uncomment this to enable "safe" field accessors for primitive types */
 /*   The sexp union type fields are abstracted away with macros of the */
 /*   form sexp_<type>_<field>(<obj>), however these are just convenience */
@@ -160,11 +188,27 @@
 /* uncomment this if you don't want 1## style approximate digits */
 /* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */
 
+/* uncomment this to disable a workaround for numeric formatting, */
+/* to fix numbers in locales which don't use the '.' decimal sep */
+/* #define SEXP_USE_PATCH_NON_DECIMAL_NUMERIC_FORMATS 0 */
+
 /* uncomment this if you don't need extended math operations */
 /*   This includes the trigonometric and expt functions. */
 /*   Automatically disabled if you've disabled flonums. */
 /* #define SEXP_USE_MATH 0 */
 
+/* uncomment this to enable lenient matching of top-level bindings */
+/*   Historically, to match behavior with some other Schemes and in */
+/*   hopes of making it easier to use macros and modules, Chibi allowed */
+/*   top-level bindings with the same underlying symbol name to match */
+/*   with identifier=?.  In particular, there still isn't a good way */
+/*   to handle the case where auxiliary syntax conflicts with some other */
+/*   binding without renaming one or the other (though SRFI 206 helps). */
+/*   However, if people make use of this you can write Chibi programs */
+/*   which don't work portably in other implementations, which has been */
+/*   a source of confusion, so the default has reverted to strict R7RS. */
+/* #define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0 */
+
 /* uncomment this to disable warning about references to undefined variables */
 /*   This is something of a hack, but can be quite useful. */
 /*   It's very fast and doesn't involve any separate analysis */
@@ -187,6 +231,11 @@
 /* uncomment this to disable extended char names as defined in R7RS */
 /* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */
 
+/* uncomment this to disable R7RS #<n>= and #<n># reader labels in source */
+/*   The (scheme read) and (scheme write) libraries always support */
+/*   this regardless. */
+/* #define SEXP_USE_READER_LABELS 0 */
+
 /* uncomment this to disable UTF-8 string support */
 /*   The default settings store strings in memory as UTF-8, */
 /*   and assumes strings passed to/from the C FFI are UTF-8.  */
@@ -197,10 +246,32 @@
 /*   Making them immutable allows for packed UTF-8 strings. */
 /* #define SEXP_USE_MUTABLE_STRINGS 0 */
 
-/* uncomment this to base string ports on C streams */
-/*   This historic option enables string and custom ports backed */
-/*   by FILE* objects using memstreams and funopen/fopencookie. */
-/* #define SEXP_USE_STRING_STREAMS 1 */
+/* uncomment this to enable precomputed index->cursor tables for strings */
+/*   This makes string-ref faster at the expensive of making string */
+/*   construction (including string-append and I/O) slower. */
+/*   You can configure with SEXP_STRING_INDEX_TABLE_CHUNK_SIZE below, */
+/*   the default is caching every 64th index (<=12.5% string overhead). */
+/*   With a minimum of 1 you'd have up to 8x string overhead, and */
+/*   string-ref would still be slightly slower than string-cursors, */
+/*   and string-append would be marginally slower as well.          */
+/*                                                                  */
+/*   In practice, the overhead of iterating over a string with      */
+/*   string-ref isn't noticeable until about 10k chars.  Times      */
+/*   for iteration using the different approaches:                  */
+/*                                                                  */
+/*   impl\len               1000   10000  100000  1000000           */
+/*   string-ref (utf8)         1      97    9622        x           */
+/*   string-ref (fast)         0       2      19      216           */
+/*   cursor-ref (srfi 130)     0       4      18      150           */
+/*   text-ref (srfi 135)       2      27     211     2006           */
+/*                                                                  */
+/* #define SEXP_USE_STRING_INDEX_TABLE 1 */
+
+/* uncomment this to cache a string cursor for string-ref calls */
+/*   The default is not to use a cache. The goal of caching is to   */
+/*   soften the performance impact of repeated O(n) string-ref      */
+/*   operations on the same string. */
+/* #define SEXP_USE_STRING_REF_CACHE 1 */
 
 /* uncomment this to disable automatic closing of ports */
 /*   If enabled, the underlying FILE* for file ports will be */
@@ -230,7 +301,7 @@
 
 /* uncomment this to make the VM adhere to alignment rules */
 /*   This is required on some platforms, e.g. ARM */
-/* #define SEXP_USE_ALIGNED_BYTECODE */
+/* #define SEXP_USE_ALIGNED_BYTECODE 1 */
 
 /************************************************************************/
 /* These settings are configurable but only recommended for */
@@ -256,6 +327,15 @@
 #define SEXP_GROW_HEAP_RATIO 0.75
 #endif
 
+/* how much to expand the heap size by */
+#ifndef SEXP_GROW_HEAP_FACTOR
+#define SEXP_GROW_HEAP_FACTOR 2  /* 1.6180339887498948482 */
+#endif
+
+/* size of per-context stack that is used during gc cycles
+ * increase if you can affort extra unused memory */
+#define SEXP_MARK_STACK_COUNT 1024
+
 /* the default number of opcodes to run each thread for */
 #ifndef SEXP_DEFAULT_QUANTUM
 #define SEXP_DEFAULT_QUANTUM 500
@@ -265,12 +345,21 @@
 #define SEXP_MAX_ANALYZE_DEPTH 8192
 #endif
 
+/* The size of flexible arrays (empty arrays at the end of a struct */
+/* representing the trailing data), when compiled with C++.  Technically */
+/* 0 is an illegal value here, and the C++ idiom is to use 1, but this */
+/* breaks compatibility with C when computing the size of structs, and */
+/* in practice all of the major C++ compilers support 0. */
+#ifndef SEXP_FLEXIBLE_ARRAY_SIZE
+#define SEXP_FLEXIBLE_ARRAY_SIZE 0
+#endif
+
 /************************************************************************/
 /*         DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE            */
 /************************************************************************/
 
 #ifndef SEXP_64_BIT
-#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__)
+#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) || defined(__mips64__) || defined(__sparc64__) || defined(__arm64)
 #define SEXP_64_BIT 1
 #else
 #define SEXP_64_BIT 0
@@ -286,6 +375,51 @@
 #endif
 #endif
 
+/* Detect specific BSD */
+#if SEXP_BSD
+#if defined(__APPLE__)
+#define SEXP_DARWIN 1
+#define SEXP_FREEBSD 0
+#define SEXP_NETBSD 0
+#define SEXP_DRAGONFLY 0
+#define SEXP_OPENBSD 0
+#elif defined(__FreeBSD__)
+#define SEXP_DARWIN 0
+#define SEXP_FREEBSD 1
+#define SEXP_NETBSD 0
+#define SEXP_DRAGONFLY 0
+#define SEXP_OPENBSD 0
+#elif defined(__NetBSD__)
+#define SEXP_DARWIN 0
+#define SEXP_FREEBSD 0
+#define SEXP_NETBSD 1
+#define SEXP_DRAGONFLY 0
+#define SEXP_OPENBSD 0
+#elif defined(__DragonFly__)
+#define SEXP_DARWIN 0
+#define SEXP_FREEBSD 0
+#define SEXP_NETBSD 0
+#define SEXP_DRAGONFLY 1
+#define SEXP_OPENBSD 0
+#elif defined(__OpenBSD__)
+#define SEXP_DARWIN 0
+#define SEXP_FREEBSD 0
+#define SEXP_NETBSD 0
+#define SEXP_DRAGONFLY 0
+#define SEXP_OPENBSD 1
+#endif
+#endif
+
+/* for bignum support, need a double long to store long*long */
+/* gcc supports uint128_t, otherwise we need a custom struct */
+#ifndef SEXP_USE_CUSTOM_LONG_LONGS
+#if SEXP_64_BIT && !defined(__GNUC__)
+#define SEXP_USE_CUSTOM_LONG_LONGS 1
+#else
+#define SEXP_USE_CUSTOM_LONG_LONGS 0
+#endif
+#endif
+
 #ifndef SEXP_USE_NO_FEATURES
 #define SEXP_USE_NO_FEATURES 0
 #endif
@@ -294,9 +428,19 @@
 #define SEXP_USE_PEDANTIC 0
 #endif
 
+/* this ensures public structs and enums are unchanged by feature toggles. */
+/* should generally be left at 1. */
+#ifndef SEXP_USE_STABLE_ABI
+#define SEXP_USE_STABLE_ABI 1
+#endif
+
 #ifndef SEXP_USE_GREEN_THREADS
+#if defined(_WIN32)
+#define SEXP_USE_GREEN_THREADS 0
+#else
 #define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES
 #endif
+#endif
 
 #ifndef SEXP_USE_DEBUG_THREADS
 #define SEXP_USE_DEBUG_THREADS 0
@@ -327,20 +471,28 @@
 #endif
 
 #ifndef SEXP_USE_DL
-#if defined(PLAN9) || defined(_WIN32)
+#if defined(PLAN9)
 #define SEXP_USE_DL 0
 #else
 #define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
 #endif
 #endif
 
+#ifndef SEXP_USE_STATIC_LIBS_EMPTY
+#define SEXP_USE_STATIC_LIBS_EMPTY 0
+#endif
+
 #ifndef SEXP_USE_STATIC_LIBS
-#define SEXP_USE_STATIC_LIBS 0
+#define SEXP_USE_STATIC_LIBS SEXP_USE_STATIC_LIBS_EMPTY
 #endif
 
 /* don't include clibs.c - include separately or link */
 #ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
-#define SEXP_USE_STATIC_LIBS_NO_INCLUDE defined(PLAN9)
+#if defined(PLAN9) || SEXP_USE_STATIC_LIBS_EMPTY
+#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 0
+#else
+#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 1
+#endif
 #endif
 
 #ifndef SEXP_USE_FULL_SOURCE_INFO
@@ -355,9 +507,17 @@
 #define SEXP_USE_BOEHM 0
 #endif
 
+#ifdef SEXP_USE_UNIFY_FILENOS_BY_NUMBER
+#define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 0
+#endif
+
 #ifndef SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_UNIFY_FILENOS_BY_NUMBER
+#define SEXP_USE_WEAK_REFERENCES 1
+#else
 #define SEXP_USE_WEAK_REFERENCES ! SEXP_USE_NO_FEATURES
 #endif
+#endif
 
 #ifndef SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
 #define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 0
@@ -379,6 +539,14 @@
 #define SEXP_USE_DEBUG_GC 0
 #endif
 
+#ifndef SEXP_USE_TIME_GC
+#if SEXP_USE_DEBUG_GC > 0 || defined(__linux) || SEXP_BSD
+#define SEXP_USE_TIME_GC 1
+#else
+#define SEXP_USE_TIME_GC 0
+#endif
+#endif
+
 #ifndef SEXP_USE_SAFE_GC_MARK
 #define SEXP_USE_SAFE_GC_MARK SEXP_USE_DEBUG_GC > 1
 #endif
@@ -387,6 +555,10 @@
 #define SEXP_USE_CONSERVATIVE_GC 0
 #endif
 
+#ifndef SEXP_USE_FINALIZERS
+#define SEXP_USE_FINALIZERS 1
+#endif
+
 #ifndef SEXP_USE_TRACK_ALLOC_SOURCE
 #define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
 #endif
@@ -395,6 +567,18 @@
 #define SEXP_USE_TRACK_ALLOC_BACKTRACE SEXP_USE_TRACK_ALLOC_SOURCE
 #endif
 
+#ifndef SEXP_USE_TRACK_ALLOC_TIMES
+#define SEXP_USE_TRACK_ALLOC_TIMES 0
+#endif
+
+#ifndef SEXP_USE_TRACK_ALLOC_SIZES
+#define SEXP_USE_TRACK_ALLOC_SIZES 0
+#endif
+
+#ifndef SEXP_ALLOC_HISTOGRAM_BUCKETS
+#define SEXP_ALLOC_HISTOGRAM_BUCKETS 32
+#endif
+
 #ifndef SEXP_BACKTRACE_SIZE
 #define SEXP_BACKTRACE_SIZE 3
 #endif
@@ -432,7 +616,7 @@
 #endif
 
 #ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
-#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
+#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 1
 #endif
 
 #if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
@@ -506,6 +690,10 @@
 #define SEXP_PLACEHOLDER_DIGIT '#'
 #endif
 
+#ifndef SEXP_USE_PATCH_NON_DECIMAL_NUMERIC_FORMATS
+#define SEXP_USE_PATCH_NON_DECIMAL_NUMERIC_FORMATS 1
+#endif
+
 #ifndef SEXP_USE_MATH
 #define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES
 #endif
@@ -522,15 +710,27 @@
 #define SEXP_USE_OBJECT_BRACE_LITERALS (SEXP_USE_TYPE_DEFS && !SEXP_USE_NO_FEATURES)
 #endif
 
-/* Dangerous without shared object detection. */
 #ifndef SEXP_USE_TYPE_PRINTERS
-#define SEXP_USE_TYPE_PRINTERS 0
+#define SEXP_USE_TYPE_PRINTERS SEXP_USE_OBJECT_BRACE_LITERALS
+#endif
+
+#ifndef SEXP_USE_UNIFORM_VECTOR_LITERALS
+#define SEXP_USE_UNIFORM_VECTOR_LITERALS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
+#define SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS ! SEXP_USE_NO_FEATURES
 #endif
 
 #ifndef SEXP_USE_BYTEVECTOR_LITERALS
-#define SEXP_USE_BYTEVECTOR_LITERALS ! SEXP_USE_NO_FEATURES
+#define SEXP_USE_BYTEVECTOR_LITERALS SEXP_USE_UNIFORM_VECTOR_LITERALS
 #endif
 
+#ifndef SEXP_BYTEVECTOR_HEX_LITERALS
+#define SEXP_BYTEVECTOR_HEX_LITERALS SEXP_USE_BYTEVECTOR_LITERALS
+#endif
+
+
 #ifndef SEXP_USE_SELF_PARAMETER
 #define SEXP_USE_SELF_PARAMETER 1
 #endif
@@ -583,6 +783,10 @@
 #define SEXP_USE_EXTENDED_CHAR_NAMES ! SEXP_USE_NO_FEATURES
 #endif
 
+#ifndef SEXP_USE_READER_LABELS
+#define SEXP_USE_READER_LABELS ! SEXP_USE_NO_FEATURES
+#endif
+
 #ifndef SEXP_USE_UTF8_STRINGS
 #define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES
 #endif
@@ -598,8 +802,20 @@
 #define SEXP_USE_PACKED_STRINGS 1
 #endif
 
-#ifndef SEXP_USE_STRING_STREAMS
-#define SEXP_USE_STRING_STREAMS 0
+#if SEXP_USE_PACKED_STRINGS
+#define SEXP_USE_STRING_INDEX_TABLE 0
+#endif
+#ifndef SEXP_USE_STRING_INDEX_TABLE
+#define SEXP_USE_STRING_INDEX_TABLE 0
+#endif
+
+/* for every chunk_size indexes store the precomputed offset */
+#ifndef SEXP_STRING_INDEX_TABLE_CHUNK_SIZE
+#define SEXP_STRING_INDEX_TABLE_CHUNK_SIZE 64
+#endif
+
+#ifndef SEXP_USE_DISJOINT_STRING_CURSORS
+#define SEXP_USE_DISJOINT_STRING_CURSORS SEXP_USE_UTF8_STRINGS
 #endif
 
 #ifndef SEXP_USE_AUTOCLOSE_PORTS
@@ -607,7 +823,11 @@
 #endif
 
 #ifndef SEXP_USE_GC_FILE_DESCRIPTORS
-#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM && !defined(PLAN9))
+#ifdef PLAN9
+#define SEXP_USE_GC_FILE_DESCRIPTORS 0
+#else
+#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM)
+#endif
 #endif
 
 #ifndef SEXP_USE_BIDIRECTIONAL_PORTS
@@ -660,6 +880,10 @@
 #define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000
 #endif
 
+#ifndef SEXP_MAX_VECTOR_LENGTH
+#define SEXP_MAX_VECTOR_LENGTH (SEXP_MAX_FIXNUM >> 1)
+#endif
+
 #ifndef SEXP_DEFAULT_EQUAL_DEPTH
 #define SEXP_DEFAULT_EQUAL_DEPTH 10000
 #endif
@@ -668,8 +892,21 @@
 #define SEXP_DEFAULT_EQUAL_BOUND 100000000
 #endif
 
+#ifndef SEXP_DEFAULT_WRITE_BOUND
+#define SEXP_DEFAULT_WRITE_BOUND 10000
+#endif
+
+#ifndef SEXP_STRIP_SYNCLOS_BOUND
+#define SEXP_STRIP_SYNCLOS_BOUND 10000
+#endif
+
+#ifndef SEXP_POLL_SLEEP_TIME
+#define SEXP_POLL_SLEEP_TIME 5000
+#define SEXP_POLL_SLEEP_TIME_MS 5
+#endif
+
 #ifndef SEXP_USE_IMAGE_LOADING
-#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
+#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && SEXP_64_BIT && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
 #endif
 
 #ifndef SEXP_USE_UNSAFE_PUSH
@@ -707,13 +944,17 @@
 #endif
 
 #ifndef SEXP_USE_ALIGNED_BYTECODE
-#if defined(__arm__)
+#if defined(__arm__) || defined(__sparc__) || defined(__sparc64__) || defined(__mips__) || defined(__mips64__)
 #define SEXP_USE_ALIGNED_BYTECODE 1
 #else
 #define SEXP_USE_ALIGNED_BYTECODE 0
 #endif
 #endif
 
+#ifndef SEXP_USE_SIGNED_SHIFTS
+#define SEXP_USE_SIGNED_SHIFTS 0
+#endif
+
 #ifdef PLAN9
 #define strcasecmp cistrcmp
 #define strncasecmp cistrncmp
@@ -723,6 +964,17 @@
 #define isinf(x) (isInf(x,1) || isInf(x,-1))
 #define isnan(x) isNaN(x)
 #elif defined(_WIN32)
+#define SHUT_RD 0 /* SD_RECEIVE */
+#define SHUT_WR 1 /* SD_SEND */
+#define SHUT_RDWR 2 /* SD_BOTH */
+#ifdef _MSC_VER
+#define _CRT_SECURE_NO_WARNINGS 1
+#define _CRT_NONSTDC_NO_DEPRECATE 1
+#define _USE_MATH_DEFINES /* For M_LN10 */
+#define strcasecmp _stricmp
+#define strncasecmp _strnicmp
+#pragma warning(disable:4146) /* unary minus operator to unsigned type */
+#if _MSC_VER < 1900
 #define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val)
 #define strcasecmp lstrcmpi
 #define strncasecmp(s1, s2, n) lstrcmpi(s1, s2)
@@ -731,6 +983,10 @@
 #define isnan(x) (x!=x)
 #define isinf(x) (x > DBL_MAX || x < -DBL_MAX)
 #endif
+#elif !defined(__MINGW32__)
+#error Unknown Win32 compiler!
+#endif
+#endif
 
 #ifdef _WIN32
 #define sexp_pos_infinity (DBL_MAX*DBL_MAX)
@@ -746,12 +1002,16 @@
 #define sexp_nan (0.0/0.0)
 #endif
 
-#ifdef __MINGW32__
+#ifdef _WIN32
+#ifdef SEXP_STATIC_LIBRARY
+#define SEXP_API    extern
+#else
 #ifdef BUILDING_DLL
 #define SEXP_API    __declspec(dllexport)
 #else
 #define SEXP_API    __declspec(dllimport)
 #endif
+#endif
 #else
 #define SEXP_API    extern
 #endif

include/chibi/gc_heap.h

@@ -0,0 +1,105 @@
+/* gc_heap.h -- heap packing, run-time image generation    */
+/* Copyright (c) 2016 Chris Walsh.  All rights reserved.   */
+/* BSD-style license: http://synthcode.com/license.txt     */
+
+#ifndef SEXP_GC_HEAP_H
+#define SEXP_GC_HEAP_H
+
+#include "chibi/sexp.h"
+
+#if SEXP_USE_IMAGE_LOADING
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Iterate the heap associated with the context argument 'ctx',
+   calling user provided callbacks for the individual heap elements.
+   
+   For each heap found, heap_callback is called.
+   For each free segment found, free_callback is called.
+   For each valid sexp found, sexp_callback is called.
+     
+   Callbacks are skipped if the associated function
+   pointer argument is NULL.
+
+   A callback return value of SEXP_TRUE allows the heap walk to 
+   continue normally.  Any other value terminates the heap walk
+   with the callback result being returned.
+ 
+   The sexp_gc_heap_walk return value of SEXP_TRUE indicates all
+   elements of the heap were walked normally.  Any other return 
+   value indicates an abnormal return condition.
+*/
+SEXP_API sexp sexp_gc_heap_walk(
+  sexp ctx,         /* a possibly incomplete context */
+  sexp_heap h,      /* normally set to sexp_context_heap(ctx) */
+  sexp *types,      /* normally set to sexp_context_types(ctx) */
+  size_t types_cnt, /* normally set to sexp_context_num_types(ctx) */
+  void *user,   /* arbitrary data passed to callbacks */
+  sexp (*heap_callback)(sexp ctx, sexp_heap h, void *user),
+  sexp (*free_callback)(sexp ctx, sexp_free_list f, void *user),
+  sexp (*sexp_callback)(sexp ctx, sexp s, void *user));
+
+
+/* Returns a new context which contains a single, packed heap.
+   
+   The original ctx or heap are not altered, leaving two copies
+   of all sexps.  For runtime use where you are packing the heap
+   to make accesses more efficient, the old heap and context should
+   be discarded after a sucessful call to heap pack; finalizers do
+   not need to be called since all active objects are in the new heap.
+ 
+   The input heap_size specifies the amount of free space to allocate
+   at the end of the packed heap.  A heap_size of zero will produce a
+   single packed heap just large enough to hold all sexps from the
+   original heap.
+*/
+SEXP_API sexp sexp_gc_heap_pack(sexp ctx, sexp_uint_t heap_free_size);
+
+
+/* Creates a new packed heap from the provided context, and saves
+   the contents of the packed heap to the file named filename.
+
+   If sucessful, SEXP_TRUE is returned.  If a problem was encountered
+   in either creating the packed heap or saving to a file, then either
+   SEXP_FALSE or an exception is returned.  Because of shared code with
+   sexp_load_image, sexp_load_image_err() can also be used to return the
+   error condition.
+
+   In all cases, upon completion the temporary packed context is deleted 
+   and the context provided as an argument is not changed.
+*/
+SEXP_API sexp sexp_save_image (sexp ctx, const char* filename);
+
+
+/* Loads a previously saved image, and returns the context associated with
+   that image.  If the context could not be loaded, either NULL or an exception
+   are returned instead.
+
+   A new context is created with the contents of filename loaded into the
+   heap.  The heap_free_size parameter specifies the size of the heap to be
+   created in addition to the heap image on disk.  A size of zero will
+   result in an initial heap exactly the size of the disk image which will
+   be expanded with an additional heap when the system requests storage space.
+ 
+   The return value is either the context of the loaded image, or NULL.  In
+   the case of a NULL context, the function sexp_load_image_err() can be called
+   to provide a description of the error encountered.  An sexp exception cannot be
+   returned because there is not a valid context in which to put the exception.
+*/
+SEXP_API sexp sexp_load_image (const char* filename, off_t offset, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size);
+
+
+/* In the case that sexp_load_image() returns NULL, this function will return
+   a string containing a description of the error condition.
+*/
+SEXP_API char* sexp_load_image_err();
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif  /* SEXP_USE_IMAGE_LOADING */
+
+#endif  /* ! SEXP_GC_HEAP_H */

include/chibi/install.h.in

@@ -0,0 +1,6 @@
+#define sexp_so_extension "@CMAKE_SHARED_LIBRARY_SUFFIX@"
+#define sexp_default_module_path "@default_module_path@"
+#define sexp_platform "@platform@"
+#define sexp_architecture "@CMAKE_SYSTEM_PROCESSOR@"
+#define sexp_version "@CMAKE_PROJECT_VERSION@"
+#define sexp_release_name "@release@"

include/chibi/sexp-huff.h

@@ -1,3 +1,4 @@
+static struct sexp_huff_entry huff_table[] = {
  {12, 0x0C00},   /* '\x00' */
  {15, 0x0000},   /* '\x01' */
  {15, 0x4000},   /* '\x02' */
@@ -125,4 +126,5 @@
  {14, 0x0E00},   /* '|'   */
  {14, 0x2E00},   /* '}'   */
  {14, 0x1E00},   /* '~'   */
- {14, 0x3E00},   /* '\x7f' */
+ {14, 0x3E00}    /* '\x7f' */
+};

include/chibi/sexp-hufftabdefs.h

@@ -1,5 +1,5 @@
 
-char _huff_tab1[8], _huff_tab2[8], _huff_tab3[2], _huff_tab4[2],
+extern char _huff_tab1[8], _huff_tab2[8], _huff_tab3[2], _huff_tab4[2],
   _huff_tab5[4], _huff_tab6[2], _huff_tab7[4], _huff_tab8[4],
   _huff_tab9[4], _huff_tab10[4], _huff_tab11[4], _huff_tab12[2],
   _huff_tab13[8], _huff_tab14[2], _huff_tab15[8], _huff_tab16[8],

js/exported_functions.json

@@ -0,0 +1,4 @@
+[
+    "_main",
+    "_sexp_resume"
+]

js/index.html

@@ -0,0 +1,116 @@
+<!DOCTYPE html>
+<html lang="en">
+  <head>
+    <meta charset="utf-8">
+    <title>Chibi-Scheme</title>
+    <style>
+      body {
+        font-family: sans-serif;
+        height: 100vh;
+        margin: 0;
+        padding: 0;
+        display: flex;
+        flex-direction: column;
+      }
+      main {
+        flex: 1;
+        display: flex;
+        flex-direction: column;
+      }
+      #program {
+        flex: 1 1 0;
+        padding: 0.5em;
+      }
+      #start {
+        font-size: inherit;
+        padding: 0.5em;
+      }
+      #output {
+        font-family: monospace;
+        padding: 0.5em;
+        white-space: pre;
+        background-color: #000;
+        color: #fff;
+        overflow: auto;
+        flex: 1 1 0;
+      }
+    </style>
+  </head>
+  <body>
+    <main>
+      <textarea id="program" spellcheck="false">;
+; This is Chibi-Scheme compiled with Emscripten to run in the browser.
+;
+
+(import (scheme base))
+(write-string "Hello, world!\n")
+
+;
+; You can also run arbitrary JavaScript code from scheme and yield control back and forth between Scheme and the browser
+;
+
+(import (chibi emscripten)) ; exports: eval-script!, integer-eval-script, string-eval-script, wait-on-event!
+
+(write-string (number->string (integer-eval-script "6 * 7")))
+(newline)
+
+(eval-script! "window.addEventListener('click', function () {
+  Module['resume'](); // give control back to the Scheme process
+})")
+
+(let loop ()
+  (wait-on-event!) ; yields control back to the browser
+  (write-string "You have clicked me!\n")
+  (loop))
+
+(write-string "Control never reaches this point\n")
+</textarea>
+      <button type="button" id="start" disabled>Start Program</button>
+      <div id="output"></div>
+    </main>
+    <script src="chibi.js"></script>
+    <script>
+      function start(program, args, onOutput, onError) {
+        var firstError = true;
+        Chibi({
+          print: onOutput,
+          printErr: function (text) {
+            if (firstError) {
+              firstError = false;
+              return;
+            }
+            if (onError !== undefined) {
+              onError(text);
+            } else {
+              onOutput(text);
+            }
+          },
+          program: program,
+          arguments: args
+        });
+      }
+    </script>
+    <script>
+      (function () {
+        var programField = document.querySelector('#program');
+        var startButton = document.querySelector('#start');
+        var program = sessionStorage.getItem('program');
+        if (program) {
+          programField.value = program;
+        }
+        programField.addEventListener('input', function() {
+          sessionStorage.setItem('program', programField.value);
+        });
+        startButton.addEventListener('click', function() {
+          var program = programField.value;
+          startButton.disabled = true;
+          start(program, [],
+              function(text) {
+                output.textContent = output.textContent + text + '\n'
+              });
+        });
+        startButton.disabled = false;
+      })();
+    </script>
+  </body>
+</html>

js/post.js

@@ -0,0 +1,2 @@
+Module['resume'] = Module.cwrap('sexp_resume', 'void', []);
+

js/pre.js

@@ -0,0 +1,6 @@
+Module['preRun'].push(function () {
+  FS.writeFile('program.scm', Module['program']);
+});
+Module['arguments'] = Module['arguments'] || [];
+Module['arguments'].unshift('program.scm');
+

lib/chibi/accept.c

@@ -92,19 +92,19 @@ sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
 /* Additional utilities. */
 
 sexp sexp_sockaddr_name (sexp ctx, sexp self, struct sockaddr* addr) {
-  char buf[24];
+  char buf[INET6_ADDRSTRLEN];
   /* struct sockaddr_in *sa = (struct sockaddr_in *)addr; */
   /* unsigned char *ptr = (unsigned char *)&(sa->sin_addr); */
-  /* sprintf(buf, "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
+  /* snprintf(buf, sizeof(buf), "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
   inet_ntop(addr->sa_family,
             (addr->sa_family == AF_INET6 ?
              (void*)(&(((struct sockaddr_in6 *)addr)->sin6_addr)) :
              (void*)(&(((struct sockaddr_in *)addr)->sin_addr))),
-            buf, 24);
+            buf, INET6_ADDRSTRLEN);
   return sexp_c_string(ctx, buf, -1);
 }
 
 int sexp_sockaddr_port (sexp ctx, sexp self, struct sockaddr* addr) {
   struct sockaddr_in *sa = (struct sockaddr_in *)addr;
-  return sa->sin_port;
+  return ntohs(sa->sin_port);
 }

lib/chibi/app-test.sld

@@ -0,0 +1,49 @@
+(define-library (chibi app-test)
+  (import (scheme base) (chibi app) (chibi config) (chibi test))
+  (export run-tests)
+  (begin
+    (define (feed cfg spec . args)
+      (let ((animals (conf-get-list cfg 'animals '())))
+        (cons (if (conf-get cfg 'lions) (cons 'lions animals) animals) args)))
+    (define (wash cfg spec . args)
+      (let ((animals (conf-get-list cfg 'animals '())))
+        (cons (cons 'soap (conf-get cfg '(command wash soap))) animals)))
+    (define zoo-app-spec
+      `(zoo
+        "Zookeeper Application"
+        (@
+         (animals (list symbol) "list of animals to act on (default all)")
+         (lions boolean (#\l) "also apply the action to lions"))
+        (or
+         (feed "feed the animals" (,feed animals ...))
+         (wash "wash the animals" (@ (soap boolean)) (,wash animals ...))
+         (help "print help" (,app-help-command)))
+        ))
+    (define (run-tests)
+      (test-begin "app")
+      (test '((camel elephant) "today")
+          (run-application
+           zoo-app-spec
+           '("zoo" "--animals" "camel,elephant" "feed" "today")))
+      (test '((lions camel elephant) "tomorrow")
+          (run-application
+           zoo-app-spec
+           '("zoo" "--animals" "camel,elephant" "--lions" "feed" "tomorrow")))
+      (test '((soap . #f) rhino)
+          (run-application zoo-app-spec '("zoo" "--animals" "rhino" "wash")))
+      (test '((soap . #t) rhino)
+          (run-application zoo-app-spec
+                           '("zoo" "--animals" "rhino" "wash" "--soap")))
+      (test '((soap . #t) rhino)
+          (run-application zoo-app-spec
+                           '("zoo" "wash" "--soap" "--animals" "rhino")))
+      (test 'error
+          (guard (exn (else 'error))
+            (run-application zoo-app-spec
+                             '("zoo" "--soap" "wash" "--animals" "rhino"))))
+      (let ((out (open-output-string)))
+        (parameterize ((current-output-port out))
+          (run-application zoo-app-spec '("zoo" "help"))
+          (test "Usage: zoo [options] <command>\nCommands:\n  feed animals ... - feed the animals\n  wash animals ... - wash the animals\n  help - print help\nOptions:\n      --animals - list of animals to act on (default all)\n  -l, --lions - also apply the action to lions\n"
+              (get-output-string out))))
+      (test-end))))

lib/chibi/app.scm

@@ -1,12 +1,19 @@
 ;; app.scm -- unified option parsing and config
-;; Copyright (c) 2012-2015 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2012-2024 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
-;;> The high-level interface.  Given an application spec \var{spec},
-;;> parses the given command-line arguments \var{args} into a config
-;;> object, prepended to the existing object \var{config} if given.
-;;> Then runs the corresponding command (or sub-command) procedure
-;;> from \var{spec}.
+;;> The high-level interface.  Parses a command-line with optional
+;;> and/or positional arguments, with arbitrarily nested subcommands
+;;> (optionally having their own arguments), and calls the
+;;> corresponding main procedure on the parsed config.
+;;>
+;;> Given an application spec \var{spec}, parses the given
+;;> command-line arguments \var{args} into a config object (from
+;;> \scheme{(chibi config)}), prepended to the existing object
+;;> \var{config} if given.  Then runs the corresponding command (or
+;;> sub-command) procedure from \var{spec} on the following arguments:
+;;>
+;;> \scheme{(<proc> <config> <spec> <positional args> ...)}
 ;;>
 ;;> The app spec should be a list of the form:
 ;;>
@@ -15,12 +22,13 @@
 ;;> where clauses can be any of:
 ;;>
 ;;> \itemlist[
-;;> \item[\scheme{(@ <opt-spec>)} - option spec, described below]
-;;> \item[\scheme{(begin: <begin-proc>)} - procedure to run before main]
-;;> \item[\scheme{(end: <end-proc>)} - procedure to run after main]
-;;> \item[\scheme{(<proc> args ...)} - main procedure (args only for documentation)]
-;;> \item[\scheme{<app-spec>} - a subcommand described by the nested spec]
-;;> \item[\scheme{(or <app-spec> ...)} - an alternate list of subcommands]
+;;> \item{\scheme{(@ <opt-spec>)} - option spec, described below}
+;;> \item{\scheme{(begin: <begin-proc>)} - procedure to run before main}
+;;> \item{\scheme{(end: <end-proc>)} - procedure to run after main}
+;;> \item{\scheme{(types: (<type-name> <parser>) ...)} - additional types that can be used in argument parsing}
+;;> \item{\scheme{(<proc> args ...)} - main procedure (args only for documentation)}
+;;> \item{\scheme{<app-spec>} - a subcommand described by the nested spec}
+;;> \item{\scheme{(or <app-spec> ...)} - an alternate list of subcommands}
 ;;> ]
 ;;>
 ;;> For subcommands the symbolic command name must match, though it is
@@ -40,7 +48,7 @@
 ;;>
 ;;> \itemlist[
 ;;> \item{\scheme{boolean} - boolean, associated value optional, allowing \scheme{--noname} to indicate \scheme{#false}}
-;;> \item{[\scheme{char} - a single character}
+;;> \item{\scheme{char} - a single character}
 ;;> \item{\scheme{integer} - an exact integer}
 ;;> \item{\scheme{real} - any real number}
 ;;> \item{\scheme{number} - any real or complex number}
@@ -55,7 +63,43 @@
 ;;> files, whereas the app specs include embedded procedure objects so
 ;;> are typically written with \scheme{quasiquote}.
 ;;>
-;;> Complete Example:
+;;> Complete Example - stripped down ls(1):
+;;>
+;;> \schemeblock{
+;;> (import (scheme base)
+;;>         (scheme process-context)
+;;>         (scheme write)
+;;>         (srfi 130)
+;;>         (chibi app)
+;;>         (chibi config)
+;;>         (chibi filesystem))
+;;>
+;;> (define (ls cfg spec . files)
+;;>   (for-each
+;;>     (lambda (x)
+;;>       (for-each
+;;>         (lambda (file)
+;;>           (unless (and (string-prefix? "." file)
+;;>                        (not (conf-get cfg 'all)))
+;;>             (write-string file)
+;;>             (when (conf-get cfg 'long)
+;;>               (write-string " ")
+;;>               (write (file-modification-time file)))
+;;>             (newline)))
+;;>         (if (file-directory? x) (directory-files x) (list x))))
+;;>     files))
+;;>
+;;> (run-application
+;;>   `(ls
+;;>     "list directory contents"
+;;>     (@
+;;>      (long boolean (#\\l) "use a long listing format")
+;;>      (all boolean (#\\a) "do not ignore entries starting with ."))
+;;>     (,ls files ...))
+;;>   (command-line))
+;;> }
+;;>
+;;> Subcommand Skeleton Example:
 ;;>
 ;;> \schemeblock{
 ;;> (run-application
@@ -63,11 +107,11 @@
 ;;>     "Zookeeper Application"
 ;;>     (@
 ;;>      (animals (list symbol) "list of animals to act on (default all)")
-;;>      (lions boolean (#\l) "also apply the action to lions"))
+;;>      (lions boolean (#\\l) "also apply the action to lions"))
 ;;>     (or
 ;;>      (feed "feed the animals" () (,feed animals ...))
 ;;>      (wash "wash the animals" (@ (soap boolean)) (,wash animals ...))
-;;>      (help "print help" (,app-help-command)))
+;;>      (help "print help" (,app-help-command))))
 ;;>   (command-line)
 ;;>   (conf-load (string-append (get-environment-variable "HOME") "/.zoo")))
 ;;> }
@@ -125,7 +169,7 @@
   (let ((args (or (and (pair? o) (car o)) (command-line)))
         (config (and (pair? o) (pair? (cdr o)) (cadr o))))
     (cond
-     ((parse-app '() (cdr spec) '() (cdr args) config #f #f)
+     ((parse-app '() (cdr spec) '() (cdr args) config #f #f '())
       => (lambda (v)
            (let ((proc (vector-ref v 0))
                  (cfg (vector-ref v 1))
@@ -133,13 +177,14 @@
                  (init (vector-ref v 3))
                  (end (vector-ref v 4)))
              (if init (init cfg))
-             (apply proc cfg spec args)
-             (if end (end cfg)))))
+             (let ((res (apply proc cfg spec args)))
+               (if end (end cfg))
+               res))))
      ((null? (cdr args))
       (app-help spec args)
       (error "Expected a command"))
      (else
-      (error "Unknown command" (cdr args))))))
+      (error "Unknown command" args)))))
 
 ;;> Parse a single command-line argument from \var{args} according to
 ;;> \var{conf-spec}, and returns a list of two values: the
@@ -149,7 +194,7 @@
 ;;> \var{fail} with a single string argument describing the error,
 ;;> returning that result.
 
-(define (parse-option prefix conf-spec args fail)
+(define (parse-option prefix conf-spec args types fail)
   (define (parse-value type str)
     (cond
      ((not (string? str))
@@ -186,7 +231,10 @@
                    res))
                #f))
         (else
-         (list str #f))))))
+         (cond
+          ((assq type types)
+           => (lambda (cell) (list ((cadr cell) str) #f)))
+          (else (list str #f))))))))
   (define (lookup-conf-spec conf-spec syms strs)
     (let ((sym (car syms))
           (str (car strs)))
@@ -301,7 +349,7 @@
 ;;> is the list of remaining non-option arguments.  Calls fail on
 ;;> error and tries to continue processing from the result.
 
-(define (parse-options prefix conf-spec orig-args fail)
+(define (parse-options prefix conf-spec orig-args types fail)
   (let lp ((args orig-args)
            (opts (make-conf '() #f (cons 'options orig-args) #f)))
     (cond
@@ -311,7 +359,7 @@
           (not (eqv? #\- (string-ref (car args) 0))))
       (cons opts (if (equal? (car args) "--") (cdr args) args)))
      (else
-      (let ((val+args (parse-option prefix conf-spec args fail)))
+      (let ((val+args (parse-option prefix conf-spec args types fail)))
         (lp (cdr val+args)
             (conf-set opts (caar val+args) (cdar val+args))))))))
 
@@ -331,59 +379,92 @@
 ;;> all prefixed by \var{prefix}.  The original \var{spec} is used for
 ;;> \scheme{app-help}.
 
-(define (parse-app prefix spec opt-spec args config init end . o)
+(define (parse-app prefix spec opt-spec args config init end types . o)
   (define (next-prefix prefix name)
     (append (if (null? prefix) '(command) prefix) (list name)))
   (define (prev-prefix prefix)
-    (cond ((and (= 2 (length prefix))))
+    (cond ((and (= 2 (length prefix))) '())
           ((null? prefix) '())
           (else (reverse (cdr (reverse  prefix))))))
+  (define (all-opt-names opt-spec)
+    ;; TODO: nested options
+    (let lp ((ls opt-spec) (res '()))
+      (if (null? ls)
+          (map (lambda (x) (if (symbol? x) (symbol->string x) x))
+               (remove char? (reverse res)))
+          (let ((o (car ls)))
+            (lp (cdr ls)
+                (append (if (and (pair? (cddr o)) (pair? (third o)))
+                            (third o)
+                            '())
+                        (cons (car o) res)))))))
   (let ((fail (if (pair? o)
                   (car o)
                   (lambda (prefix spec opt args reason)
-                    ;; TODO: search for closest option in "unknown" case
-                    (error reason opt)))))
+                    (cond
+                     ((and (string=? reason "unknown option")
+                           (find-nearest-edits opt (all-opt-names spec)))
+                      => (lambda (similar)
+                           (if (pair? similar)
+                               (error reason opt "Did you mean: " similar)
+                               (error reason opt))))
+                     (else
+                      (error reason opt)))))))
     (cond
      ((null? spec)
       (error "no procedure in application spec"))
+     ((or (null? (car spec)) (equal? '(@) (car spec)))
+      (parse-app prefix (cdr spec) opt-spec args config init end types fail))
      ((pair? (car spec))
       (case (caar spec)
         ((@)
-         (let* ((new-opt-spec (cadr (car spec)))
+         (let* ((tail (cdar spec))
+                (new-opt-spec
+                 (cond
+                  ((not (pair? tail))
+                   '())
+                  ((or (pair? (cdr tail))
+                       (and (pair? (car tail)) (symbol? (caar tail))))
+                   tail)
+                  (else
+                   (car tail))))
                 (new-fail
                  (lambda (new-prefix new-spec new-opt new-args reason)
-                   (parse-options (prev-prefix prefix) opt-spec new-args fail)))
-                (cfg+args (parse-options prefix new-opt-spec args new-fail))
+                   (parse-option (prev-prefix prefix) opt-spec new-args types fail)))
+                (cfg+args (parse-options prefix new-opt-spec args types new-fail))
                 (config (conf-append (car cfg+args) config))
                 (args (cdr cfg+args)))
            (parse-app prefix (cdr spec) new-opt-spec args config
-                      init end new-fail)))
+                      init end types new-fail)))
         ((or)
-         (any (lambda (x) (parse-app prefix x opt-spec args config init end))
+         (any (lambda (x) (parse-app prefix x opt-spec args config init end types))
               (cdar spec)))
         ((begin:)
          (parse-app prefix (cdr spec) opt-spec args config
-                    (cadr (car spec)) end fail))
+                    (cadr (car spec)) end types fail))
         ((end:)
          (parse-app prefix (cdr spec) opt-spec args config
-                    init (cadr (car spec)) fail))
+                    init (cadr (car spec)) types fail))
+        ((types:)
+         (parse-app prefix (cdr spec) opt-spec args config
+                    init end (cdr (car spec)) fail))
         (else
          (if (procedure? (caar spec))
              (vector (caar spec) config args init end) ; TODO: verify
              (parse-app prefix (car spec) opt-spec args config
-                        init end fail)))))
+                        init end types fail)))))
      ((symbol? (car spec))
       (and (pair? args)
            (eq? (car spec) (string->symbol (car args)))
            (let ((prefix (next-prefix prefix (car spec))))
              (parse-app prefix (cdr spec) opt-spec (cdr args) config
-                        init end fail))))
+                        init end types fail))))
      ((procedure? (car spec))
       (vector (car spec) config args init end))
      (else
       (if (not (string? (car spec)))
           (error "unknown application spec" (car spec)))
-      (parse-app prefix (cdr spec) opt-spec args config init end fail)))))
+      (parse-app prefix (cdr spec) opt-spec args config init end types fail)))))
 
 (define (print-command-help command out)
   (cond
@@ -457,7 +538,7 @@
             (and (pair? (car ls)) (memq (caar ls) '(begin: end:) )))
         (lp (cdr ls) (car ls) commands options))
        ((and (pair? (car ls)) (eq? '@ (caar ls)))
-        (lp (cdr ls) docs commands (append options (cadr (car ls)))))
+        (lp (cdr ls) docs commands (append options (cdar ls))))
        ((and (pair? (car ls)) (symbol? (caar ls)))
         ;; don't print nested commands
         (if (pair? commands)

lib/chibi/app.sld

@@ -9,5 +9,6 @@
           (scheme process-context)
           (srfi 1)
           (chibi config)
+          (chibi edit-distance)
           (chibi string))
   (include "app.scm"))

lib/chibi/apropos.scm

@@ -0,0 +1,33 @@
+(define (list-bindings env)
+  (let parents ((env env) (binds '()))
+    (if (not env) binds
+        (let symbols ((syms (env-exports env)) (binds binds))
+          (if (null? syms) (parents (env-parent env) binds)
+              (symbols (cdr syms) (if (assv (car syms) binds) binds
+                                      (cons (cons (car syms) env)
+                                            binds))))))))
+
+(define (apropos-list-bindings query)
+  (cond ((symbol? query) (set! query (symbol->string query)))
+        ((not (string? query))
+         (error "Apropos query must be a symbol or a string")))
+  (sort (filter (lambda (binding)
+                  (string-contains (symbol->string (car binding)) query))
+                (list-bindings (interaction-environment)))
+        (lambda (a b) (string<? (symbol->string (car a))
+                                (symbol->string (car b))))))
+
+(define (apropos-list query) (map car (apropos-list-bindings query)))
+
+(define (apropos-prefix sym env)
+  (let ((p "procedure  ")
+        (s "syntax     ")
+        (v "variable   "))
+    (guard (_ (else s)) (if (procedure? (eval sym env)) p v))))
+
+(define (apropos query)
+  (for-each (lambda (bind)
+              (display (apropos-prefix (car bind) (cdr bind)))
+              (write (car bind))
+              (newline))
+            (apropos-list-bindings query)))

lib/chibi/apropos.sld

@@ -0,0 +1,4 @@
+(define-library (chibi apropos)
+  (export apropos apropos-list)
+  (import (scheme base) (chibi) (chibi string) (srfi 1) (srfi 95))
+  (include "apropos.scm"))

lib/chibi/assert-test.sld

@@ -0,0 +1,30 @@
+
+(define-library (chibi assert-test)
+  (import (chibi) (chibi assert) (chibi test))
+  (export run-tests)
+  (begin
+    (define-syntax test-assert
+      (syntax-rules ()
+        ((test-assert irritants expr)
+         (protect (exn
+                   (else
+                    (test irritants (exception-irritants exn))))
+           expr
+           (error "assertion not triggered")))))
+    (define (run-tests)
+      (test-begin "assert")
+      (test-assert '((= x (+ x 1))
+                     (x 3))
+        (let ((x 3)) (assert (= x (+ x 1)))))
+      (test-assert '((= x (+ y 1))
+                     (x 3)
+                     (y 42))
+        (let ((x 3) (y 42)) (assert (= x (+ y 1)))))
+      (test-assert '((eq? x 'three)
+                     (x 3))
+        (let ((x 3)) (assert (eq? x 'three))))
+      (test-assert '((eq? x 'three)
+                     "expected three: "
+                     3)
+        (let ((x 3)) (assert (eq? x 'three) "expected three: " x)))
+      (test-end))))

lib/chibi/assert.sld

@@ -0,0 +1,115 @@
+
+;;> A nice assert macro.
+;;>
+;;> Assert macros are common in Scheme, in particular being helpful
+;;> for domain checks at the beginning of a procedure to catch errors
+;;> as early as possible.  Compared to statically typed languages this
+;;> has the advantages that the assertions are optional, and that they
+;;> are not limited by the type system.  SRFI 145 provides the related
+;;> notion of assumptions, but the motivation there is to provide
+;;> hints to optimizing compilers, and these are not required to
+;;> actually signal an error.
+;;>
+;;> \macro{(assert expr [msg ...])}
+;;>
+;;> Equivalent to SRFI 145 \code{assume} except that an error is
+;;> guaranteed to be raised if \var{expr} is false.  Conceptually
+;;> shorthand for
+;;>
+;;> \code{(or \var{expr}
+;;>     (error "assertion failed" \var{msg} ...))}
+;;>
+;;> that is, evaluates \var{expr} and returns it if true, but raises
+;;> an exception otherwise.  The error is augmented to include the
+;;> text of the failed \var{expr}.  If no additional \var{msg}
+;;> arguments are provided then \var{expr} is scanned for free
+;;> variables in non-operator positions to report values from, e.g. in
+;;>
+;;> \code{(let ((x 3))
+;;>  (assert (= x (+ x 1))))}
+;;>
+;;> the error would also report the bound value of \code{x}.  This
+;;> uses the technique from Oleg Kiselyov's \hyperlink[http://okmij.org/ftp/Scheme/assert-syntax-rule.txt]{good assert macro},
+;;> which is convenient but fallible.  It is thus best to keep the
+;;> body of the assertion simple, moving any predicates you need to
+;;> external utilities, or provide an explicit \var{msg}.
+
+(define-library (chibi assert)
+  (export assert)
+  (cond-expand
+   (chibi
+    (import (chibi))
+    (begin
+      (define-syntax syntax-identifier?
+        (er-macro-transformer
+         (lambda (expr rename compare)
+           (if (identifier? (cadr expr))
+               (car (cddr expr))
+               (cadr (cddr expr))))))
+      (define-syntax syntax-id-memq?
+        (er-macro-transformer
+         (lambda (expr rename compare)
+           (let ((expr (cdr expr)))
+             (if (any (lambda (x) (compare x (car expr))) (cadr expr))
+                 (car (cddr expr))
+                 (cadr (cddr expr)))))))))
+   (else
+    (import (scheme base))
+    (begin
+      ;; from match.scm
+      (define-syntax syntax-identifier?
+        (syntax-rules ()
+          ((_ (x . y) success-k failure-k) failure-k)
+          ((_ #(x ...) success-k failure-k) failure-k)
+          ((_ x success-k failure-k)
+           (let-syntax
+               ((sym?
+                 (syntax-rules ()
+                   ((sym? x sk fk) sk)
+                   ((sym? y sk fk) fk))))
+             (sym? abracadabra success-k failure-k)))))
+      (define-syntax syntax-id-memq?
+        (syntax-rules ()
+          ((syntax-memq? id (ids ...) sk fk)
+           (let-syntax
+               ((memq?
+                 (syntax-rules (ids ...)
+                   ((memq? id sk2 fk2) fk2)
+                   ((memq? any-other sk2 fk2) sk2))))
+             (memq? random-symbol-to-match sk fk))))))))
+  (begin
+    (define-syntax extract-vars
+      (syntax-rules ()
+        ((report-vars (op arg0 arg1 ...) (next ...) res)
+         (syntax-id-memq? op (quote quasiquote lambda let let* letrec letrec*
+                              let-syntax letrec-syntax let-values let*-values
+                              receive match case define define-syntax do)
+                          (next ... res)
+                          (extract-vars arg0
+                                        (extract-vars (op arg1 ...) (next ...))
+                                        res)))
+        ((report-vars (op . x) (next ...) res)
+         (next ... res))
+        ((report-vars x (next ...) (res ...))
+         (syntax-identifier? x
+                             (syntax-id-memq? x (res ...)
+                                              (next ... (res ...))
+                                              (next ... (res ... x)))
+                             (next ... (res ...))))))
+    (define-syntax qq-vars
+      (syntax-rules ()
+        ((qq-vars (next ...) (var ...))
+         (next ... `(var ,var) ...))))
+    (define-syntax report-final
+      (syntax-rules ()
+        ((report-final expr msg ...)
+         (error "assertion failed" 'expr msg ...))))
+    (define-syntax assert
+      (syntax-rules ()
+        ((assert test)
+         (or test
+             (extract-vars test (qq-vars (report-final test)) ())))
+        ((assert test msg ...)
+         (or test
+             (report-final test msg ...)))
+        ((assert) #t)))))

lib/chibi/ast.c

@@ -1,13 +1,35 @@
 /*  ast.c -- interface to the Abstract Syntax Tree            */
-/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include <chibi/eval.h>
 
 #ifndef PLAN9
+#include <stdlib.h>
 #include <errno.h>
 #endif
 
+#ifdef _WIN32
+#if defined(__MINGW32__) || defined(__MINGW64__)
+/* Workaround MinGW header implementation */
+errno_t getenv_s(size_t*, char*, size_t, const char*);
+#endif
+int setenv(const char *name, const char *value, int overwrite)
+{
+  int errcode = 0;
+  if (!overwrite) {
+    size_t envsize = 0;
+    errcode = getenv_s(&envsize, NULL, 0, name);
+    if (errcode || envsize) return errcode;
+  }
+  return _putenv_s(name, value);
+}
+int unsetenv(const char *name)
+{
+  return setenv(name, "", 1);
+}
+#endif
+
 #if ! SEXP_USE_BOEHM
 extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
 #endif
@@ -40,7 +62,7 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
   sexp_gc_release2(ctx);
 }
 
-static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
+sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
   sexp cell;
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   cell = sexp_env_cell(ctx, env, id, 0);
@@ -50,33 +72,55 @@ static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sex
       id = sexp_synclo_expr(id);
     }
     cell = sexp_env_cell(ctx, env, id, 0);
-    if (!cell && createp)
+    if (!cell && sexp_truep(createp))
       cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
   }
   return cell ? cell : SEXP_FALSE;
 }
 
-static sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_procedure_code(proc);
 }
 
-static sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_procedure_vars(proc);
 }
 
-static sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_make_fixnum(sexp_procedure_num_args(proc));
 }
 
-static sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_make_boolean(sexp_procedure_variadic_p(proc));
 }
 
-static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_procedure_variable_transformer_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_boolean(sexp_procedure_variable_transformer_p(proc));
+}
+
+sexp sexp_get_procedure_flags (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return (sexp) (sexp_uint_t) sexp_procedure_flags(proc);
+}
+
+sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) {
+  sexp flags;
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc);
+  if (sexp_procedure_variable_transformer_p(base_proc))
+    return base_proc;
+  flags = sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER);
+  return sexp_make_procedure(ctx, flags,
+                             sexp_make_fixnum(sexp_procedure_num_args(base_proc)),
+                             sexp_procedure_code(base_proc),
+                             sexp_procedure_vars(base_proc));
+}
+
+sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   if (! sexp_opcodep(op))
     return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
   else if (! sexp_opcode_name(op))
@@ -103,7 +147,7 @@ static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
   return res;
 }
 
-static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp res;
   if (!op)
     return sexp_type_by_index(ctx, SEXP_OBJECT);
@@ -117,7 +161,7 @@ static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp o
   return sexp_translate_opcode_type(ctx, res);
 }
 
-static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
+sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
   sexp res;
   int p = sexp_unbox_fixnum(k);
   if (! sexp_opcodep(op))
@@ -136,7 +180,7 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp
   default:
     res = sexp_opcode_arg3_type(op);
     if (res && sexp_vectorp(res)) {
-      if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
+      if (sexp_vector_length(res) > (unsigned)(sexp_unbox_fixnum(k)-2))
         res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
       else
         res = sexp_type_by_index(ctx, SEXP_OBJECT);
@@ -146,17 +190,17 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp
   return sexp_translate_opcode_type(ctx, res);
 }
 
-static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_class(op));
 }
 
-static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_code(op));
 }
 
-static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp data;
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   data = sexp_opcode_data(op);
@@ -167,29 +211,41 @@ static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
     sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
 }
 
-static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_num_args(op));
 }
 
-static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_boolean(sexp_opcode_variadic_p(op));
 }
 
-static sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
+sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
   sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
   return sexp_make_fixnum(sexp_port_line(p));
 }
 
-static sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
+sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
   sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
   sexp_port_line(p) = sexp_unbox_fixnum(i);
   return SEXP_VOID;
 }
 
-static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_get_port_sourcep (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
+  return sexp_make_boolean(sexp_port_sourcep(p));
+}
+
+sexp sexp_set_port_sourcep (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp b) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
+  sexp_assert_type(ctx, sexp_booleanp, SEXP_BOOLEAN, b);
+  sexp_port_sourcep(p) = sexp_truep(b);
+  return SEXP_VOID;
+}
+
+sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   if (!x)
     return sexp_type_by_index(ctx, SEXP_OBJECT);
   if (sexp_pointerp(x))
@@ -212,41 +268,43 @@ static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
     return sexp_type_by_index(ctx, SEXP_OBJECT);
 }
 
-static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
-  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
-  return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
+sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp e2) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1);
+  if (sexp_truep(e2)) sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2);
+  sexp_env_parent(e1) = e2;
+  return SEXP_VOID;
 }
 
-static sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
 }
 
-static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
+sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
   sexp_env_lambda(e) = lam;
   return SEXP_VOID;
 }
 
-static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   return sexp_make_boolean(sexp_env_syntactic_p(e));
 }
 
-static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
+sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   sexp_env_syntactic_p(e) = sexp_truep(synp);
   return SEXP_VOID;
 }
 
-static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
   return sexp_env_cell_define(ctx, env, name, value, NULL);
 }
 
-static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
   sexp_gc_var1(tmp);
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
@@ -256,38 +314,45 @@ static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp
   return SEXP_VOID;
 }
 
-static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
+sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
   sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
   return sexp_make_fixnum(sexp_core_code(c));
 }
 
-static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_name(t);
 }
 
-static sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_cpl(t);
 }
 
-static sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_slots(t);
 }
 
-static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t))
     : sexp_make_fixnum(sexp_type_field_eq_len_base(t));
 }
 
-static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE;
 }
 
-static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_type_printer_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp t, sexp p) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, p);
+  sexp_type_print(t) = p;
+  return SEXP_VOID;
+}
+
+sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   sexp t;
   if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
     return SEXP_ZERO;
@@ -295,15 +360,40 @@ static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_make_fixnum(sexp_type_size_of_object(t, x));
 }
 
-static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
+sexp sexp_immutablep_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return sexp_pointerp(x) ? sexp_make_boolean(sexp_immutablep(x)) : SEXP_TRUE;
+}
+
+sexp sexp_immutable_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp s) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, s);
+#if SEXP_USE_PACKED_STRINGS
+  /* no sharing with packed strings */
+  res = sexp_c_string(ctx, sexp_string_data(s), sexp_string_size(s));
+#else
+  res = sexp_alloc_type(ctx, string, SEXP_STRING);
+  sexp_string_bytes(res) = sexp_string_bytes(s);
+  sexp_string_offset(res) = sexp_string_offset(s);
+  sexp_string_size(res) = sexp_string_size(s);
+  sexp_copy_on_writep(s) = 1;
+#endif
+  sexp_immutablep(res) = 1;
+  return res;
+}
+
+sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
   sexp x = (sexp)sexp_unbox_fixnum(i);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
-  if (sexp_pointerp(x))
+  if (!x || sexp_pointerp(x))
     return dflt;
   return x;
 }
 
-static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
+sexp sexp_object_to_integer (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return sexp_make_integer(ctx, (sexp_uint_t)x);
+}
+
+sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
   sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
   sexp_lambda_name(res) = name;
   sexp_lambda_params(res) = params;
@@ -317,7 +407,7 @@ static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name,
   return res;
 }
 
-static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
+sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
   sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
   sexp_lambda_name(res) = sexp_lambda_name(lambda);
   sexp_lambda_params(res) = sexp_lambda_params(lambda);
@@ -331,21 +421,21 @@ static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
   return res;
 }
 
-static sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
+sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
   sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
   sexp_set_var(res) = var;
   sexp_set_value(res) = value;
   return res;
 }
 
-static sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
+sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
   sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
   sexp_ref_name(res) = name;
   sexp_ref_cell(res) = cell;
   return res;
 }
 
-static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
+sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
   sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
   sexp_cnd_test(res) = test;
   sexp_cnd_pass(res) = pass;
@@ -353,26 +443,26 @@ static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sex
   return res;
 }
 
-static sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
   sexp res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
   sexp_seq_ls(res) = ls;
   return res;
 }
 
-static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
+sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
   sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
   sexp_lit_value(res) = value;
   return res;
 }
 
-static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
+sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
   sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO);
   sexp_macro_proc(res) = proc;
   sexp_macro_env(res) = env;
   return res;
 }
 
-static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
+sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
   sexp ctx2 = ctx;
   if (sexp_envp(e)) {
     ctx2 = sexp_make_child_context(ctx, NULL);
@@ -381,12 +471,12 @@ static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e)
   return sexp_analyze(ctx2, x);
 }
 
-static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
+sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   return sexp_extend_env(ctx, env, vars, value);
 }
 
-static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   sexp_gc_var2(ls, res);
   sexp_gc_preserve2(ctx, ls, res);
   res = x;
@@ -398,7 +488,7 @@ static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return res;
 }
 
-static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
   size_t sum_freed=0;
 #if SEXP_USE_BOEHM
   GC_gcollect();
@@ -408,20 +498,34 @@ static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
   return sexp_make_unsigned_integer(ctx, sum_freed);
 }
 
+sexp sexp_gc_count_op (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_make_unsigned_integer(ctx, sexp_context_gc_count(ctx));
+}
+
+sexp sexp_gc_usecs_op (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_make_unsigned_integer(ctx, sexp_context_gc_usecs(ctx));
+}
+
 #if SEXP_USE_GREEN_THREADS
-static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
+sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
   sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P);
   sexp_global(ctx, SEXP_G_ATOMIC_P) = new_val;
   return res;
 }
 #endif
 
+sexp sexp_thread_interrupt (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  sexp_context_interruptp(thread) = 1;
+  return sexp_make_boolean(ctx == thread);
+}
+
 sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
-  sexp ls;
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
   res = SEXP_NULL;
 #if SEXP_USE_GREEN_THREADS
+  sexp ls;
   for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
     sexp_push(ctx, res, sexp_car(ls));
   for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
@@ -432,15 +536,18 @@ sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
   return res;
 }
 
-static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y, sexp start) {
   const char *res;
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
-  res = strstr(sexp_string_data(x), sexp_string_data(y));
-  return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE;
+  sexp_assert_type(ctx, sexp_string_cursorp, SEXP_STRING_CURSOR, start);
+  if (sexp_unbox_string_cursor(start) > sexp_string_size(x))
+    return sexp_user_exception(ctx, self, "string-contains: start out of range", start);
+  res = strstr(sexp_string_data(x) + sexp_unbox_string_cursor(start), sexp_string_data(y));
+  return res ? sexp_make_string_cursor(res-sexp_string_data(x)) : SEXP_FALSE;
 }
 
-static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
+sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
   unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
   sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
     start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
@@ -451,9 +558,9 @@ static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp ds
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
   if (from < 0 || from > to)
     return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
-  if (start < 0 || start > sexp_string_size(src))
+  if (start < 0 || start > (sexp_sint_t)sexp_string_size(src))
     return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
-  if (end < start || end > sexp_string_size(src))
+  if (end < start || end > (sexp_sint_t)sexp_string_size(src))
     return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
   pfrom = (unsigned char*)sexp_string_data(dst) + from;
   pto = (unsigned char*)sexp_string_data(dst) + to;
@@ -471,7 +578,7 @@ static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp ds
   return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
 }
 
-static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
 #ifdef PLAN9
   return SEXP_FALSE;
 #else
@@ -479,7 +586,7 @@ static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
 #endif
 }
 
-static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
 #ifdef PLAN9
   return SEXP_FALSE;
 #else
@@ -494,22 +601,22 @@ static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
 #endif
 }
 
-static sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_free_vars(ctx, x, SEXP_NULL);
 }
 
-static sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
+sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
   return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
 }
 
-static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
+sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
   return sexp_make_boolean(unsetenv(sexp_string_data(name)));
 }
 
-static sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
+sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
   sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
   sexp_exception_message(res) = SEXP_TRAMPOLINE;
   return res;
@@ -519,6 +626,7 @@ static sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
   sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag));
 
 sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  sexp_gc_var2(sym, str);
   if (!(sexp_version_compatible(ctx, version, sexp_version)
         && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
     return SEXP_ABI_ERROR;
@@ -551,6 +659,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
   sexp_define_type(ctx, "Cnd", SEXP_CND);
   sexp_define_type(ctx, "Set", SEXP_SET);
+  sexp_define_type(ctx, "Set-Syn", SEXP_SET_SYN);
   sexp_define_type(ctx, "Ref", SEXP_REF);
   sexp_define_type(ctx, "Seq", SEXP_SEQ);
   sexp_define_type(ctx, "Lit", SEXP_LIT);
@@ -568,7 +677,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
   sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
   sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
-  sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
   sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE);
   sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE);
   sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT);
@@ -592,22 +700,28 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
   sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!");
   sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!");
+  sexp_define_accessors(ctx, env, SEXP_SET, 2, "set-source", "set-source-set!");
   sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!");
   sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!");
   sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!");
   sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
-  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-name", "bytecode-name-set!");
-  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-literals", NULL);
-  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 4, "bytecode-source", NULL);
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 0, "bytecode-name", "bytecode-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-literals", NULL);
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-source", NULL);
   sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
   sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL);
   sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL);
   sexp_define_accessors(ctx, env, SEXP_MACRO, 1, "macro-env", NULL);
   sexp_define_accessors(ctx, env, SEXP_MACRO, 2, "macro-source", NULL);
+  sexp_define_accessors(ctx, env, SEXP_MACRO, 3, "macro-aux", "macro-aux-set!");
+  sexp_define_foreign(ctx, env, "make-procedure", 4, sexp_make_procedure_op);
   sexp_define_foreign(ctx, env, "procedure-code", 1, sexp_get_procedure_code);
   sexp_define_foreign(ctx, env, "procedure-vars", 1, sexp_get_procedure_vars);
   sexp_define_foreign(ctx, env, "procedure-arity", 1, sexp_get_procedure_arity);
   sexp_define_foreign(ctx, env, "procedure-variadic?", 1, sexp_get_procedure_variadic_p);
+  sexp_define_foreign(ctx, env, "procedure-variable-transformer?", 1, sexp_get_procedure_variable_transformer_p);
+  sexp_define_foreign(ctx, env, "procedure-flags", 1, sexp_get_procedure_flags);
+  sexp_define_foreign(ctx, env, "make-variable-transformer", 1, sexp_make_variable_transformer_op);
   sexp_define_foreign(ctx, env, "copy-lambda", 1, sexp_copy_lambda);
   sexp_define_foreign_opt(ctx, env, "make-lambda", 4, sexp_make_lambda_op, SEXP_NULL);
   sexp_define_foreign_opt(ctx, env, "make-cnd", 3, sexp_make_cnd_op, SEXP_VOID);
@@ -630,12 +744,15 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
   sexp_define_foreign(ctx, env, "port-line", 1, sexp_get_port_line);
   sexp_define_foreign(ctx, env, "port-line-set!", 2, sexp_set_port_line);
+  sexp_define_foreign(ctx, env, "port-source?", 1, sexp_get_port_sourcep);
+  sexp_define_foreign(ctx, env, "port-source?-set!", 2, sexp_set_port_sourcep);
   sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of);
   sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op);
   sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op);
   sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op);
   sexp_define_foreign(ctx, env, "type-num-slots", 1, sexp_type_num_slots_op);
   sexp_define_foreign(ctx, env, "type-printer", 1, sexp_type_printer_op);
+  sexp_define_foreign(ctx, env, "type-printer-set!", 2, sexp_type_printer_set_op);
   sexp_define_foreign(ctx, env, "env-parent-set!", 2, sexp_env_parent_set_op);
   sexp_define_foreign(ctx, env, "env-lambda", 1, sexp_env_lambda_op);
   sexp_define_foreign(ctx, env, "env-lambda-set!", 2, sexp_env_lambda_set_op);
@@ -645,13 +762,19 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
   sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
   sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
+  sexp_define_foreign(ctx, env, "immutable?", 1, sexp_immutablep_op);
+  sexp_define_foreign(ctx, env, "immutable-string", 1, sexp_immutable_string_op);
   sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
+  sexp_define_foreign_opt(ctx, env, "object->integer", 1, sexp_object_to_integer, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
+  sexp_define_foreign(ctx, env, "gc-count", 0, sexp_gc_count_op);
+  sexp_define_foreign(ctx, env, "gc-usecs", 0, sexp_gc_usecs_op);
 #if SEXP_USE_GREEN_THREADS
   sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
 #endif
+  sexp_define_foreign(ctx, env, "%thread-interrupt!", 1, sexp_thread_interrupt);
   sexp_define_foreign(ctx, env, "thread-list", 0, sexp_thread_list);
-  sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
+  sexp_define_foreign_opt(ctx, env, "string-contains", 3, sexp_string_contains, sexp_make_string_cursor(0));
   sexp_define_foreign(ctx, env, "string-cursor-copy!", 5, sexp_string_cursor_copy);
   sexp_define_foreign(ctx, env, "errno", 0, sexp_errno);
   sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
@@ -659,5 +782,11 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv);
   sexp_define_foreign(ctx, env, "unsetenv", 1, sexp_unsetenv);
   sexp_define_foreign(ctx, env, "abort", 1, sexp_abort);
+  sexp_gc_preserve2(ctx, sym, str);
+  sym = sexp_intern(ctx, "chibi-version", -1);
+  str = sexp_c_string(ctx, sexp_version, -1);
+  sexp_immutablep(str) = 1;
+  sexp_env_define(ctx, env, sym, str);
+  sexp_gc_release2(ctx);
   return SEXP_VOID;
 }

lib/chibi/ast.scm

@@ -109,6 +109,34 @@
        ((opcode? x) (cond ((opcode-name x) => string->symbol) (else x)))
        (else x)))))
 
+;;> \section{Identifier Macros}
+
+;;> \procedure{(make-variable-transformer proc)}
+
+;;> Returns a new procedure wrapping the input procedure \var{proc}.
+;;> The returned procedure, if used as a macro transformer procedure,
+;;> can expand an instance of \scheme{set!} with its keyword on the
+;;> left hand side.
+
+;;> \macro{(identifier-syntax clauses ...)}
+
+;;> A high-level form for creating identifier macros. See
+;;> \hyperlink["http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-14.html#node_idx_796"]{the R6RS specification.}
+
+(define-syntax identifier-syntax
+  (syntax-rules (set!)
+    ((_ template)
+     (syntax-rules ()
+       ((_ xs (... ...))
+        (template xs (... ...)))
+       (x template)))
+    ((_ (id_1 template_1) ((set! id_2 pattern) template_2))
+     (make-variable-transformer
+      (syntax-rules (set!)
+        ((set! id_2 pattern) template_2)
+        ((id_1 xs (... ...)) (template_1 xs (... ...)))
+        (id_1 template_1))))))
+
 ;;> \section{Types}
 
 ;;> All objects have an associated type, and types may have parent
@@ -121,32 +149,32 @@
 ;;> used in the \scheme{match} \scheme{($ ...)} syntax.
 
 ;;> \itemlist[
-;;> \item{\scheme{<object>} - the parent of all types}
-;;> \item{\scheme{<number>} - abstract numeric type}
-;;> \item{\scheme{<bignum>} - arbitrary precision exact integers}
-;;> \item{\scheme{<flonum>} - inexact real numbers}
-;;> \item{\scheme{<integer>} - abstract integer type}
-;;> \item{\scheme{<symbol>} - symbols}
-;;> \item{\scheme{<char>} - character}
-;;> \item{\scheme{<boolean>} - \scheme{#t} or \scheme{#f}}
-;;> \item{\scheme{<string>} - strings of characters}
-;;> \item{\scheme{<byte-vector>} - uniform vector of octets}
-;;> \item{\scheme{<pair>} - a \var{car} and \var{cdr}, the basis for lists}
-;;> \item{\scheme{<vector>} - vectors}
-;;> \item{\scheme{<opcode>} - a primitive opcode or C function}
-;;> \item{\scheme{<procedure>} - a closure}
-;;> \item{\scheme{<bytecode>} - the compiled code for a closure}
-;;> \item{\scheme{<env>} - an environment structure}
-;;> \item{\scheme{<macro>} - a macro object, usually not first-class}
-;;> \item{\scheme{<lam>} - a lambda AST type}
-;;> \item{\scheme{<cnd>} - an conditional AST type (i.e. \scheme{if})}
-;;> \item{\scheme{<ref>} - a reference AST type}
-;;> \item{\scheme{<set>} - a mutation AST type (i.e. \scheme{set!})}
-;;> \item{\scheme{<seq>} - a sequence AST type}
-;;> \item{\scheme{<lit>} - a literal AST type}
-;;> \item{\scheme{<sc>} - a syntactic closure}
-;;> \item{\scheme{<context>} - a context object (including threads)}
-;;> \item{\scheme{<exception>} - an exception object}
+;;> \item{\scheme{Object} - the parent of all types}
+;;> \item{\scheme{Number} - abstract numeric type}
+;;> \item{\scheme{Bignum} - arbitrary precision exact integers}
+;;> \item{\scheme{Flonum} - inexact real numbers}
+;;> \item{\scheme{Integer} - abstract integer type}
+;;> \item{\scheme{Symbol} - symbols}
+;;> \item{\scheme{Char} - character}
+;;> \item{\scheme{Boolean} - \scheme{#t} or \scheme{#f}}
+;;> \item{\scheme{String} - strings of characters}
+;;> \item{\scheme{Byte-Vector} - uniform vector of octets}
+;;> \item{\scheme{Pair} - a \var{car} and \var{cdr}, the basis for lists}
+;;> \item{\scheme{Vector} - vectors}
+;;> \item{\scheme{Opcode} - a primitive opcode or C function}
+;;> \item{\scheme{Procedure} - a closure}
+;;> \item{\scheme{Bytecode} - the compiled code for a closure}
+;;> \item{\scheme{Env} - an environment structure}
+;;> \item{\scheme{Macro} - a macro object, usually not first-class}
+;;> \item{\scheme{Lam} - a lambda AST type}
+;;> \item{\scheme{Cnd} - an conditional AST type (i.e. \scheme{if})}
+;;> \item{\scheme{Ref} - a reference AST type}
+;;> \item{\scheme{Set} - a mutation AST type (i.e. \scheme{set!})}
+;;> \item{\scheme{Seq} - a sequence AST type}
+;;> \item{\scheme{Lit} - a literal AST type}
+;;> \item{\scheme{Sc} - a syntactic closure}
+;;> \item{\scheme{Context} - a context object (including threads)}
+;;> \item{\scheme{Exception} - an exception object}
 ;;> ]
 
 ;;> The following extended type predicates may also be used to test
@@ -222,6 +250,8 @@
 ;;> \item{\scheme{(macro-procedure f)} - the macro procedure}
 ;;> \item{\scheme{(macro-env f)} - the environment the macro was defined in}
 ;;> \item{\scheme{(macro-source f)} - the source location the macro was defined in}
+;;> \item{\scheme{(macro-aux f)} - custom auxiliary data stored with the macro}
+;;> \item{\scheme{(macro-aux-set! f x)}}
 ;;> ]
 
 ;;> \subsection{Bytecode Objects}
@@ -351,11 +381,29 @@
 ;;> Returns the interpretation of the integer \var{n} as
 ;;> an immediate object, useful for debugging.
 
-;;> \procedure{(string-contains str pat)}
+;;> \procedure{(string-contains str pat [start])}
 
 ;;> Returns the first string cursor of \var{pat} in \var{str},
 ;;> of \scheme{#f} if it's not found.
 
+(cond-expand
+ (safe-string-cursors
+  (define orig-string-contains string-contains)
+  (set! string-contains
+        (lambda (str pat . o)
+          (let ((res
+                 (if (pair? o)
+                     (orig-string-contains str pat (string-cursor-where (car o)))
+                     (orig-string-contains str pat))))
+            (and res (make-string-cursor str res (string-size str)))))))
+ (else
+  ))
+
+;;> \procedure{(string-cursor-copy! dst src from start end)}
+
+;;> Copies the characters from \var{src}[\var{start}..\var{end}]
+;;> to \var{dst} starting at \var{from}.
+
 ;;> \procedure{(safe-setenv name value)}
 
 ;;> Equivalent to \scheme{setenv} but does nothing and returns
@@ -388,3 +436,7 @@
  (else
   (define-syntax atomically
     (syntax-rules () ((atomically . body) (begin . body))))))
+
+(define (thread-interrupt! thread)
+  (if (%thread-interrupt! thread)
+      (yield!)))

lib/chibi/ast.sld

@@ -1,11 +1,12 @@
 
 (define-library (chibi ast)
   (export
-   analyze optimize env-cell ast->sexp macroexpand type-of
+   analyze optimize env-cell ast->sexp macroexpand identifier-syntax
+   type-of
    Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env
    Number Bignum Flonum Integer Complex Char Boolean
    Symbol String Byte-Vector Vector Pair File-Descriptor
-   Context Lam Cnd Set Ref Seq Lit Sc Exception Core
+   Context Lam Cnd Set Set-Syn Ref Seq Lit Sc Exception Core
    syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core?
    environment? bytecode? exception? macro? context? file-descriptor?
    syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
@@ -20,23 +21,29 @@
    lambda-source-set!
    cnd-test cnd-pass cnd-fail
    cnd-test-set! cnd-pass-set! cnd-fail-set!
-   set-var set-value set-var-set! set-value-set!
+   set-var set-value set-var-set! set-value-set! set-source set-source-set!
    ref-name ref-cell ref-name-set! ref-cell-set!
    seq-ls seq-ls-set! lit-value lit-value-set!
    exception-kind exception-message exception-irritants exception-source
    opcode-name opcode-num-params opcode-return-type opcode-param-type
-   opcode-class opcode-code opcode-data opcode-variadic?
-   macro-procedure macro-env macro-source
+   opcode-class opcode-code opcode-data opcode-variadic? opcode?
+   macro-procedure macro-env macro-source macro-aux macro-aux-set!
    procedure-code procedure-vars procedure-name procedure-name-set!
-   procedure-arity procedure-variadic?
+   procedure-arity procedure-variadic? procedure-variable-transformer?
+   procedure-flags make-variable-transformer make-procedure procedure?
    bytecode-name bytecode-literals bytecode-source
-   port-line port-line-set!
+   port-line port-line-set! port-source? port-source?-set!
    extend-env env-parent env-parent-set! env-lambda env-lambda-set!
    env-define! env-push! env-syntactic? env-syntactic?-set! core-code
-   type-name type-cpl type-parent type-slots type-num-slots type-printer
-   object-size integer->immediate gc atomically thread-list abort
+   type-name type-cpl type-parent type-slots type-num-slots
+   type-printer type-printer-set!
+   object-size object->integer integer->immediate gc gc-usecs gc-count
+   atomically thread-list abort
    string-contains string-cursor-copy! errno integer->error-string
-   flatten-dot update-free-vars! setenv unsetenv safe-setenv)
+   flatten-dot update-free-vars! setenv unsetenv safe-setenv
+   immutable? immutable-string make-immutable!
+   thread-interrupt!
+   chibi-version)
   (import (chibi))
   (include-shared "ast")
   (include "ast.scm"))

lib/chibi/base64-test.sld

@@ -1,6 +1,6 @@
 (define-library (chibi base64-test)
   (export run-tests)
-  (import (chibi) (chibi base64) (chibi test))
+  (import (scheme base) (chibi base64) (chibi string) (chibi test))
   (begin
     (define (run-tests)
       (test-begin "base64")

lib/chibi/base64.scm

@@ -141,18 +141,18 @@
              dst
              j
              (bitwise-ior (arithmetic-shift b1 2)
-                          (extract-bit-field 2 4 b2)))
+                          (bit-field b2 4 6)))
             (bytevector-u8-set!
              dst
              (+ j 1)
              (bitwise-ior
-              (arithmetic-shift (extract-bit-field 4 0 b2) 4)
-              (extract-bit-field 4 2 b3)))
+              (arithmetic-shift (bit-field b2 0 4) 4)
+              (bit-field b3 2 6)))
             (bytevector-u8-set!
              dst
              (+ j 2)
              (bitwise-ior
-              (arithmetic-shift (extract-bit-field 2 0 b3) 6)
+              (arithmetic-shift (bit-field b3 0 2) 6)
               c))
             (lp (+ i 1) (+ j 3)
                 *outside-char* *outside-char* *outside-char*)))))))
@@ -172,7 +172,7 @@
     (bytevector-u8-set! dst
                         j
                         (bitwise-ior (arithmetic-shift b1 2)
-                                     (extract-bit-field 2 4 b2)))
+                                     (bit-field b2 4 6)))
     (cond
      ((eqv? b3 *outside-char*)
       (+ j 1))
@@ -180,8 +180,8 @@
       (bytevector-u8-set! dst
                           (+ j 1)
                           (bitwise-ior
-                           (arithmetic-shift (extract-bit-field 4 0 b2) 4)
-                           (extract-bit-field 4 2 b3)))
+                           (arithmetic-shift (bit-field b2 0 4) 4)
+                           (bit-field b3 2 6)))
       (+ j 2))))))
 
 ;;>  Variation of the above to read and write to ports.
@@ -193,14 +193,15 @@
                  (current-output-port))))
     (cond
      ((not (binary-port? in))
-      (write-string (base64-decode-string (port->string in)) out))
+      (let ((str (port->string in)))
+        (write-string (base64-decode-string str) out)))
      (else
       (let ((src (make-bytevector decode-src-length))
             (dst (make-bytevector decode-dst-length)))
         (let lp ((offset 0))
           (let ((src-len
                  (+ offset
-                    (read-bytevector! decode-src-length src in offset))))
+                    (read-bytevector! src in offset decode-src-length))))
             (cond
              ((= src-len decode-src-length)
               ;; read a full chunk: decode, write and loop
@@ -209,12 +210,12 @@
                (lambda (src-offset dst-len b1 b2 b3)
                  (cond
                   ((and (< src-offset src-len)
-                        (eqv? #\= (string-ref src src-offset)))
+                        (eqv? #x3D (bytevector-u8-ref src src-offset)))
                    ;; done
                    (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
                      (write-bytevector dst out 0 dst-len)))
                   ((eqv? b1 *outside-char*)
-                   (write-string dst out 0 dst-len)
+                   (write-bytevector dst out 0 dst-len)
                    (lp 0))
                   (else
                    (write-bytevector dst out 0 dst-len)
@@ -237,7 +238,7 @@
                src 0 src-len dst
                (lambda (src-offset dst-len b1 b2 b3)
                  (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
-                   (write-string dst out 0 dst-len)))))))))))))
+                   (write-bytevector dst out 0 dst-len)))))))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; encoding
@@ -258,8 +259,7 @@
     res))
 
 (define (base64-encode-bytevector! bv start end res)
-  (let* ((res-len (bytevector-length res))
-         (limit (- end 2)))
+  (let ((limit (- end 2)))
     (let lp ((i start) (j 0))
       (if (>= i limit)
           (case (- end i)
@@ -271,7 +271,8 @@
                 (+ j 1)
                 (enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
                (bytevector-u8-set! res (+ j 2) (char->integer #\=))
-               (bytevector-u8-set! res (+ j 3) (char->integer #\=))))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=))
+               (+ j 4)))
             ((2)
              (let ((b1 (bytevector-u8-ref bv i))
                    (b2 (bytevector-u8-ref bv (+ i 1))))
@@ -281,13 +282,15 @@
                 (+ j 1)
                 (enc (bitwise-ior
                       (arithmetic-shift (bitwise-and #b11 b1) 4)
-                      (extract-bit-field 4 4 b2))))
+                      (bit-field b2 4 8))))
                (bytevector-u8-set!
                 res
                 (+ j 2)
-                (enc (arithmetic-shift (extract-bit-field 4 0 b2)
-                                       2)))
-               (bytevector-u8-set! res (+ j 3) (char->integer #\=)))))
+                (enc (arithmetic-shift (bit-field b2 0 4) 2)))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=))
+               (+ j 4)))
+            (else
+             j))
           (let ((b1 (bytevector-u8-ref bv i))
                 (b2 (bytevector-u8-ref bv (+ i 1)))
                 (b3 (bytevector-u8-ref bv (+ i 2))))
@@ -297,13 +300,13 @@
              (+ j 1)
              (enc (bitwise-ior
                    (arithmetic-shift (bitwise-and #b11 b1) 4)
-                   (extract-bit-field 4 4 b2))))
+                   (bit-field b2 4 8))))
             (bytevector-u8-set!
              res
              (+ j 2)
              (enc (bitwise-ior
-                   (arithmetic-shift (extract-bit-field 4 0 b2) 2)
-                   (extract-bit-field 2 6 b3))))
+                   (arithmetic-shift (bit-field b2 0 4) 2)
+                   (bit-field b3 6 8))))
             (bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
             (lp (+ i 3) (+ j 4)))))))
 
@@ -316,17 +319,19 @@
                  (current-output-port))))
     (cond
      ((not (binary-port? in))
-      (write-string (base64-encode-string (port->string in)) out))
+      (let ((str (port->string in)))
+        (write-string (base64-encode-string str) out)))
      (else
-      (let ((src (make-string encode-src-length))
-            (dst (make-string
+      (let ((src (make-bytevector encode-src-length))
+            (dst (make-bytevector
                   (arithmetic-shift (quotient encode-src-length 3) 2))))
         (let lp ()
           (let ((n (read-bytevector! src in 0 2048)))
             (base64-encode-bytevector! src 0 n dst)
-            (write-bytevector dst out 0 (* 3 (quotient (+ n 3) 4)))
+            (write-bytevector dst out 0 (* 4 (quotient (+ n 2) 3)))
             (if (= n 2048)
-                (lp)))))))))
+                (lp)
+                (flush-output-port out)))))))))
 
 ;;> Return a base64 encoded representation of the string \var{str} as
 ;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
@@ -359,7 +364,7 @@
                (string-append
                 prefix (substring str 0 first-max-col) "?=" nl "\t" prefix)
                "")
-           (string-concatenate (string-chop (substring str first-max-col len)
+           (string-join (string-chop (substring str first-max-col len)
                                      effective-max-col)
                         (string-append "?=" nl "\t" prefix))
            "?=")))))

lib/chibi/base64.sld

@@ -3,6 +3,35 @@
   (export base64-encode base64-encode-string base64-encode-bytevector
           base64-decode base64-decode-string base64-decode-bytevector
           base64-encode-header)
-  (import (scheme base) (srfi 33) (chibi io)
-          (only (chibi) string-concatenate))
+  (import (scheme base)
+          (chibi string))
+  (cond-expand
+   ((library (srfi 151))
+    (import (srfi 151)))
+   ((library (srfi 33))
+    (import (srfi 33))
+    (begin
+      (define (%mask size) (bitwise-not (arithmetic-shift -1 size)))
+      (define (bit-field n start end)
+        (bitwise-and (arithmetic-shift n (- start)) (mask (- end start))))))
+   (else
+    (import (srfi 60))
+    (begin
+      (define (%mask size) (bitwise-not (arithmetic-shift -1 size)))
+      (define (bit-field n start end)
+        (bitwise-and (arithmetic-shift n (- start)) (mask (- end start)))))))
+  (cond-expand
+   (chibi (import (chibi io)))
+   (else
+    (begin
+      (define (port->string in)
+        (let ((out (open-output-string)))
+          (let lp ()
+            (let ((ch (read-char in)))
+              (cond
+               ((eof-object? ch)
+                (get-output-string out))
+               (else
+                (write-char ch out)
+                (lp))))))))))
   (include "base64.scm"))

lib/chibi/binary-record-chicken.scm

@@ -0,0 +1,52 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; binary records, simpler version with type-checking on set! removed
+
+(define-syntax defrec
+  (syntax-rules (make: pred: read: write: block:)
+    ((defrec () n m p r w
+       ((field-tmp field-read field-read-expr field-write field-write-expr field-get) ...)
+       ((field getter . s) ...))
+     (begin
+       (define-record-type n (m field ...) p
+         (field getter . s) ...)
+       (define n 'n)  ; chicken define-record-type doesn't define the rtd
+       (define r
+         (let ((field-read field-read-expr) ...)
+           (lambda (in)
+             (let* ((field-tmp (field-read in)) ...)
+               (m field ...)))))
+       (define w
+         (let ((field-write field-write-expr) ...)
+           (lambda (x out)
+             (field-write (field-get x) out) ...)))))
+    ((defrec ((make: x) . rest) n m p r w b f)
+     (defrec rest n x p r w b f))
+    ((defrec ((pred: x) . rest) n m p r w b f)
+     (defrec rest n m x r w b f))
+    ((defrec ((read: x) . rest) n m p r w b f)
+     (defrec rest n m p x w b f))
+    ((defrec ((write: x) . rest) n m p r w b f)
+     (defrec rest n m p r x b f))
+    ((defrec ((block: (field (type . args) getter . s) . fields) . rest) n m p r w
+       (b ...) (f ...))
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (field read-tmp (type read: args) write-tmp (type write: args) getter))
+       (f ...
+          (field getter . s))))
+    ((defrec ((block: (field . x)) . rest) n m p r w b f)
+     (syntax-error "invalid field in block" (field . x)))
+    ((defrec ((block: data . fields) . rest) n m p r w (b ...) f)
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (tmp-data read-tmp (read-literal 'data) write-tmp (write-literal 'data) (lambda (x) x)))
+       f))
+    ((defrec ((block:) . rest) n m p r w b f)
+     (defrec rest n m p r w b f))
+    ))
+
+(define-syntax define-binary-record-type
+  (syntax-rules ()
+    ((define-binary-record-type name x ...)
+     (defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
+       () ()))))

lib/chibi/binary-record-test.sld

@@ -0,0 +1,31 @@
+
+(define-library (chibi binary-record-test)
+  (export run-tests)
+  (import (scheme base) (chibi binary-record) (chibi test))
+  (begin
+    (define-binary-record-type gif-header
+      (make: make-gif-header)
+      (pred: gif-header?)
+      (read: read-gif-header)
+      (write: write-gif-header)
+      (block:
+       "GIF89a"
+       (width (u16/le) gif-header-width)
+       (height (u16/le) gif-header-height)
+       (gct (u8) gif-header-gct)
+       (bgcolor (u8) gif-header-gbcolor)
+       (aspect-ratio (u8) gif-header-aspect-ratio)
+       ))
+    (define (gif->bytevector gif)
+      (let ((out (open-output-bytevector)))
+        (write-gif-header gif out)
+        (get-output-bytevector out)))
+    (define (bytevector->gif bv)
+      (read-gif-header (open-input-bytevector bv)))
+    (define (run-tests)
+      (test-begin "(chibi binary-record)")
+      (let ((gif (make-gif-header 4096 2160 #xF7 1 2)))
+        (test #u8(#x47 #x49 #x46 #x38 #x39 #x61 0 #x10 #x70 #x08 #xF7 #x01 #x02)
+          (gif->bytevector gif))
+        (test gif (bytevector->gif (gif->bytevector gif))))
+      (test-end))))

lib/chibi/binary-record.scm

@@ -1,300 +1,160 @@
 
-(define (read-u16/be in)
-  (let* ((i (read-u8 in))
-         (j (read-u8 in)))
-    (if (eof-object? j)
-        (error "end of input")
-        (+ (arithmetic-shift i 8) j))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Binary Records
 
-(define (read-u16/le in)
-  (let* ((i (read-u8 in))
-         (j (read-u8 in)))
-    (if (eof-object? j)
-        (error "end of input")
-        (+ (arithmetic-shift j 8) i))))
-
-;; Record types with user-specified binary formats.
-;; A work in progress, but sufficient for tar files.
-
-(define (assert-read-u8 in i)
-  (let ((i2 (read-u8 in)))
-    (if (not (eqv? i i2))
-        (error "unexpected value: " i i2)
-        i2)))
-
-(define (assert-read-char in ch)
-  (let ((ch2 (read-char in)))
-    (if (not (eqv? ch ch2))
-        (error "unexpected value: " ch ch2)
-        ch2)))
-
-(define (assert-read-string in s)
-  (let ((s2 (read-string (string-length s) in)))
-    (if (not (equal? s s2))
-        (error "unexpected value: " s s2)
-        s2)))
-
-(define (assert-read-bytevector in bv)
-  (let ((bv2 (read-bytevector (bytevector-length bv) in)))
-    (if (not (equal? bv bv2))
-        (error "unexpected value: " bv bv2)
-        bv2)))
-
-(define (assert-read-integer in len radix)
-  (let* ((s (string-trim (read-string len in)
-                         (lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
-         (n (if (equal? s "") 0 (string->number s radix))))
-    (or n (error "invalid number syntax: " s))))
-
-(define (read-padded-string in len pad)
-  (string-trim-right (read-string len in) pad))
-
-(define (expand-read rename in spec)
-  (case (car spec)
-    ((literal)
-     (let ((val (cadr spec)))
-       (cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
-             ((char? val) `(,(rename 'assert-read-char) ,in ,val))
-             ((string? val) `(,(rename 'assert-read-string) ,in ,val))
-             ((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
-             (else (error "unknown binary literal: " val)))))
-    ((u8)
-     `(,(rename 'read-u8) ,in))
-    ((u16/be)
-     `(,(rename 'read-u16/be) ,in))
-    ((u16/le)
-     `(,(rename 'read-u16/le) ,in))
-    ((octal)
-     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
-    ((decimal)
-     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
-    ((hexadecimal)
-     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
-    ((fixed-string)
-     (let ((len (cadr spec)))
-       `(,(rename 'read-string) ,len ,in)))
-    ((padded-string)
-     (let ((len (cadr spec))
-           (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
-       `(,(rename 'read-padded-string) ,in ,len ,pad)))
-    (else
-     (error "unknown binary format: " spec))))
-
-(define (string-pad-left str len . o)
-  (let ((diff (- len (string-length str)))
-        (pad-ch (if (pair? o) (car o) #\space)))
-    (if (positive? diff)
-        (string-append (make-string diff pad-ch) str)
-        str)))
-
-(define (string-pad-right str len . o)
-  (let ((diff (- len (string-length str)))
-        (pad-ch (if (pair? o) (car o) #\space)))
-    (if (positive? diff)
-        (string-append str (make-string diff pad-ch))
-        str)))
-
-(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
-  (let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch)))
-    (cond
-     ((>= (string-length s) len)
-      (error "number too large for width" n radix len))
-     (else
-      (write-string s out)
-      (write-char right-pad-ch out)))))
-
-(define (write-u16/be n out)
-  (write-u8 (arithmetic-shift n -8) out)
-  (write-u8 (bitwise-and n #xFF) out))
-
-(define (write-u16/le n out)
-  (write-u8 (bitwise-and n #xFF) out)
-  (write-u8 (arithmetic-shift n -8) out))
-
-(define (expand-write rename out val spec)
-  (let ((_if (rename 'if))
-        (_not (rename 'not))
-        (_let (rename 'let))
-        (_string-length (rename 'string-length))
-        (_write-string (rename 'write-string))
-        (_write-bytevector (rename 'write-bytevector))
-        (_error (rename 'error))
-        (_> (rename '>))
-        (_= (rename '=)))
-    (case (car spec)
-      ((literal)
-       (let ((val (cadr spec)))
-         (cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
-               ((char? val) `(,(rename 'write-char) ,val ,out))
-               ((string? val) `(,_write-string ,val ,out))
-               ((bytevector? val) `(,_write-bytevector ,val ,out))
-               (else (error "unknown binary literal: " val)))))
-      ((u8)
-       `(,(rename 'write-u8) ,val ,out))
-      ((u16/be)
-       `(,(rename 'write-u16/be) ,val ,out))
-      ((u16/le)
-       `(,(rename 'write-u16/le) ,val ,out))
-      ((octal)
-       `(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
-      ((decimal)
-       `(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
-      ((hexadecimal)
-       `(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
-      ((fixed-string)
-       (let ((len (cadr spec)))
-         `(,_if (,_not (,_= ,len (,_string-length ,val)))
-              (,_error "wrong field length: " ,val ,len)
-              (,_write-string ,val ,out))))
-      ((padded-string)
-       (let ((len (cadr spec))
-             (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
-         `(,_let ((l (,_string-length ,val)))
-            (,_if (,_> l ,len)
-                (,_error "field too large: " ,val ,len)
-                (,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
-                                ,out)))))
-      (else
-       (error "unknown binary format: " spec)))))
-
-(define (expand-assert rename spec x v)
-  (let ((_if (rename 'if))
-        (_not (rename 'not))
-        (_error (rename 'error))
-        (_integer? (rename 'integer?))
-        (_string? (rename 'string?))
-        (_string-length (rename 'string-length))
-        (_> (rename '>)))
-    (case (car spec)
-      ((literal) #t)
-      ((u8 u16/be u16/le octal decimal hexadecimal)
-       `(,_if (,_not (,_integer? ,v))
-            (,_error "expected an integer" ,v)))
-      ((fixed-string padded-string)
-       (let ((len (cadr spec)))
-         `(,_if (,_not (,_string? ,v))
-              (,_error "expected a string" ,v)
-              (,_if (,_> (,_string-length ,v) ,len)
-                  (,_error "string too long" ,v ,len)))))
-      (else (error "unknown binary format: " spec)))))
-
-(define (expand-default rename spec)
-  (case (car spec)
-    ((literal) (cadr spec))
-    ((u8 u16/be u16/le octal decimal hexadecimal) 0)
-    ((fixed-string) (make-string (cadr spec) #\space))
-    ((padded-string) "")
-    (else (error "unknown binary format: " spec))))
-
-(define (param-ref ls key . o)
-  (cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
-
-(define (symbol-append a b)
-  (string->symbol (string-append (symbol->string a) (symbol->string b))))
-
-(define-record-type Field
-  (make-field name get set raw-set spec)
-  field?
-  (name field-name)
-  (get field-get)
-  (set field-set)
-  (raw-set field-raw-set)
-  (spec field-spec))
-
-(define (extract-fields type ls)
-  (let lp ((ls ls) (res '()))
-    (cond
-     ((null? ls)
-      (reverse res))
-     ((not (pair? (car ls)))
-      (lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
-     (else
-      (let* ((name (caar ls))
-             (get (or (param-ref (car ls) 'getter)
-                      (and (not (eq? name '_))
-                           (symbol-append type (symbol-append '- name)))))
-             (set (or (param-ref (car ls) 'setter)
-                      (and (not (eq? name '_))
-                           (symbol-append (symbol-append type '-)
-                                          (symbol-append name '-set!)))))
-             (raw-set (and set (symbol-append '% set)))
-             (spec0 (cadr (car ls)))
-             (spec (if (pair? spec0) spec0 (list spec0))))
-        (lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
+;;> \macro{(define-binary-record-type <name> [<bindings> ...] (block: <fields> ...))}
+;;>
+;;> Defines a new record type that supports serializing to and from
+;;> binary ports.  The generated procedures accept keyword-style
+;;> arguments:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{(make: <constructor-name>)}}
+;;> \item{\scheme{(pred: <predicate-name>)}}
+;;> \item{\scheme{(read: <reader-name>)}}
+;;> \item{\scheme{(write: <writer-name>)}}
+;;> \item{\scheme{(block: <fields> ...)}}
+;;> ]
+;;>
+;;> The fields are also similar to \scheme{define-record-type} but
+;;> with an additional type:
+;;>
+;;> \scheme{(field (type args ...) getter setter)}
+;;>
+;;> Built-in types include:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{(u8)} - a single byte in [0, 255]}
+;;> \item{\scheme{(u16/le)} - a little-endian short integer}
+;;> \item{\scheme{(u16/be)} - a big-endian short integer}
+;;> \item{\scheme{(fixed-string <length>)} - a fixed-length utf-8 string}
+;;> \item{\scheme{(padded-string <length> (pad <pad-char>))} - a utf-8 string padded to a given length}
+;;> \item{\scheme{(octal <length>)} - an integer in octal string format}
+;;> \item{\scheme{(decimal <length>)} - an integer in decimal string format}
+;;> \item{\scheme{(hexadecimal <length>)} - an integer in hexadecimal string format}
+;;> ]
+;;>
+;;> In addition, the field can be a literal (char, string or
+;;> bytevector), for instance as a file magic sequence or fixed
+;;> separator.  The fields (and any constants) are serialized in the
+;;> order they appear in the block.  For example, the header of a GIF
+;;> file could be defined as:
+;;>
+;;> \example{
+;;>  (define-binary-record-type gif-header
+;;>    (make: make-gif-header)
+;;>    (pred: gif-header?)
+;;>    (read: read-gif-header)
+;;>    (write: write-gif-header)
+;;>    (block:
+;;>     "GIF89a"
+;;>     (width (u16/le) gif-header-width)
+;;>     (height (u16/le) gif-header-height)
+;;>     (gct (u8) gif-header-gct)
+;;>     (bgcolor (u8) gif-header-gbcolor)
+;;>     (aspect-ratio (u8) gif-header-aspect-ratio)
+;;>     ))
+;;> }
+;;>
+;;> For a more complex example see the \scheme{(chibi tar)}
+;;> implementation.
+;;>
+;;> The binary type itself is a macro used to expand to a predicate
+;;> and reader/writer procedures, which can be defined with
+;;> \scheme{define-binary-type}.  For example,
+;;>
+;;> \example{
+;;>  (define-binary-type (u8)
+;;>    (lambda (x) (and (exact-integer? x) (<= 0 x 255)))
+;;>    read-u8
+;;>    write-u8)
+;;> }
 
 (define-syntax define-binary-record-type
-  (er-macro-transformer
-   (lambda (expr rename compare)
-     (let ((name (cadr expr))
-           (ls (cddr expr)))
-       (if (not (and (identifier? name) (every list? ls)))
-           (error "invalid syntax: " expr))
-       (let* ((type (or (param-ref ls 'type) (symbol-append 'type- name)))
-              (pred (or (param-ref ls 'predicate) (symbol-append name '?)))
-              (make (or (param-ref ls 'make) (symbol-append 'make- name)))
-              (make-spec (if (pair? make) make (list make)))
-              (%make (rename (symbol-append '% (car make-spec))))
-              (%%make (rename (symbol-append '%% (car make-spec))))
-              (reader (or (param-ref ls 'read) (symbol-append 'read- name)))
-              (writer (or (param-ref ls 'write) (symbol-append 'write- name)))
-              (block (assq 'block ls))
-              (_begin (rename 'begin))
-              (_define (rename 'define))
-              (_define-record-type (rename 'define-record-type))
-              (_let (rename 'let)))
-         (if (not block)
-             (error "missing binary record block: " expr))
-         (let* ((fields (extract-fields name (cdr block)))
-                (named-fields (filter (lambda (f) (not (eq? '_ (field-name f))))
-                                      fields)))
-           `(,_begin
-             (,_define ,name ',ls)
-             (,_define-record-type
-              ,type (,%%make) ,pred
-              ,@(map
-                 (lambda (f)
-                   `(,(field-name f) ,(field-get f) ,(field-raw-set f)))
-                 named-fields))
-             ,@(map
-                (lambda (f)
-                  `(,_define (,(field-set f) x v)
-                     ,(expand-assert rename (field-spec f) 'x 'v)
-                     (,(field-raw-set f) x v)))
-                named-fields)
-             (,_define (,%make)
-               (let ((res (,%%make)))
-                 ,@(map
-                    (lambda (f)
-                      `(,(field-raw-set f)
-                        res
-                        ,(expand-default rename (field-spec f))))
-                    named-fields)
-                 res))
-             (,_define ,make-spec
-               (,_let ((res (,%make)))
-                 ,@(map
-                    (lambda (x)
-                      (let ((field (find (lambda (f) (eq? x (field-name f)))
-                                         fields)))
-                        `(,(field-set field) res ,x)))
-                    (cdr make-spec))
-                 res))
-             (,_define (,reader in)
-               (,_let ((res (,%make)))
-                 ,@(map
-                    (lambda (f)
-                      (if (eq? '_ (field-name f))
-                          (expand-read rename 'in (field-spec f))
-                          `(,(field-set f)
-                            res
-                            ,(expand-read rename 'in (field-spec f)))))
-                    fields)
-                 res))
-             (,_define (,writer x out)
-               ,@(map
-                  (lambda (f)
-                    (expand-write rename
-                                  'out
-                                  `(,(field-get f) x)
-                                  (field-spec f)))
-                  fields)))))))))
+  (syntax-rules ()
+    ((define-binary-record-type name x ...)
+     (defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
+       () () ()))))
+
+(define-syntax defrec
+  (syntax-rules (make: pred: read: write: block:)
+    ((defrec () n m p r w
+       ((field-tmp field-read field-read-expr field-write field-write-expr field-get) ...)
+       ((field getter . s) ...)
+       (def-setter ...))
+     (begin
+       (define-record-type n (m field ...) p
+         (field getter . s) ...)
+       (define r
+         (let ((field-read field-read-expr) ...)
+           (lambda (in)
+             (let* ((field-tmp (field-read in)) ...)
+               (m field ...)))))
+       (define w
+         (let ((field-write field-write-expr) ...)
+           (lambda (x out)
+             (field-write (field-get x) out) ...)))
+       def-setter ...)
+     ;; workaround for impls which strip hygiene from top-level defs
+     ;; for some reason, works in chicken but not across libraries
+     ;;
+     ;; (begin
+     ;;   (define-values (n m p getter ... setter ...)
+     ;;     (let ()
+     ;;       (define-record-type n (m field ...) p
+     ;;         (field getter . s) ...)
+     ;;       (def setter val) ...
+     ;;       (values (record-rtd n) m p getter ... setter ...)))
+     ;;   (define r
+     ;;     (let ((field-read field-read-expr) ...)
+     ;;       (lambda (in)
+     ;;         (let* ((field-tmp (field-read in)) ...)
+     ;;           (m field ...)))))
+     ;;   (define w
+     ;;     (let ((field-write field-write-expr) ...)
+     ;;       (lambda (x out)
+     ;;         (field-write (field-get x) out) ...))))
+     )
+    ((defrec ((make: x) . rest) n m p r w b f s)
+     (defrec rest n x p r w b f s))
+    ((defrec ((pred: x) . rest) n m p r w b f s)
+     (defrec rest n m x r w b f s))
+    ((defrec ((read: x) . rest) n m p r w b f s)
+     (defrec rest n m p x w b f s))
+    ((defrec ((write: x) . rest) n m p r w b f s)
+     (defrec rest n m p r x b f s))
+    ((defrec ((block: (field (type . args) getter setter) . fields) . rest) n m p r w b f s)
+     (defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w b f s))
+    ((defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w
+       (b ...) (f ...) (s ...))
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (field read-tmp (type read: args) write-tmp (type write: args) getter))
+       (f ...
+          (field getter tmp-setter))
+       (s ...
+          (define setter
+            (let ((pred? (type pred: args)))
+              (lambda (x val)
+                (if (not (pred? val))
+                    (error "invalid val for" 'field val))
+                (tmp-setter x val)))))))
+    ((defrec ((block: (field (type . args) getter) . fields) . rest) n m p r w
+       (b ...) (f ...) s)
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (field read-tmp (type read: args) write-tmp (type write: args) getter))
+       (f ...
+          (field getter))
+       s))
+    ((defrec ((block: (field . x)) . rest) n m p r w b f s)
+     (syntax-error "invalid field in block" (field . x)))
+    ((defrec ((block: data . fields) . rest) n m p r w (b ...) f s)
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (tmp-data read-tmp (read-literal 'data) write-tmp (write-literal 'data) (lambda (x) x)))
+       f
+       s))
+    ((defrec ((block:) . rest) n m p r w b f s)
+     (defrec rest n m p r w b f s))
+    ))

lib/chibi/binary-record.sld

@@ -1,11 +1,46 @@
 
 (define-library (chibi binary-record)
-  (import (scheme base)
-          (srfi 1) (srfi 9)
-          (chibi io) (chibi string)
-          (only (chibi) identifier? er-macro-transformer))
+  (import (scheme base) (srfi 1))
   (cond-expand
-   ((library (srfi 60)) (import (srfi 60)))
-   (else (import (srfi 33))))
-  (export define-binary-record-type)
-  (include "binary-record.scm"))
+   ((library (srfi 151)) (import (srfi 151)))
+   ((library (srfi 33)) (import (srfi 33)))
+   (else (import (srfi 60))))
+  (cond-expand
+   ((library (srfi 130)) (import (srfi 130)))
+   (else (import (srfi 13))))
+  (cond-expand
+   ;; ((library (auto))
+   ;;  (import (only (auto) make: pred: read: write: block:)))
+   (else
+    ;; indirect exports for chicken
+    (export defrec define-auxiliary-syntax syntax-let-optionals*)
+    (begin
+      (define-syntax define-auxiliary-syntax
+        (syntax-rules ()
+          ((define-auxiliary-syntax name)
+           (define-syntax name
+             (syntax-rules ()
+               ((name . x)
+                (syntax-error "invalid use of auxiliary syntax"
+                              (name . x))))))))
+      (define-auxiliary-syntax make:)
+      (define-auxiliary-syntax pred:)
+      (define-auxiliary-syntax read:)
+      (define-auxiliary-syntax write:)
+      (define-auxiliary-syntax block:))))
+  (export
+   ;; interface
+   define-binary-record-type
+   ;; binary types
+   u8 u16/le u16/be padded-string fixed-string
+   octal decimal hexadecimal
+   ;; auxiliary syntax
+   make: pred: read: write: block:
+   ;; new types
+   define-binary-type)
+  (include "binary-types.scm")
+  (cond-expand
+   (chicken
+    (include "binary-record-chicken.scm"))
+   (else
+    (include "binary-record.scm"))))

lib/chibi/binary-types.scm

@@ -0,0 +1,160 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define (read-u16/be in)
+  (let* ((i (read-u8 in))
+         (j (read-u8 in)))
+    (if (eof-object? j)
+        (error "end of input")
+        (+ (arithmetic-shift i 8) j))))
+
+(define (read-u16/le in)
+  (let* ((i (read-u8 in))
+         (j (read-u8 in)))
+    (if (eof-object? j)
+        (error "end of input")
+        (+ (arithmetic-shift j 8) i))))
+
+(define (assert-read-u8 in i)
+  (let ((i2 (read-u8 in)))
+    (if (not (eqv? i i2))
+        (error "unmatched value, expected: " i " but got: " i2)
+        i2)))
+
+(define (assert-read-char in ch)
+  (let ((ch2 (read-char in)))
+    (if (not (eqv? ch ch2))
+        (error "unmatched value, expected: " ch " but got: " ch2)
+        ch2)))
+
+(define (assert-read-string in s)
+  (let ((s2 (read-string (string-length s) in)))
+    (if (not (equal? s s2))
+        (error "unmatched value, expected: " s " but got: " s2)
+        s2)))
+
+(define (assert-read-bytevector in bv)
+  (let ((bv2 (read-bytevector (bytevector-length bv) in)))
+    (if (not (equal? bv bv2))
+        (error "unmatched value, expected: " bv " but got: " bv2)
+        bv2)))
+
+(define (assert-read-integer in len radix)
+  (let* ((s (string-trim-both (read-string len in)
+                              (lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
+         (n (if (equal? s "") 0 (string->number s radix))))
+    (or n (error "invalid number syntax: " s))))
+
+(define (read-padded-string in len pad)
+  (string-trim-right (read-string len in) pad))
+
+(define (read-literal val)
+  (cond
+   ((integer? val) (lambda (in) (assert-read-u8 in val)))
+   ((char? val) (lambda (in) (assert-read-char in val)))
+   ((string? val) (lambda (in) (assert-read-string in val)))
+   ((bytevector? val) (lambda (in) (assert-read-bytevector in val)))
+   (else (error "unknown binary literal: " val))))
+
+(define (write-literal val)
+  (cond
+   ((integer? val) (lambda (x out) (write-u8 val out)))
+   ((char? val) (lambda (x out) (write-char val out)))
+   ((string? val) (lambda (x out) (write-string val out)))
+   ((bytevector? val) (lambda (x out) (write-bytevector val out)))
+   (else (error "unknown binary literal: " val))))
+
+(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
+  (let ((s (string-pad (number->string n radix) (- len 1) left-pad-ch)))
+    (cond
+     ((>= (string-length s) len)
+      (error "number too large for width" n radix len))
+     (else
+      (write-string s out)
+      (write-char right-pad-ch out)))))
+
+(define (write-u16/be n out)
+  (write-u8 (arithmetic-shift n -8) out)
+  (write-u8 (bitwise-and n #xFF) out))
+
+(define (write-u16/le n out)
+  (write-u8 (bitwise-and n #xFF) out)
+  (write-u8 (arithmetic-shift n -8) out))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syntax
+
+(define-syntax syntax-let-optionals*
+  (syntax-rules ()
+    ((syntax-let-optionals* () type-args expr)
+     expr)
+    ((syntax-let-optionals* ((param default) . rest) (arg0 . args) expr)
+     (let ((param arg0))
+       (syntax-let-optionals* rest args expr)))
+    ((syntax-let-optionals* ((param default) . rest) () expr)
+     (let ((param default))
+       (syntax-let-optionals* rest () expr)))
+    ((syntax-let-optionals* (param . rest) (arg0 . args) expr)
+     (let ((param arg0))
+       (syntax-let-optionals* rest args expr)))
+    ((syntax-let-optionals* (param . rest) () expr)
+     (syntax-error "missing required parameter" param expr))))
+
+(define-syntax define-binary-type
+  (syntax-rules ()
+    ((define-binary-type (name params ...) gen-pred gen-read gen-write)
+     (define-syntax name
+       (syntax-rules (pred: read: write:)
+         ((name pred: type-args)
+          (syntax-let-optionals* (params ...) type-args gen-pred))
+         ((name read: type-args)
+          (syntax-let-optionals* (params ...) type-args gen-read))
+         ((name write: type-args)
+          (syntax-let-optionals* (params ...) type-args gen-write)))))))
+
+(define-binary-type (u8)
+  (lambda (x) (and (exact-integer? x) (<= 0 x 255)))
+  read-u8
+  write-u8)
+
+(define-binary-type (u16/le)
+  (lambda (x) (and (exact-integer? x) (<= 0 x 65536)))
+  read-u16/le
+  write-u16/le)
+
+(define-binary-type (u16/be)
+  (lambda (x) (and (exact-integer? x) (<= 0 x 65536)))
+  read-u16/be
+  write-u16/be)
+
+(define-binary-type (padded-string len (pad #\null))
+  (lambda (x) (and (string? x) (<= (string-length x) len)))
+  (lambda (in) (read-padded-string in len pad))
+  (lambda (str out)
+    (write-string (string-pad-right str len pad) out)))
+
+(define-binary-type (fixed-string len)
+  (lambda (x) (and (string? x) (= (string-length x) len)))
+  (lambda (in)
+    (read-string len in))
+  (lambda (str out)
+    (write-string str out)))
+
+(define-binary-type (octal len)
+  exact-integer?
+  (lambda (in) (assert-read-integer in len 8))
+  (lambda (n out)
+    (write-padded-integer out n 8 len #\0 #\null)))
+
+(define-binary-type (decimal len)
+  exact-integer?
+  (lambda (in) (assert-read-integer in len 10))
+  (lambda (n out)
+    (write-padded-integer out n 10 len #\0 #\null)))
+
+(define-binary-type (hexadecimal len)
+  exact-integer?
+  (lambda (in) (assert-read-integer in len 16))
+  (lambda (n out)
+    (write-padded-integer out n 16 len #\0 #\null)))

lib/chibi/bytevector-test.sld

@@ -0,0 +1,81 @@
+
+(define-library (chibi bytevector-test)
+  (export run-tests)
+  (import (scheme base) (chibi bytevector) (chibi test))
+  (begin
+
+    (define floats
+      `(0.0 -1.0 #i1/3 1.192092896E-07 ,(+ 1 1.192092896E-07)
+        1e-23 -1e-23
+        3.40282346638528860e+38 -3.40282346638528860e+38
+        1.40129846432481707e-45 -1.40129846432481707e-45
+        3.14159265358979323846))
+
+    (define f32-le
+      '#u8(#x00 #x00 #x00 #x00 #x00 #x00 #x80 #xbf
+           #xab #xaa #xaa #x3e #x00 #x00 #x00 #x34
+           #x01 #x00 #x80 #x3f #x9a #x6d #x41 #x19
+           #x9a #x6d #x41 #x99 #xff #xff #x7f #x7f
+           #xff #xff #x7f #xff #x01 #x00 #x00 #x00
+           #x01 #x00 #x00 #x80 #xdb #x0f #x49 #x40))
+
+    (define f64-le
+      '#u8(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
+           #x00 #x00 #x00 #x00 #x00 #x00 #xf0 #xbf
+           #x55 #x55 #x55 #x55 #x55 #x55 #xd5 #x3f
+           #x68 #x5f #x1c #x00 #x00 #x00 #x80 #x3e
+           #x00 #x00 #x00 #x20 #x00 #x00 #xf0 #x3f
+           #x51 #xb2 #x12 #x40 #xb3 #x2d #x28 #x3b
+           #x51 #xb2 #x12 #x40 #xb3 #x2d #x28 #xbb
+           #x00 #x00 #x00 #xe0 #xff #xff #xef #x47
+           #x00 #x00 #x00 #xe0 #xff #xff #xef #xc7
+           #x00 #x00 #x00 #x00 #x00 #x00 #xa0 #x36
+           #x00 #x00 #x00 #x00 #x00 #x00 #xa0 #xb6
+           #x18 #x2d #x44 #x54 #xfb #x21 #x09 #x40))
+
+    (define (run-tests)
+      (test-begin "bytevector")
+
+      (test-group "reading ieee"
+
+        (do ((ls floats (cdr ls))
+            (i 0 (+ i 4)))
+           ((null? ls))
+         (test (car ls) (bytevector-ieee-single-native-ref f32-le i)))
+
+       (do ((ls floats (cdr ls))
+            (i 0 (+ i 8)))
+           ((null? ls))
+         (test (car ls) (bytevector-ieee-double-native-ref f64-le i))))
+
+      (test-group "writing ieee"
+
+        (do ((ls floats (cdr ls))
+            (i 0 (+ i 4)))
+           ((null? ls))
+         (let ((bv (make-bytevector 4 0)))
+           (bytevector-ieee-single-native-set! bv 0 (car ls))
+           (test (bytevector-copy f32-le i (+ i 4)) (values bv))))
+
+        (do ((ls floats (cdr ls))
+            (i 0 (+ i 8)))
+           ((null? ls))
+         (let ((bv (make-bytevector 8 0)))
+           (bytevector-ieee-double-native-set! bv 0 (car ls))
+           ;;(test (bytevector-copy f64-le i (+ i 8)) (values bv))
+           (test (car ls)
+             (bytevector-ieee-double-native-ref bv 0)))))
+
+      (test-group "ber integers"
+        (do ((ls '(0 1 128 16383 32767
+                   18446744073709551615
+                   340282366920938463463374607431768211456)
+                 (cdr ls)))
+            ((null? ls))
+          (let ((bv (make-bytevector 256)))
+            (do ((offsets '(0 1 27) (cdr offsets)))
+                ((null? offsets))
+              (bytevector-ber-set! bv (car ls) (car offsets))
+              (test (car ls) (bytevector-ber-ref bv (car offsets)))))))
+
+      (test-end))))

lib/chibi/bytevector.scm

@@ -33,6 +33,46 @@
      (arithmetic-shift (bytevector-u8-ref bv (+ i 2)) 8)
      (bytevector-u8-ref bv (+ i 3))))
 
+;;> \section{Bignum encodings}
+
+;;> A BER compressed integer (X.209) is an unsigned integer in base 128,
+;;> most significant digit first, where the high bit is set on all but the
+;;> final (least significant) byte.  Thus any size integer can be
+;;> encoded, but the encoding is efficient and small integers don't take
+;;> up any more space than they would in normal char/short/int encodings.
+
+(define (bytevector-ber-ref bv . o)
+  (let ((end (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (bytevector-length bv))))
+    (let lp ((acc 0) (i (if (pair? o) (car o) 0)))
+      (if (>= i end)
+          (error "unterminated ber integer in bytevector" bv)
+          (let ((b (bytevector-u8-ref bv i)))
+            (if (< b 128)
+                (+ acc b)
+                (lp (arithmetic-shift (+ acc (bitwise-and b 127)) 7)
+                    (+ i 1))))))))
+
+(define (bytevector-ber-set! bv n . o)
+  ;;(assert (integer? number) (not (negative? number)))
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (bytevector-length bv))))
+    (let lp ((n (arithmetic-shift n -7))
+             (ls (list (bitwise-and n 127))))
+      (if (zero? n)
+          (do ((i start (+ i 1))
+               (ls ls (cdr ls)))
+              ((null? ls))
+            (if (>= i end)
+                (error "integer doesn't fit in bytevector as ber"
+                       bv n start end)
+                (bytevector-u8-set! bv i (car ls))))
+          (lp (arithmetic-shift n -7)
+              (cons (+ 128 (bitwise-and n 127)) ls))))))
+
 ;;> \section{Integer conversion}
 
 ;;> Convert an unsigned integer \var{n} to a bytevector representing

lib/chibi/bytevector.sld

@@ -5,12 +5,37 @@
   (export
    bytevector-u16-ref-le bytevector-u16-ref-be
    bytevector-u32-ref-le bytevector-u32-ref-be
+   bytevector-ber-ref bytevector-ber-set!
    bytevector-pad-left
    integer->bytevector bytevector->integer
    integer->hex-string hex-string->integer
-   bytevector->hex-string hex-string->bytevector)
-  (import (scheme base))
+   bytevector->hex-string hex-string->bytevector
+   bytevector-ieee-single-ref
+   bytevector-ieee-single-native-ref
+   bytevector-ieee-single-set!
+   bytevector-ieee-single-native-set!
+   bytevector-ieee-double-ref
+   bytevector-ieee-double-native-ref
+   bytevector-ieee-double-set!
+   bytevector-ieee-double-native-set!
+   )
+  (import (scheme base) (scheme inexact))
   (cond-expand
-   ((library (srfi 60)) (import (srfi 60)))
-   (else (import (srfi 33))))
-  (include "bytevector.scm"))
+   (big-endian
+    (begin
+      (define-syntax native-endianness
+        (syntax-rules () ((_) 'big)))))
+   (else
+    (begin
+      (define-syntax native-endianness
+        (syntax-rules () ((_) 'little))))))
+  (cond-expand
+   ((library (srfi 151)) (import (srfi 151)))
+   ((library (srfi 33)) (import (srfi 33)))
+   (else (import (srfi 60))))
+  (include "bytevector.scm")
+  (cond-expand
+   (chibi
+    (import (except (scheme bytevector) bytevector-copy!)))
+   (else
+    (include "ieee-754.scm"))))

lib/chibi/char-set/ascii.scm

@@ -1,42 +1,42 @@
 ;; char-set:lower-case
-(define char-set:lower-case (immutable-char-set (%make-iset 97 122 #f #f #f)))
+(define char-set:lower-case (immutable-char-set (%make-iset 97 127 67108863 #f #f)))
 
 ;; char-set:upper-case
-(define char-set:upper-case (immutable-char-set (%make-iset 65 90 #f #f #f)))
+(define char-set:upper-case (immutable-char-set (%make-iset 65 127 67108863 #f #f)))
 
 ;; char-set:title-case
 (define char-set:title-case (immutable-char-set (%make-iset 0 0 0 #f #f)))
 
 ;; char-set:letter
-(define char-set:letter (immutable-char-set (%make-iset 97 122 #f (%make-iset 65 90 #f #f #f) #f)))
+(define char-set:letter (immutable-char-set (%make-iset 65 127 288230371923853311 #f #f)))
 
 ;; char-set:punctuation
-(define char-set:punctuation (immutable-char-set (%make-iset 63 64 #f (%make-iset 44 47 #f (%make-iset 37 42 #f (%make-iset 33 35 #f #f #f) #f) (%make-iset 58 59 #f #f #f)) (%make-iset 123 123 #f (%make-iset 95 95 #f (%make-iset 91 93 #f #f #f) #f) (%make-iset 125 125 #f #f #f)))))
+(define char-set:punctuation (immutable-char-set (%make-iset 33 127 6189700203056200029306911735 #f #f)))
 
 ;; char-set:symbol
-(define char-set:symbol (immutable-char-set (%make-iset 94 94 #f (%make-iset 43 43 #f (%make-iset 36 36 #f #f #f) (%make-iset 60 62 #f #f #f)) (%make-iset 124 124 #f (%make-iset 96 96 #f #f #f) (%make-iset 126 126 #f #f #f)))))
+(define char-set:symbol (immutable-char-set (%make-iset 36 127 1547425050547877224499904641 #f #f)))
 
 ;; char-set:blank
-(define char-set:blank (immutable-char-set (%make-iset 32 32 #f (%make-iset 9 9 #f #f #f) #f)))
+(define char-set:blank (immutable-char-set (%make-iset 9 32 8388609 #f #f)))
 
 ;; char-set:whitespace
-(define char-set:whitespace (immutable-char-set (%make-iset 32 32 #f (%make-iset 9 13 #f #f #f) #f)))
+(define char-set:whitespace (immutable-char-set (%make-iset 9 127 8388639 #f #f)))
 
 ;; char-set:digit
 (define char-set:digit (immutable-char-set (%make-iset 48 57 #f #f #f)))
 
 ;; char-set:letter+digit
-(define char-set:letter+digit (immutable-char-set (%make-iset 65 90 #f (%make-iset 48 57 #f #f #f) (%make-iset 97 122 #f #f #f))))
+(define char-set:letter+digit (immutable-char-set (%make-iset 48 127 37778931308803301180415 #f #f)))
 
 ;; char-set:hex-digit
-(define char-set:hex-digit (immutable-char-set (%make-iset 65 70 #f (%make-iset 48 57 #f #f #f) (%make-iset 97 102 #f #f #f))))
+(define char-set:hex-digit (immutable-char-set (%make-iset 48 102 35465847073801215 #f #f)))
 
 ;; char-set:iso-control
-(define char-set:iso-control (immutable-char-set (%make-iset 127 127 #f (%make-iset 0 31 #f #f #f) #f)))
+(define char-set:iso-control (immutable-char-set (%make-iset 0 127 170141183460469231731687303720179073023 #f #f)))
 
 ;; char-set:graphic
-(define char-set:graphic (immutable-char-set (%make-iset 33 126 #f #f #f)))
+(define char-set:graphic (immutable-char-set (%make-iset 33 127 19807040628566084398385987583 #f #f)))
 
 ;; char-set:printing
-(define char-set:printing (immutable-char-set (%make-iset 32 126 #f (%make-iset 9 13 #f #f #f) #f)))
+(define char-set:printing (immutable-char-set (%make-iset 9 127 332306998946228968225951765061697567 #f #f)))
 

lib/chibi/char-set/extras.scm

@@ -2,9 +2,11 @@
 (define (char-set . args)
   (list->char-set args))
 
-;; This is a mistake in the SRFI-14 design - end should be inclusive.
-(define (ucs-range->char-set start end)
-  (make-iset start (- end 1)))
+(define (ucs-range->char-set start end . o)
+  (let ((res (make-iset start (- end 1))))
+    (if (and (pair? o) (pair? (cdr o)))
+        (iset-union res (cadr o))
+        res)))
 
 (define char-set-copy iset-copy)
 
@@ -16,8 +18,8 @@
 (define (char-set-for-each proc cset)
   (iset-for-each (lambda (i) (proc (integer->char i))) cset))
 
-(define (list->char-set ls)
-  (list->iset (map char->integer ls)))
+(define (list->char-set ls . o)
+  (apply list->iset (map char->integer ls) o))
 (define (char-set->list cset)
   (map integer->char (iset->list cset)))
 
@@ -26,10 +28,10 @@
 (define (char-set->string cset)
   (list->string (char-set->list cset)))
 
-(define (char-set-adjoin! cset ch)
-  (iset-adjoin! cset (char->integer ch)))
-(define (char-set-adjoin cset ch)
-  (iset-adjoin cset (char->integer ch)))
+(define (char-set-adjoin! cset . o)
+  (apply iset-adjoin! cset (map char->integer o)))
+(define (char-set-adjoin cset . o)
+  (apply iset-adjoin cset (map char->integer o)))
 
 (define char-set-union iset-union)
 (define char-set-union! iset-union!)

lib/chibi/config.scm

@@ -76,13 +76,18 @@
 ;;> Returns true iff \var{x} is a config object.
 
 (define-record-type Config
-  (make-conf alist parent source timestamp)
+  (%make-conf alist parent source timestamp)
   conf?
   (alist conf-alist conf-alist-set!)
   (parent conf-parent conf-parent-set!)
   (source conf-source conf-source-set!)
   (timestamp conf-timestamp conf-timestamp-set!))
 
+(define (make-conf alist parent source timestamp)
+  (if (not (alist? alist))
+      (error "config requires an alist" alist)
+      (%make-conf alist parent source timestamp)))
+
 (define (assq-tail key alist)
   (let lp ((ls alist))
     (and (pair? ls)
@@ -106,7 +111,12 @@
      (else (lp (cdr ls) (cons (car ls) rev))))))
 
 (define (read-from-file file . opt)
-  (guard (exn (else (and (pair? opt) (car opt))))
+  (guard (exn
+          (else
+           (warn "couldn't load config:" file)
+           (print-exception exn)
+           (print-stack-trace exn)
+           (and (pair? opt) (car opt))))
     (call-with-input-file file read)))
 
 (define (alist? x)
@@ -451,7 +461,7 @@
               (every* (lambda (x)
                         (and (pair? x)
                              (conf-verify-match key-def (car x) warn)
-                             (conf-verify-match val-def (cell-value x) warn)))
+                             (conf-verify-match val-def (cell-value) warn)))
                       (cell-list)))))
       ((conf)
        (and (alist? (cell-list))

lib/chibi/config.sld

@@ -10,6 +10,18 @@
   ;; This is only used for config verification, it's acceptable to
   ;; substitute file existence for the stronger directory check.
   (cond-expand
-   (chibi (import (only (chibi filesystem) file-directory?)))
-   (else (begin (define file-directory? file-exists?))))
+   (chibi
+    (import (only (meta) warn))
+    (import (only (chibi) print-exception print-stack-trace))
+    (import (only (chibi filesystem) file-directory?)))
+   (else
+    (begin
+      (define file-directory? file-exists?)
+      (define (print-exception exn) (write exn))
+      (define (print-stack-trace . o) #f)
+      (define (warn msg . args)
+        (let ((err (current-error-port)))
+          (display msg err)
+          (for-each (lambda (x) (display " " err) (write x err)) args)
+          (newline err))))))
   (include "config.scm"))

lib/chibi/crypto/md5-test.sld

@@ -1,6 +1,6 @@
 (define-library (chibi crypto md5-test)
   (export run-tests)
-  (import (chibi) (chibi crypto md5) (chibi test))
+  (import (scheme base) (chibi crypto md5) (chibi test))
   (begin
     (define (run-tests)
       (test-begin "md5")

lib/chibi/crypto/md5.sld

@@ -5,7 +5,8 @@
 (define-library (chibi crypto md5)
   (import (scheme base) (chibi bytevector))
   (cond-expand
-   ((library (srfi 60)) (import (srfi 60)))
-   (else (import (srfi 33))))
+   ((library (srfi 151)) (import (srfi 151)))
+   ((library (srfi 33)) (import (srfi 33)))
+   (else (import (srfi 60))))
   (export md5)
   (include "md5.scm"))

lib/chibi/crypto/rsa-test.sld

@@ -6,23 +6,28 @@
           (chibi test))
   (begin
     (define (run-tests)
+
+      (define (test-key key)
+        (test #t (rsa-key? key))
+        (test #t (positive? (rsa-key-n key)))
+        (test #t (positive? (rsa-key-e key)))
+        (test #t (positive? (rsa-key-d key)))
+        (test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
+
       (test-begin "rsa")
 
       ;; Verify an explicit key.
 
       ;; p = 61, q = 53
-      (define priv-key (rsa-key-gen-from-primes 8 61 53))
-      (define pub-key (rsa-pub-key priv-key))
-
+      (let* ((priv-key (rsa-key-gen-from-primes 8 61 53))
+             (pub-key (rsa-pub-key priv-key)))
         (test 439 (rsa-sign priv-key 42))
         (test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
-
         (let ((msg 42))
-        (test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg))))
-
-      (define priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
-      (define pub-key2 (rsa-pub-key priv-key2))
+          (test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg)))))
 
+      (let* ((priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
+             (pub-key2 (rsa-pub-key priv-key2)))
         (let ((msg 42))
           (test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
 
@@ -36,17 +41,10 @@
           (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
 
         (let ((msg #u8(42)))
-        (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
+          (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg)))))
 
       ;; Key generation.
 
-      (define (test-key key)
-        (test #t (rsa-key? key))
-        (test #t (positive? (rsa-key-n key)))
-        (test #t (positive? (rsa-key-e key)))
-        (test #t (positive? (rsa-key-d key)))
-        (test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
-
       (test-key (rsa-key-gen 8))
       (test-key (rsa-key-gen 16))
       (test-key (rsa-key-gen 32))

lib/chibi/crypto/rsa.sld

@@ -5,8 +5,9 @@
   (import (scheme base) (srfi 27)
           (chibi bytevector) (chibi math prime))
   (cond-expand
-   ((library (srfi 60)) (import (srfi 60)))
-   (else (import (srfi 33))))
+   ((library (srfi 151)) (import (srfi 151)))
+   ((library (srfi 33)) (import (srfi 33)))
+   (else (import (srfi 60))))
   (export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key
           rsa-encrypt rsa-decrypt rsa-sign rsa-verify rsa-verify?
           rsa-key? rsa-key-bits rsa-key-n rsa-key-e rsa-key-d

lib/chibi/crypto/sha2-test.sld

@@ -1,6 +1,6 @@
 (define-library (chibi crypto sha2-test)
   (export run-tests)
-  (import (chibi) (chibi io) (chibi crypto sha2) (chibi test))
+  (import (scheme base) (chibi crypto sha2) (chibi test))
   (begin
     (define (run-tests)
       (test-begin "sha2")

lib/chibi/crypto/sha2.sld

@@ -11,8 +11,9 @@
     (include-shared "crypto"))
    (else
     (cond-expand
-     ((library (srfi 60)) (import (srfi 60)))
-     (else (import (srfi 33))))
+     ((library (srfi 151)) (import (srfi 151)))
+     ((library (srfi 33)) (import (srfi 33)))
+     (else (import (srfi 60))))
     (import (chibi bytevector))
     (include "sha2.scm"))))
 

lib/chibi/csv-test.sld

@@ -0,0 +1,98 @@
+
+(define-library (chibi csv-test)
+  (import (scheme base)
+          (srfi 227)
+          (chibi csv)
+          (chibi test))
+  (export run-tests)
+  (begin
+    (define string->csv
+      (opt-lambda (str (reader (csv-read->list)))
+        (reader (open-input-string str))))
+    (define csv->string
+      (opt-lambda (row (writer (csv-writer)))
+        (let ((out (open-output-string)))
+          (writer row out)
+          (get-output-string out))))
+    (define (run-tests)
+      (test-begin "(chibi csv)")
+      (test-assert (eof-object? (string->csv "")))
+      (test '("1997" "Ford" "E350")
+          (string->csv "1997,Ford,E350"))
+      (test '("1997" "Ford" "E350")
+          (string->csv "\n1997,Ford,E350"))
+      (test '(" ")
+          (string->csv " \n1997,Ford,E350"))
+      (test '("" "")
+          (string->csv ",\n1997,Ford,E350"))
+      (test '("1997" "Ford" "E350")
+          (string->csv "\"1997\",\"Ford\",\"E350\""))
+      (test '("1997" "Ford" "E350" "Super, luxurious truck")
+          (string->csv "1997,Ford,E350,\"Super, luxurious truck\""))
+      (test '("1997" "Ford" "E350" "Super, \"luxurious\" truck")
+          (string->csv "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\""))
+      (test '("1997" "Ford" "E350" "Go get one now\nthey are going fast")
+          (string->csv "1997,Ford,E350,\"Go get one now
+they are going fast\""))
+      (test '("1997" "Ford" "E350")
+          (string->csv
+           "# this is a comment\n1997,Ford,E350"
+           (csv-read->list
+            (csv-parser (csv-grammar '((comment-chars #\#)))))))
+      (let ((parser (csv-parser (csv-grammar '((quote-non-numeric? . #t))))))
+        (test-error (string->csv "1997,\"Ford\",E350" (csv-read->list parser)))
+        (test '(1997 "Ford" "E350")
+            (string->csv "1997,\"Ford\",\"E350\"" (csv-read->list parser))))
+      (test '("1997" "Fo\"rd" "E3\"50")
+          (string->csv "1997\tFo\"rd\tE3\"50"
+                            (csv-read->list (csv-parser default-tsv-grammar))))
+      (test '#("1997" "Ford" "E350")
+          (string->csv "1997,Ford,E350" (csv-read->vector)))
+      (test '#("1997" "Ford" "E350")
+          (string->csv "1997,Ford,E350" (csv-read->fixed-vector 3)))
+      (test-error
+          (string->csv "1997,Ford,E350" (csv-read->fixed-vector 2)))
+      (let ((city-csv "Los Angeles,34°03′N,118°15′W
+New York City,40°42′46″N,74°00′21″W
+Paris,48°51′24″N,2°21′03″E"))
+        (test '(*TOP*
+                (row (col-0 "Los Angeles")
+                     (col-1 "34°03′N")
+                     (col-2 "118°15′W"))
+                (row (col-0 "New York City")
+                     (col-1 "40°42′46″N")
+                     (col-2 "74°00′21″W"))
+                (row (col-0 "Paris")
+                     (col-1 "48°51′24″N")
+                     (col-2 "2°21′03″E")))
+            ((csv->sxml) (open-input-string city-csv)))
+       (test '(*TOP*
+               (city (name "Los Angeles")
+                     (latitude "34°03′N")
+                     (longitude "118°15′W"))
+               (city (name "New York City")
+                     (latitude "40°42′46″N")
+                     (longitude "74°00′21″W"))
+               (city (name "Paris")
+                     (latitude "48°51′24″N")
+                     (longitude "2°21′03″E")))
+           ((csv->sxml 'city '(name latitude longitude))
+            (open-input-string city-csv)))
+       (test 3 (csv-num-rows default-csv-grammar (open-input-string city-csv)))
+       (test 0 (csv-num-rows default-csv-grammar (open-input-string "")))
+       (test 1 (csv-num-rows default-csv-grammar (open-input-string "x"))))
+      (test "1997,Ford,E350\n"
+          (csv->string '("1997" "Ford" "E350")))
+      (test "1997,Ford,E350,\"Super, luxurious truck\"\n"
+          (csv->string '("1997" "Ford" "E350" "Super, luxurious truck")))
+      (test "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\"\n"
+          (csv->string '("1997" "Ford" "E350" "Super, \"luxurious\" truck")))
+      (test "1997,Ford,E350,\"Go get one now\nthey are going fast\"\n"
+          (csv->string
+           '("1997" "Ford" "E350" "Go get one now\nthey are going fast")))
+      (test "1997,Ford,E350\n"
+          (csv->string '(1997 "Ford" E350)))
+      (test "1997,\"Ford\",\"E350\"\n"
+          (csv->string '(1997 "Ford" E350)
+                       (csv-writer (csv-grammar '((quote-non-numeric? . #t))))))
+      (test-end))))

lib/chibi/csv.scm

@@ -0,0 +1,498 @@
+
+;;> \section{CSV Grammars}
+
+;;> CSV is a simple and compact format for tabular data, which has
+;;> made it popular for a variety of tasks since the early days of
+;;> computing.  Unfortunately, there are many incompatible dialects
+;;> requiring a grammar to specify all of the different options.
+
+(define-record-type Csv-Grammar
+  (make-csv-grammar separator-chars quote-char quote-doubling-escapes? escape-char record-separator comment-chars quote-non-numeric?)
+  csv-grammar?
+  (separator-chars csv-grammar-separator-chars csv-grammar-separator-chars-set!)
+  (quote-char csv-grammar-quote-char csv-grammar-quote-char-set!)
+  (quote-doubling-escapes? csv-grammar-quote-doubling-escapes? csv-grammar-quote-doubling-escapes?-set!)
+  (escape-char csv-grammar-escape-char csv-grammar-escape-char-set!)
+  (record-separator csv-grammar-record-separator csv-grammar-record-separator-set!)
+  (comment-chars csv-grammar-comment-chars csv-grammar-comment-chars-set!)
+  (quote-non-numeric? csv-grammar-quote-non-numeric? csv-grammar-quote-non-numeric?-set!))
+
+;; TODO: Other options to consider:
+;; - strip-leading/trailing-whitespace?
+;; - newlines-in-quotes?
+
+;;> Creates a new CSV grammar from the given spec, an alist of symbols
+;;> to values.  The following options are supported:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{'separator-chars} - A non-empty list of characters used to delimit fields, by default \scheme{'(#\\,)} (comma-separated).}
+;;> \item{\scheme{'quote-char} - A single character used to quote fields containing special characters, or \scheme{#f} to disable quoting, by default \scheme{#\\"} (a double-quote).}
+;;> \item{\scheme{'quote-doubling-escapes?} - If true, two successive \scheme{quote-char}s within quotes are treated as a single escaped \scheme{quote-char} (default true).}
+;;> \item{\scheme{'escape-char} - A single character used to escape characters within quoted fields, or \scheme{#f} to disable escapes, by default \scheme{#f} (no explicit escape, use quote doubling).}
+;;> \item{\scheme{'record-separator} - A single character used to delimit the record (row), or one of the symbols \scheme{'cr}, \scheme{'crlf}, \scheme{'lf} or \scheme{'lax}.  These correspond to sequences of carriage return and line feed, or in the case of \scheme{'lax} any of the other three sequences.  Defaults to \scheme{'lax}.}
+;;> \item{\scheme{'comment-chars} - A list of characters which if found at the start of a record indicate it is a comment, discarding all characters through to the next record-separator. Defaults to the empty list (no comments).}
+;;> ]
+;;>
+;;> Example Gecos grammar:
+;;>
+;;> \example{
+;;> (csv-grammar
+;;>   '((separator-chars #\\:)
+;;>     (quote-char . #f)))
+;;> }
+(define (csv-grammar spec)
+  (let ((grammar (make-csv-grammar '(#\,) #\" #t #f 'lax '() #f)))
+    (for-each
+     (lambda (x)
+       (case (car x)
+         ((separator-chars delimiter)
+          (csv-grammar-separator-chars-set! grammar (cdr x)))
+         ((quote-char)
+          (csv-grammar-quote-char-set! grammar (cdr x)))
+         ((quote-doubling-escapes?)
+          (csv-grammar-quote-doubling-escapes?-set! grammar (cdr x)))
+         ((escape-char)
+          (csv-grammar-escape-char-set! grammar (cdr x)))
+         ((record-separator newline-type)
+          (let ((rec-sep
+                 (case (cdr x)
+                   ((crlf lax) (cdr x))
+                   ((cr) #\return)
+                   ((lf) #\newline)
+                   (else
+                    (if (char? (cdr x))
+                        (cdr x)
+                        (error "invalid record-separator, expected a char or one of 'lax or 'crlf" (cdr x)))))))
+            (csv-grammar-escape-char-set! grammar (cdr x))))
+         ((comment-chars)
+          (csv-grammar-comment-chars-set! grammar (cdr x)))
+         ((quote-non-numeric?)
+          (csv-grammar-quote-non-numeric?-set! grammar (cdr x)))
+         (else
+          (error "unknown csv-grammar spec" x))))
+     spec)
+    grammar))
+
+;;> The default CSV grammar for convenience, with all of the defaults
+;;> from \scheme{csv-grammar}, i.e. comma-delimited with \scheme{#\"}
+;;> for quoting, doubled to escape.
+(define default-csv-grammar
+  (csv-grammar '()))
+
+;;> The default TSV grammar for convenience, splitting fields only on
+;;> tabs, with no quoting or escaping.
+(define default-tsv-grammar
+  (csv-grammar '((separator-chars #\tab) (quote-char . #f))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{CSV Parsers}
+
+;;> Parsers are low-level utilities to perform operations on records a
+;;> field at a time.  You generally want to work with readers, which
+;;> build on this to build records into familiar data structures.
+
+;;> Parsers follow the rules of a grammar to parse a single CSV
+;;> record, possible comprised of multiple fields.  A parser is a
+;;> procedure of three arguments which performs a fold operation over
+;;> the fields of the record. The parser signature is:
+;;> \scheme{(parser kons knil in)}, where \scheme{kons} itself is
+;;> a procedure of three arguments: \scheme{(proc acc index field)}.
+;;> \scheme{proc} is called on each field of the record, in order,
+;;> along with its zero-based \scheme{index} and the accumulated
+;;> result of the last call, starting with \scheme{knil}.
+
+;;> Returns a new CSV parser for the given \var{grammar}.  The parser
+;;> by itself can be used to parse a record at a time.
+;;>
+;;> \example{
+;;> (let ((parse (csv-parser)))
+;;>   (parse (lambda (vec i field) (vector-set! vec i (string->number field)) vec)
+;;>          (make-vector 3)
+;;>          (open-input-string "1,2,3")))
+;;> }
+(define csv-parser
+  (opt-lambda ((grammar default-csv-grammar))
+    (lambda (kons knil in)
+      (when (pair? (csv-grammar-comment-chars grammar))
+        (let lp ()
+          (when (memv (peek-char in) (csv-grammar-comment-chars grammar))
+            (csv-skip-line in grammar)
+            (lp))))
+      (let lp ((acc knil)
+               (index 0)
+               (quoted? #f)
+               (out (open-output-string)))
+        (define (get-field)
+          (let ((field (get-output-string out)))
+            (cond
+             ((and (zero? index) (equal? field "")) field)
+             ((and (csv-grammar-quote-non-numeric? grammar) (not quoted?))
+              (or (string->number field)
+                  (error "unquoted field is not numeric" field)))
+             (else field))))
+        (define (finish-row)
+          (let ((field (get-field)))
+            (if (and (zero? index) (equal? field ""))
+                ;; empty row, read again
+                (lp acc index #f out)
+                (kons acc index field))))
+        (let ((ch (read-char in)))
+          (cond
+           ((eof-object? ch)
+            (let ((field (get-field)))
+              (if (and (zero? index) (equal? field ""))
+                  ;; no data
+                  ch
+                  (kons acc index field))))
+           ((memv ch (csv-grammar-separator-chars grammar))
+            (lp (kons acc index (get-field))
+                (+ index 1)
+                #f
+                (open-output-string)))
+           ((eqv? ch (csv-grammar-quote-char grammar))
+            ;; TODO: Consider a strict mode to enforce no text
+            ;; before/after the quoted text.
+            (csv-read-quoted in out grammar)
+            (lp acc index #t out))
+           ((eqv? ch (csv-grammar-record-separator grammar))
+            (finish-row))
+           ((and (eqv? ch #\return)
+                 (memq (csv-grammar-record-separator grammar) '(crlf lax)))
+            (cond
+             ((eqv? (peek-char in) #\newline)
+              (read-char in)
+              (finish-row))
+             ((eq? (csv-grammar-record-separator grammar) 'lax)
+              (finish-row))
+             (else
+              (write-char ch out)
+              (lp acc (+ index 1) quoted? out))))
+           ((and (eqv? ch #\newline)
+                 (eq? (csv-grammar-record-separator grammar) 'lax))
+            (finish-row))
+           (else
+            (write-char ch out)
+            (lp acc index quoted? out))))))))
+
+(define (csv-skip-line in grammar)
+  (let lp ()
+    (let ((ch (read-char in)))
+      (cond
+       ((eof-object? ch))
+       ((eqv? ch (csv-grammar-record-separator grammar)))
+       ((and (eqv? ch #\newline)
+             (eq? (csv-grammar-record-separator grammar) 'lax)))
+       ((and (eqv? ch #\return)
+             (memq (csv-grammar-record-separator grammar) '(crlf lax)))
+        (cond
+         ((eqv? (peek-char in) #\newline) (read-char in))
+         ((eq? (csv-grammar-record-separator grammar) 'lax))
+         (else (lp))))
+       (else (lp))))))
+
+(define (csv-read-quoted in out grammar)
+  (let lp ()
+    (let ((ch (read-char in)))
+      (cond
+       ((eof-object? ch)
+        (error "unterminated csv quote" (get-output-string out)))
+       ((eqv? ch (csv-grammar-quote-char grammar))
+        (when (and (csv-grammar-quote-doubling-escapes? grammar)
+                   (eqv? ch (peek-char in)))
+          (write-char (read-char in) out)
+          (lp)))
+       ((eqv? ch (csv-grammar-escape-char grammar))
+        (write-char (read-char in) out)
+        (lp))
+       (else
+        ;; TODO: Consider an option to disable newlines in quotes.
+        (write-char ch out)
+        (lp))))))
+
+(define (csv-skip-quoted in grammar)
+  (let lp ()
+    (let ((ch (read-char in)))
+      (cond
+       ((eof-object? ch)
+        (error "unterminated csv quote"))
+       ((eqv? ch (csv-grammar-quote-char grammar))
+        (when (and (csv-grammar-quote-doubling-escapes? grammar)
+                   (eqv? ch (peek-char in)))
+          (read-char in)
+          (lp)))
+       ((eqv? ch (csv-grammar-escape-char grammar))
+        (read-char in)
+        (lp))
+       (else
+        (lp))))))
+
+;;> Returns the number of rows in the input.
+(define csv-num-rows
+  (opt-lambda ((grammar default-csv-grammar)
+               (in (current-input-port)))
+    (let lp ((num-rows 0) (start? #t))
+      (let ((ch (read-char in)))
+        (cond
+         ((eof-object? ch) (if start? num-rows (+ num-rows 1)))
+         ((eqv? ch (csv-grammar-quote-char grammar))
+          (csv-skip-quoted in grammar)
+          (lp num-rows #f))
+         ((eqv? ch (csv-grammar-record-separator grammar))
+          (lp (+ num-rows 1) #f))
+         ((and (eqv? ch #\return)
+               (memq (csv-grammar-record-separator grammar) '(crlf lax)))
+          (cond
+           ((eqv? (peek-char in) #\newline)
+            (read-char in)
+            (lp (+ num-rows 1) #t))
+           ((eq? (csv-grammar-record-separator grammar) 'lax)
+            (lp (+ num-rows 1) #t))
+           (else
+            (lp num-rows #f))))
+         ((and (eqv? ch #\newline)
+               (eq? (csv-grammar-record-separator grammar) 'lax))
+          (lp (+ num-rows 1) #t))
+         (else
+          (lp num-rows #f)))))))
+
+;;> \section{CSV Readers}
+
+;;> A CSV reader reads a single record, returning some representation
+;;> of it.  You can either loop manually with these or pass them to
+;;> one of the high-level utilities to operate on a whole CSV file at
+;;> a time.
+
+;;> The simplest reader, simply returns the field string values in
+;;> order as a list.
+;;>
+;;> \example{
+;;> ((csv-read->list) (open-input-string "foo,bar,baz"))
+;;> }
+(define csv-read->list
+  (opt-lambda ((parser (csv-parser)))
+    (opt-lambda ((in (current-input-port)))
+      (let ((res (parser (lambda (ls i field) (cons field ls)) '() in)))
+        (if (pair? res)
+            (reverse res)
+            res)))))
+
+;;> The equivalent of \scheme{csv-read->list} but returns a vector.
+;;>
+;;> \example{
+;;> ((csv-read->vector) (open-input-string "foo,bar,baz"))
+;;> }
+(define csv-read->vector
+  (opt-lambda ((parser (csv-parser)))
+    (let ((reader (csv-read->list parser)))
+      (opt-lambda ((in (current-input-port)))
+        (let ((res (reader in)))
+          (if (pair? res)
+              (list->vector res)
+              res))))))
+
+;;> The same as \scheme{csv-read->vector} but requires the vector to
+;;> be of a fixed size, and may be more efficient.
+;;>
+;;> \example{
+;;> ((csv-read->fixed-vector 3) (open-input-string "foo,bar,baz"))
+;;> }
+(define csv-read->fixed-vector
+  (opt-lambda (size (parser (csv-parser)))
+    (opt-lambda ((in (current-input-port)))
+      (let ((res (make-vector size)))
+        (let ((len (parser (lambda (prev-i i field) (vector-set! res i field) i)
+                           0
+                           in)))
+          (if (zero? len)
+              (eof-object)
+              res))))))
+
+;;> Returns an SXML representation of the record, as a row with
+;;> multiple named columns.
+;;>
+;;> \example{
+;;> ((csv-read->sxml 'city '(name latitude longitude))
+;;>  (open-input-string "Tokyo,35°41′23″N,139°41′32″E"))
+;;> }
+(define csv-read->sxml
+  (opt-lambda ((row-name 'row)
+               (column-names
+                (lambda (i)
+                  (string->symbol (string-append "col-" (number->string i)))))
+               (parser (csv-parser)))
+    (define (get-column-name i)
+      (if (procedure? column-names)
+          (column-names i)
+          (list-ref column-names i)))
+    (opt-lambda ((in (current-input-port)))
+      (let ((res (parser (lambda (ls i field)
+                           `((,(get-column-name i) ,field) ,@ls))
+                         (list row-name)
+                         in)))
+        (if (pair? res)
+            (reverse res)
+            res)))))
+
+;;> \section{CSV Utilities}
+
+;;> A folding operation on records.  \var{proc} is called successively
+;;> on each row and the accumulated result.
+;;>
+;;> \example{
+;;> (csv-fold
+;;>  (lambda (row acc) (cons (cadr (assq 'name (cdr row))) acc))
+;;>  '()
+;;>  (csv-read->sxml 'city '(name latitude longitude))
+;;>  (open-input-string
+;;>   "Tokyo,35°41′23″N,139°41′32″E
+;;> Paris,48°51′24″N,2°21′03″E"))
+;;> }
+(define csv-fold
+  (opt-lambda (proc
+               knil
+               (reader (csv-read->list))
+               (in (current-input-port)))
+    (let lp ((acc knil))
+      (let ((row (reader in)))
+        (cond
+         ((eof-object? row) acc)
+         (else (lp (proc row acc))))))))
+
+;;> An iterator which simply calls \var{proc} on each record in the
+;;> input in order.
+;;>
+;;> \example{
+;;> (let ((count 0))
+;;>   (csv-for-each
+;;>    (lambda (row) (if (string->number (car row)) (set! count (+ 1 count))))
+;;>    (csv-read->list)
+;;>    (open-input-string
+;;>      "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
+;;>    count)
+;;> }
+(define csv-for-each
+  (opt-lambda (proc
+               (reader (csv-read->list))
+               (in (current-input-port)))
+    (csv-fold (lambda (row acc) (proc row)) #f reader in)))
+
+;;> Returns a list containing the result of calling \var{proc} on each
+;;> element in the input.
+;;>
+;;> \example{
+;;> (csv-map
+;;>  (lambda (row) (string->symbol (cadr row)))
+;;>  (csv-read->list)
+;;>  (open-input-string
+;;>    "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
+;;> }
+(define csv-map
+  (opt-lambda (proc
+               (reader (csv-read->list))
+               (in (current-input-port)))
+    (reverse (csv-fold (lambda (row acc) (cons (proc row) acc)) '() reader in))))
+
+;;> Returns a list of all of the read records in the input.
+;;>
+;;> \example{
+;;> (csv->list
+;;>  (csv-read->list)
+;;>  (open-input-string
+;;>    "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
+;;> }
+(define csv->list
+  (opt-lambda ((reader (csv-read->list))
+               (in (current-input-port)))
+    (csv-map (lambda (row) row) reader in)))
+
+;;> Returns an SXML representation of the CSV.
+;;>
+;;> \example{
+;;> ((csv->sxml 'city '(name latitude longitude))
+;;>  (open-input-string
+;;>   "Tokyo,35°41′23″N,139°41′32″E
+;;> Paris,48°51′24″N,2°21′03″E"))
+;;> }
+(define csv->sxml
+  (opt-lambda ((row-name 'row)
+               (column-names
+                (lambda (i)
+                  (string->symbol (string-append "col-" (number->string i)))))
+               (parser (csv-parser)))
+    (opt-lambda ((in (current-input-port)))
+      (cons '*TOP*
+            (csv->list (csv-read->sxml row-name column-names parser) in)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{CSV Writers}
+
+(define (write->string obj)
+  (let ((out (open-output-string)))
+    (write obj out)
+    (get-output-string out)))
+
+(define (csv-grammar-char-needs-quoting? grammar ch)
+  (or (eqv? ch (csv-grammar-quote-char grammar))
+      (eqv? ch (csv-grammar-escape-char grammar))
+      (memv ch (csv-grammar-separator-chars grammar))
+      (eqv? ch (csv-grammar-record-separator grammar))
+      (memv ch '(#\newline #\return))))
+
+(define (csv-write-quoted obj out grammar)
+  (let ((in (open-input-string (if (string? obj) obj (write->string obj)))))
+    (write-char (csv-grammar-quote-char grammar) out)
+    (let lp ()
+      (let ((ch (read-char in)))
+        (cond
+         ((eof-object? ch))
+         ((or (eqv? ch (csv-grammar-quote-char grammar))
+              (eqv? ch (csv-grammar-escape-char grammar)))
+          (cond
+           ((and (csv-grammar-quote-doubling-escapes? grammar)
+                 (eqv? ch (csv-grammar-quote-char grammar)))
+            (write-char ch out))
+           ((csv-grammar-escape-char grammar)
+            => (lambda (esc) (write-char esc out)))
+           (else (error "no quote defined for" ch grammar)))
+          (write-char ch out)
+          (lp))
+         (else
+          (write-char ch out)
+          (lp)))))
+    (write-char (csv-grammar-quote-char grammar) out)))
+
+(define csv-writer
+  (opt-lambda ((grammar default-csv-grammar))
+    (opt-lambda (row (out (current-output-port)))
+      (let lp ((ls row) (first? #t))
+        (when (pair? ls)
+          (unless first?
+            (write-char (car (csv-grammar-separator-chars grammar)) out))
+          (if (or (and (csv-grammar-quote-non-numeric? grammar)
+                       (not (number? (car ls))))
+                  (and (string? (car ls))
+                       (string-any
+                        (lambda (ch) (csv-grammar-char-needs-quoting? grammar ch))
+                        (car ls)))
+                  (and (not (string? (car ls)))
+                       (not (number? (car ls)))
+                       (not (symbol? (car ls)))))
+              (csv-write-quoted (car ls) out grammar)
+              (display (car ls) out))
+          (lp (cdr ls) #f)))
+      (write-string
+       (case (csv-grammar-record-separator grammar)
+         ((crlf) "\r\n")
+         ((lf lax) "\n")
+         ((cr) "\r")
+         (else (string (csv-grammar-record-separator grammar))))
+       out))))
+
+(define csv-write
+  (opt-lambda ((writer (csv-writer)))
+    (opt-lambda (rows (out (current-output-port)))
+      (for-each
+       (lambda (row) (writer row out))
+       rows))))

lib/chibi/csv.sld

@@ -0,0 +1,11 @@
+
+(define-library (chibi csv)
+  (import (scheme base) (scheme write) (srfi 130) (srfi 227))
+  (export csv-grammar csv-parser csv-grammar?
+          default-csv-grammar default-tsv-grammar
+          csv-read->list csv-read->vector  csv-read->fixed-vector
+          csv-read->sxml csv-num-rows
+          csv-fold csv-map csv->list csv-for-each csv->sxml
+          csv-writer csv-write
+          csv-skip-line)
+  (include "csv.scm"))

lib/chibi/diff-test.sld

@@ -0,0 +1,63 @@
+
+(define-library (chibi diff-test)
+  (import (scheme base) (chibi diff))
+  (export run-tests)
+  (cond-expand
+   (chibi (import (chibi test)))
+   (else
+    (import (scheme write))
+    ;; inline (chibi test) to avoid circular dependencies in snow
+    ;; installations
+    (begin
+      (define-syntax test
+        (syntax-rules ()
+          ((test expect expr)
+           (test 'expr expect expr))
+          ((test name expect expr)
+           (guard (exn (else (display "!\nERROR: ") (write name) (newline)
+                             (write exn) (newline)))
+             (let* ((res expr)
+                    (pass? (equal? expect expr)))
+               (display (if pass? "." "x"))
+               (cond
+                ((not pass?)
+                 (display "\nFAIL: ") (write name) (newline))))))))
+      (define (test-begin name)
+        (display name))
+      (define (test-end)
+        (newline)))))
+  (begin
+    (define (run-tests)
+      (test-begin "diff")
+      (test '((#\A 1 0) (#\C 2 2))
+          (lcs-with-positions '(#\G #\A #\C) '(#\A #\G #\C #\A #\T)))
+      (test '(#\A #\C)
+          (lcs '(#\G #\A #\C) '(#\A #\G #\C #\A #\T)))
+      (test '((#\G #\A #\C) (#\A #\G #\C #\A #\T) ((#\A 1 0) (#\C 2 2)))
+          (diff "GAC" "AGCAT" read-char))
+      (test '((#\A #\G #\C #\A #\T) (#\A #\G #\C #\A #\T)
+              ((#\A 0 0) (#\G 1 1) (#\C 2 2) (#\A 3 3) (#\T 4 4)))
+          (diff "AGCAT" "AGCAT" read-char))
+      (test '((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\.
+               #\G #\A #\C #\. #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+              (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\.
+               #\A #\G #\C #\A #\T #\. #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+              ((#\0 0 0) (#\1 1 1) (#\2 2 2) (#\3 3 3) (#\4 4 4) (#\5 5 5)
+               (#\6 6 6) (#\7 7 7) (#\8 8 8) (#\9 9 9) (#\. 10 10)
+               (#\A 12 11) (#\C 13 13)
+               (#\. 14 16) (#\0 15 17) (#\1 16 18) (#\2 17 19) (#\3 18 20)
+               (#\4 19 21) (#\5 20 22) (#\6 21 23) (#\7 22 24) (#\8 23 25)
+               (#\9 24 26)))
+          (diff "0123456789.GAC.0123456789"
+                "0123456789.AGCAT.0123456789"
+                read-char))
+      (let ((d (diff "GAC" "AGCAT" read-char)))
+        (test " »G« AC"
+            (edits->string (car d) (car (cddr d)) 1))
+        (test "A «G» C «AT» "
+            (edits->string (cadr d) (car (cddr d)) 2))
+        (test "\x1b;[31mG\x1b;[39mAC"
+            (edits->string/color (car d) (car (cddr d)) 1))
+        (test "A\x1b;[32mG\x1b;[39mC\x1b;[32mAT\x1b;[39m"
+            (edits->string/color (cadr d) (car (cddr d)) 2)))
+      (test-end))))

lib/chibi/diff.scm

@@ -0,0 +1,279 @@
+
+;; utility for lcs-with-positions
+(define (max-seq . o)
+  (if (null? o)
+      (list 0 '())
+      (let loop ((a (car o)) (ls (cdr o)))
+        (if (null? ls)
+            a
+            (let ((b (car ls)))
+              (if (>= (car a) (car b))
+                  (loop a (cdr ls))
+                  (loop b (cdr ls))))))))
+
+;;> Finds the Longest Common Subsequence between \var{a-ls} and
+;;> \var{b-ls}, comparing elements with \var{eq} (default
+;;> \scheme{equal?}.  Returns this sequence as a list, using the
+;;> elements from \var{a-ls}.  Uses quadratic time and space.
+(define (lcs a-ls b-ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (map car (lcs-with-positions a-ls b-ls eq))))
+
+;;> Variant of \scheme{lcs} which returns the annotated sequence.  The
+;;> result is a list of the common elements, each represented as a
+;;> list of 3 values: the element, the zero-indexed position in
+;;> \var{a-ls} where the element occurred, and the position in
+;;> \var{b-ls}.
+(define (lcs-with-positions a-ls b-ls . o)
+  (let* ((eq (if (pair? o) (car o) equal?))
+         (a-len (+ 1 (length a-ls)))
+         (b-len (+ 1 (length b-ls)))
+         (results (make-vector (* a-len b-len) #f)))
+    (let loop ((a a-ls) (a-pos 0) (b b-ls) (b-pos 0))
+      ;; cache this step if not already done
+      (let ((i (+ (* a-pos b-len) b-pos)))
+        (or (vector-ref results i)
+            (let ((res
+                   (if (or (null? a) (null? b))
+                       (list 0 '()) ;; base case
+                       (let ((a1 (car a))
+                             (b1 (car b))
+                             (a-tail (loop (cdr a) (+ a-pos 1) b b-pos))
+                             (b-tail (loop a a-pos (cdr b) (+ b-pos 1))))
+                         (cond
+                          ((eq a1 b1)
+                           ;; match found, we either use it or we don't
+                           (let* ((a-b-tail (loop (cdr a) (+ a-pos 1)
+                                                  (cdr b) (+ b-pos 1)))
+                                  (a-b-res (list (+ 1 (car a-b-tail))
+                                                 (cons (list a1 a-pos b-pos)
+                                                       (cadr a-b-tail)))))
+                             (max-seq a-b-res a-tail b-tail)))
+                          (else
+                           ;; not a match
+                           (max-seq a-tail b-tail)))))))
+              (vector-set! results i res)
+              res))))
+    (cadr (vector-ref results 0))))
+
+(define (source->list x reader)
+  (port->list
+   reader
+   (cond ((port? x) x)
+         ((string? x) (open-input-string x))
+         (else (error "don't know how to diff from:" x)))))
+
+;;> Utility to run lcs on text.  \var{a} and \var{b} can be strings or
+;;> ports, which are tokenized into a sequence by calling \var{reader}
+;;> until \var{eof-object} is found.  Returns a list of three values,
+;;> the sequences read from \var{a} and \var{b}, and the \scheme{lcs}
+;;> result.  Unless \var{minimal?} is set, we trim common
+;;> prefixes/suffixes before computing the lcs.
+(define (diff a b . o)
+  (let-optionals o ((reader read-line)
+                    (eq equal?)
+                    (optimal? #f))
+    (let ((a-ls (source->list a reader))
+          (b-ls (source->list b reader)))
+      (if optimal?
+          (list a-ls b-ls (lcs-with-positions a-ls b-ls eq))
+          (let lp1 ((i 0) (a a-ls) (b b-ls))
+            (cond
+             ((or (null? a) (null? b))  ;; prefix or equal
+              (if (and (null? a) (null? b))
+                  (let ((n-ls (iota (length a-ls))))  ;; equal
+                    (list a-ls b-ls (map list a-ls n-ls n-ls)))
+                  (list a-ls b-ls (lcs-with-positions a-ls b-ls eq))))
+             ((eq (car a) (car b))
+              (lp1 (+ i 1) (cdr a) (cdr b)))
+             (else
+              (let lp2 ((j 0) (ra (reverse a)) (rb (reverse b)))
+                (cond
+                 ((or (null? ra) (null? rb))  ;; can't happen
+                  (list a-ls b-ls (lcs-with-positions a-ls b-ls eq)))
+                 ((eq (car ra) (car rb))
+                  (lp2 (+ j 1) (cdr ra) (cdr rb)))
+                 (else
+                  (let* ((a-ls2 (reverse ra))
+                         (b-ls2 (reverse rb))
+                         (a-left-len (+ i (length a-ls2)))
+                         (b-left-len (+ i (length b-ls2))))
+                    (list a-ls
+                          b-ls
+                          (append
+                           (map (lambda (x i) (list x i i))
+                                (take a-ls i)
+                                (iota i))
+                           (map (lambda (x)
+                                  (list (car x)
+                                        (+ i (cadr x))
+                                        (+ i (car (cddr x)))))
+                                (lcs-with-positions a-ls2 b-ls2 eq))
+                           (map (lambda (x i)
+                                  (list x (+ i a-left-len) (+ i b-left-len)))
+                                (take-right a j)
+                                (iota j))))))
+                 )))))))))
+
+;;> Utility to format the result of a \var{diff} to output port
+;;> \var{out} (default \scheme{(current-output-port)}).  Applies
+;;> \var{writer} to successive diff chunks.  \var{writer} should be a
+;;> procedure of three arguments: \scheme{(writer subsequence type
+;;> out).  \var{subsequence} is a subsequence from the original input,
+;;> \var{type} is a symbol indicating the type of diff: \scheme{'same}
+;;> if this is part of the lcs, \scheme{'add} if it is unique to the
+;;> second input, or \scheme{'remove} if it is unique to the first
+;;> input.  \var{writer} defaults to \scheme{write-line-diffs},
+;;> assuming the default line diffs.
+(define (write-diff diff . o)
+  (let-optionals o ((writer write-line-diffs)
+                    (out (current-output-port)))
+    (let* ((a-ls (car diff))
+           (b-ls (cadr diff))
+           (d-ls (car (cddr diff))))
+      ;; context diff
+      (let lp ((d d-ls) (a a-ls) (a-pos 0) (b b-ls) (b-pos 0))
+        (unless (null? d)
+          (let* ((d1 (car d))
+                 (a-off (cadr d1))
+                 (a-skip (- a-off a-pos))
+                 (b-off (car (cddr d1)))
+                 (b-skip (- b-off b-pos)))
+            (let-values (((a-head a-tail) (split-at a a-skip))
+                         ((b-head b-tail) (split-at b b-skip)))
+              ;; elements only in a have been removed
+              (if (pair? a-head)
+                  (writer (cdr a-head) 'remove out))
+              ;; elements only in b have been added
+              (if (pair? b-head)
+                  (writer (cdr b-head) 'add out))
+              ;; reprint this common element
+              (writer (list (car d1)) 'same out)
+              ;; recurse
+              (lp (cdr d) a-tail a-off b-tail b-off))))))))
+
+;;> Equivalent to \scheme{write-diff} but collects the output to a string.
+(define (diff->string diff . o)
+  (let ((out (open-output-string)))
+    (write-diff diff (if (pair? o) (car o) write-line-diffs) out)
+    (get-output-string out)))
+
+;;> The default writer for \scheme{write-diff}, annotates simple +/-
+;;> prefixes for added/removed lines.
+(define (write-line-diffs lines type out)
+  (for-each
+   (lambda (line)
+     (case type
+       ((add)
+        (write-char #\+ out))
+       ((remove)
+        (write-char #\- out))
+       ((same)
+        (write-char #\space out))
+       (else (error "unknown diff type:" type)))
+     (write-string line out)
+     (newline out))
+   lines))
+
+;;> A variant of \scheme{write-line-diffs} which adds red/green ANSI
+;;> coloring to the +/- prefix.
+(define (write-line-diffs/color lines type out)
+  (for-each
+   (lambda (line)
+     (case type
+       ((add)
+        (write-string (green "+") out)
+        (write-string (green line) out))
+       ((remove)
+        (write-string (red "-") out)
+        (write-string (red line) out))
+       ((same)
+        (write-char #\space out)
+        (write-string line out))
+       (else (error "unknown diff type:" type)))
+     (newline out))
+   lines))
+
+;;> A diff writer for sequences of characters (when a diff was
+;;> generated with \scheme{read-char}), enclosing added characters in
+;;> «...» brackets and removed characters in »...«.
+(define (write-char-diffs chars type out)
+  (case type
+    ((add)
+     (write-string " «" out)
+     (write-string (list->string chars) out)
+     (write-string "» " out))
+    ((remove)
+     (write-string " »" out)
+     (write-string (list->string chars) out)
+     (write-string "« " out))
+    ((same)
+     (write-string (list->string chars) out))
+    (else (error "unknown diff type:" type))))
+
+;;> A diff writer for sequences of characters (when a diff was
+;;> generated with \scheme{read-char}), formatting added characters in
+;;> green and removed characters in red.
+(define (write-char-diffs/color chars type out)
+  (case type
+    ((add)
+     (write-string (green (list->string chars)) out))
+    ((remove)
+     (write-string (red (list->string chars)) out))
+    ((same)
+     (write-string (list->string chars) out))
+    (else (error "unknown diff type:" type))))
+
+;;> Utility to format the result of a \scheme{diff} with respect to a
+;;> single input sequence \var{ls}. \var{lcs} is the annotated common
+;;> sequence from \scheme{diff} or \scheme{lcs-with-positions}, and
+;;> \var{index} is the index (0 or 1, default 1) of \var{ls} in the
+;;> original call.  Since we have no information about the other
+;;> input, we can only format what is the same and what is different,
+;;> formatting the differences as either added (if \var{index} is 0)
+;;> or removed (if \var{index} is 1).
+(define (write-edits ls lcs . o)
+  (let-optionals o ((index 1)
+                    (writer write-line-diffs)
+                    (out (current-output-port)))
+    (let ((type (if (eq? index 1) 'remove 'add)))
+      (let lp ((ls ls) (lcs lcs) (buf '(#f)) (i 0))
+        (define (output ch type)
+          (cond
+           ((eq? type (car buf))
+            (cons type (cons ch (cdr buf))))
+           (else
+            (if (car buf)
+                (writer (reverse (cdr buf)) (car buf) out))
+            (list type ch))))
+        (cond
+         ((null? ls) (output #f 'done))
+         ((null? lcs)
+          (lp (cdr ls) lcs (output (car ls) type) (+ i 1)))
+         ((= i (list-ref (car lcs) index))
+          (lp (cdr ls) (cdr lcs) (output (car ls) 'same) (+ i 1)))
+         (else
+          (lp (cdr ls) lcs (output (car ls) type) (+ i 1))))))))
+
+;;> Equivalent to \scheme{write-edits} but collects the output to a string.
+(define (edits->string ls lcs . o)
+  (let-optionals o ((type 'add)
+                    (writer (if (and (pair? ls) (char? (car ls)))
+                                write-char-diffs
+                                write-line-diffs)))
+    (let ((out (open-output-string)))
+      (write-edits ls lcs type writer out)
+      (get-output-string out))))
+
+;;> Equivalent to \scheme{write-edits} but collects the output to a
+;;> string and uses a color-aware writer by default.  Note with a
+;;> character diff this returns the original input string as-is, with
+;;> only ANSI escapes indicating what changed.
+(define (edits->string/color ls lcs . o)
+  (let-optionals o ((type 'add)
+                    (writer (if (and (pair? ls) (char? (car ls)))
+                                write-char-diffs/color
+                                write-line-diffs/color)))
+    (let ((out (open-output-string)))
+      (write-edits ls lcs type writer out)
+      (get-output-string out))))

lib/chibi/diff.sld

@@ -0,0 +1,21 @@
+
+(define-library (chibi diff)
+  (import (scheme base) (srfi 1) (chibi optional) (chibi term ansi))
+  (export lcs lcs-with-positions
+          diff write-diff diff->string
+          write-edits edits->string edits->string/color
+          write-line-diffs
+          write-line-diffs/color
+          write-char-diffs
+          write-char-diffs/color)
+  (cond-expand
+   (chibi (import (only (chibi io) port->list)))
+   (else
+    (begin
+      (define (port->list reader port)
+        (let lp ((res '()))
+          (let ((x (reader port)))
+            (if (eof-object? x)
+                (reverse res)
+                (lp (cons x res)))))))))
+  (include "diff.scm"))

lib/chibi/disasm.c

@@ -11,20 +11,24 @@
 #define SEXP_DISASM_PAD_WIDTH 4
 
 #if SEXP_64_BIT
+#ifdef _WIN32
+#define SEXP_PRId "%I64d"
+#else
 #define SEXP_PRId "%ld"
+#endif
 #else
 #define SEXP_PRId "%d"
 #endif
 
 static void sexp_write_pointer (sexp ctx, void *p, sexp out) {
   char buf[32];
-  sprintf(buf, "%p", p);
+  snprintf(buf, sizeof(buf), "%p", p);
   sexp_write_string(ctx, buf, out);
 }
 
 static void sexp_write_integer (sexp ctx, sexp_sint_t n, sexp out) {
   char buf[32];
-  sprintf(buf, SEXP_PRId, n);
+  snprintf(buf, sizeof(buf), SEXP_PRId, n);
   sexp_write_string(ctx, buf, out);
 }
 
@@ -37,6 +41,10 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   sexp_sint_t src_off=0;
 #endif
 
+  if (sexp_idp(bc))
+    bc = sexp_env_ref(ctx, sexp_context_env(ctx), bc, SEXP_FALSE);
+  if (sexp_macrop(bc))
+    bc = sexp_macro_proc(bc);
   if (sexp_procedurep(bc)) {
     bc = sexp_procedure_code(bc);
   } else if (sexp_opcodep(bc)) {
@@ -76,14 +84,20 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   /* build a table of labels that are jumped to */
   labels = (sexp_sint_t*)calloc(sexp_bytecode_length(bc), sizeof(sexp_sint_t));
   ip = sexp_bytecode_data(bc);
-  while (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) {
+  while (ip - sexp_bytecode_data(bc) < (int)sexp_bytecode_length(bc)) {
     switch (*ip++) {
     case SEXP_OP_JUMP:
     case SEXP_OP_JUMP_UNLESS:
       off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
-      if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] == 0)
+      if (off >= 0 && off < (int)sexp_bytecode_length(bc) && labels[off] == 0)
         labels[off] = label++;
     case SEXP_OP_CALL:
+    case SEXP_OP_FCALL0:
+    case SEXP_OP_FCALL1:
+    case SEXP_OP_FCALL2:
+    case SEXP_OP_FCALL3:
+    case SEXP_OP_FCALL4:
+    case SEXP_OP_FCALLN:
     case SEXP_OP_CLOSURE_REF:
     case SEXP_OP_GLOBAL_KNOWN_REF:
     case SEXP_OP_GLOBAL_REF:
@@ -130,7 +144,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
           == sexp_unbox_fixnum(
                sexp_car(sexp_vector_ref(src, sexp_make_fixnum(src_off)))))) {
     src_here = sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(src_off)));
-    src_off = src_off < sexp_vector_length(src)-1 ? src_off + 1 : -1;
+    src_off = src_off < (sexp_sint_t)sexp_vector_length(src)-1 ? src_off + 1 : -1;
   } else {
     src_here = NULL;
   }
@@ -159,7 +173,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   case SEXP_OP_JUMP_UNLESS:
     sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
     off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
-    if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] > 0) {
+    if (off >= 0 && off < (sexp_sint_t)sexp_bytecode_length(bc) && labels[off] > 0) {
       sexp_write_string(ctx, " L", out);
       sexp_write_integer(ctx, labels[off], out);
     }
@@ -170,6 +184,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   case SEXP_OP_FCALL2:
   case SEXP_OP_FCALL3:
   case SEXP_OP_FCALL4:
+  case SEXP_OP_FCALLN:
     sexp_write_pointer(ctx, ((sexp*)ip)[0], out);
     sexp_write_char(ctx, ' ', out);
     sexp_write(ctx, sexp_opcode_name(((sexp*)ip)[0]), out);
@@ -220,7 +235,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
       && (depth < SEXP_DISASM_MAX_DEPTH)
       && tmp && (sexp_bytecodep(tmp) || sexp_procedurep(tmp)))
     disasm(ctx, self, tmp, out, depth+1);
-  if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
+  if (ip - sexp_bytecode_data(bc) < (int)sexp_bytecode_length(bc))
     goto loop;
 
   free(labels);

lib/chibi/doc-test.sld

@@ -25,4 +25,25 @@
                       (index (if (pair? o) (car o) 0))
                       (acc knil))
                (f p index fk)))))
+      (test "hello" (ansi->sxml "hello"))
+      (test '(span "[ " (span (@ (style . "color:red")) "FAIL") "]")
+          (ansi->sxml "[ \x1B;[31mFAIL\x1B;[39m]"))
+      (test '(span (u "under " (span (@ (style . "color:red")) "red") " line"))
+          (ansi->sxml "\x1B;[4munder \x1B;[31mred\x1B;[39m line\x1B;[24m"))
+      (test '(span "plain "
+                   (u "under "
+                      (span (@ (style . "color:red")) "red")
+                      " line"))
+          (ansi->sxml
+           "plain \x1B;[4munder \x1B;[31mred\x1B;[39m line\x1B;[24m"))
+      (test '(code "(" "string?" " "
+                   (span (@ (class . "string")) "\"hello\"")
+                   ")")
+          (expand-docs '(scheme "(string? \"hello\")")
+                       (make-default-doc-env)))
+      (test '(code "(" "string?" " "
+                   (span (@ (class . "string")) "\"<hello>\"")
+                   ")")
+          (expand-docs '(scheme "(string? \"<hello>\")")
+                       (make-default-doc-env)))
       (test-end))))

lib/chibi/doc.scm

@@ -79,6 +79,95 @@
 (define (sxml->sexp-list x)
   (call-with-input-string (sxml-strip x) port->sexp-list))
 
+;;> Replace ansi escape sequences in a \var{str} with the corresponding sxml.
+(define (ansi->sxml str)
+  ;; TODO: ick
+  (let ((start (string-cursor-start str))
+        (end (string-cursor-end str)))
+    (let lp1 ((from start)
+              (to start)
+              (res '()))
+      (define (lookup str)
+        (case (string->number str)
+          ((0) '/) ((1) 'b) ((3) 'i) ((4) 'u) ((9) 's)
+          ((22) '/b) ((23) '/i) ((24) '/u) ((29) '/s)
+          ((30) 'black) ((31) 'red) ((32) 'green) ((33) 'yellow)
+          ((34) 'blue) ((35) 'magenta) ((36) 'cyan) ((37) 'white)
+          ((39) '/color)
+          (else #f)))
+      (define (collect from to res)
+        (if (string-cursor<? from to)
+            (cons (substring-cursor str from to) res)
+            res))
+      (define (finish)
+        (let ((ls (reverse (collect from to res))))
+          (if (and (= 1 (length ls)) (string? (car ls)))
+              (car ls)
+              (let lp1 ((ls ls) (cur '()) (res '()))
+                (define (close to)
+                  (let lp2 ((ls cur) (tmp '()))
+                    (cond
+                     ((null? ls)
+                      (list '() `(,@(reverse tmp) ,@res)))
+                     ((eq? to (car ls))
+                      (list (cdr ls) `((,to ,@tmp) ,@res)))
+                     ((and (eq? to 'color) (memq (car ls) '(b i u s)))
+                      ;; color close came to an open non-color
+                      ;; back off and leave this open
+                      (let ((s `(,(car ls) ,@(take-while string? tmp)))
+                            (tmp (drop-while string? tmp)))
+                        (list `(,@(reverse tmp) ,@(reverse s)) res)))
+                     ((symbol? (car ls))
+                      (lp2 (cdr ls) `((,(car ls) ,@(reverse tmp)))))
+                     ((and (pair? (car ls)) (eq? 'color to))
+                      (lp2 (cdr ls) `((,@(car ls) ,@(reverse tmp)))))
+                     ((pair? (car ls))
+                      (lp2 (cdr ls) `(,(car ls) ,@(reverse tmp))))
+                     (else
+                      (lp2 (cdr ls) `(,(car ls) ,@tmp))))))
+                (cond
+                 ((null? ls)
+                  `(span ,@(reverse (cadr (close #f)))))
+                 ((and (string? (car ls)) (pair? cur))
+                  (lp1 (cdr ls) (cons (car ls) cur) res))
+                 ((string? (car ls))
+                  (lp1 (cdr ls) cur (cons (car ls) res)))
+                 (else
+                  (case (car ls)
+                    ((b i u s) (lp1 (cdr ls) (cons (car ls) cur) res))
+                    ((/b) (apply lp1 (cdr ls) (close 'b)))
+                    ((/i) (apply lp1 (cdr ls) (close 'i)))
+                    ((/u) (apply lp1 (cdr ls) (close 'u)))
+                    ((/s) (apply lp1 (cdr ls) (close 's)))
+                    ((/) (apply lp1 (cdr ls) (close 'all)))
+                    ((/color) (apply lp1 (cdr ls) (close 'color)))
+                    (else
+                     (let ((style (string-append "color:"
+                                                 (symbol->string (car ls)))))
+                       (lp1 (cdr ls)
+                            (cons `(span (@ (style . ,style))) cur)
+                            res))))))))))
+      (if (string-cursor>=? to end)
+          (finish)
+          (let ((c (string-cursor-ref str to))
+                (sc2 (string-cursor-next str to)))
+            (if (and (= 27 (char->integer c))
+                     (string-cursor<? sc2 end)
+                     (eqv? #\[ (string-cursor-ref str sc2)))
+                (let ((sc3 (string-cursor-next str sc2)))
+                  (let lp2 ((sc4 sc3))
+                    (if (string-cursor>=? sc4 end)
+                        (finish)
+                        (let ((c2 (string-cursor-ref str sc4))
+                              (sc5 (string-cursor-next str sc4)))
+                          (if (eqv? #\m c2)
+                              (let ((code (lookup
+                                           (substring-cursor str sc3 sc4)))
+                                    (res (collect from to res)))
+                                (lp1 sc5 sc5 (if code (cons code res) res)))
+                              (lp2 sc5))))))
+                (lp1 from sc2 res)))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;;> Extract the literate Scribble docs for module \var{mod-name} and
@@ -88,9 +177,11 @@
 (define (print-module-docs mod-name . o)
   (let ((out (if (pair? o) (car o) (current-output-port)))
         (render (or (and (pair? o) (pair? (cdr o)) (cadr o))
-                    sxml-display-as-text)))
+                    sxml-display-as-text))
+        (unexpanded?
+         (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (car (cddr o)))))
     (render
-     (generate-docs
+     ((if unexpanded? (lambda (sxml env) (fixup-docs sxml)) generate-docs)
       `((title ,(write-to-string mod-name))
         ,@(extract-module-docs mod-name #f))
       (make-module-doc-env mod-name))
@@ -176,6 +267,8 @@
      (url . ,expand-url)
      (hyperlink . ,expand-hyperlink)
      (rawcode . code)
+     (pre . pre)
+     (bibitem . ,(lambda (x env) '()))  ;; TODO: bibtex
      (code . ,expand-code)
      (codeblock . ,expand-codeblock)
      (ccode
@@ -195,6 +288,7 @@
      (margin-note . ,expand-note)
      (example . ,expand-example)
      (example-import . ,expand-example-import)
+     (example-import-only . ,expand-example-import-only)
      )))
 
 ;;> Return a new document environment as in
@@ -206,9 +300,9 @@
 (define (make-module-doc-env mod-name)
   (env-extend (make-default-doc-env)
               '(example-env)
-              (list (environment '(scheme small)
+              (list (delay (environment '(scheme small)
                                         '(only (chibi) import)
-                                 mod-name))))
+                                        mod-name)))))
 
 (define (section-name tag name)
   (string-strip
@@ -269,21 +363,41 @@
 
 (define (expand-example x env)
   (let ((expr `(begin ,@(sxml->sexp-list x)))
-        (example-env (or (env-ref env 'example-env) (current-environment))))
+        (example-env
+         (force (or (env-ref env 'example-env) (current-environment)))))
     `(div
       ,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
-      (code
-       (div (@ (class . "result"))
-            ,(call-with-output-string
-               (lambda (out)
-                 (protect (exn (#t (print-exception exn out)))
-                   (let ((res (eval expr example-env)))
-                     (display "=> " out)
-                     (write res out))))))))))
+      ,(let* ((res-out (open-output-string))
+              (tmp-out (open-output-string))
+              (tmp-err (open-output-string))
+              (res (parameterize ((current-output-port tmp-out)
+                                  (current-error-port tmp-err))
+                     (protect (exn (#t (print-exception exn tmp-err)))
+                       (eval expr example-env)))))
+         (display "=> " res-out)
+         (write res res-out)
+         (let ((res-str (get-output-string res-out))
+               (out-str (get-output-string tmp-out))
+               (err-str (get-output-string tmp-err)))
+           `(,@(if (string-null? out-str)
+                   '()
+                   `((div (@ (class . "output")) (pre ,(ansi->sxml out-str)))))
+             ,@(if (string-null? err-str)
+                   '()
+                   `((div (@ (class . "error")) (pre ,(ansi->sxml err-str)))))
+             ,@(if (and (or (not (string-null? err-str))
+                            (not (string-null? out-str)))
+                        (eq? res (if #f #f)))
+                   '()
+                   `((div (@ (class . "result")) (code ,res-str))))))))))
 
 (define (expand-example-import x env)
   (eval `(import ,@(cdr x))
-        (or (env-ref env 'example-env) (current-environment)))
+        (force (or (env-ref env 'example-env) (current-environment))))
+  "")
+
+(define (expand-example-import-only x env)
+  (env-set! env 'example-env (apply environment (cdr x)))
   "")
 
 (define (expand-command sxml env)
@@ -315,7 +429,7 @@
     sxml)))
 
 (define (expand-procedure sxml env)
-  ((expand-section 'h3) `(,(car sxml) (rawcode ,@(cdr sxml))) env))
+  ((expand-section 'h4) `(,(car sxml) (rawcode ,@(cdr sxml))) env))
 
 (define (expand-macro sxml env)
   (expand-procedure sxml env))
@@ -354,31 +468,45 @@
 (define (get-contents x)
   (if (null? x)
       '()
-      (let ((d (caar x)))
-        (let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '()))
+      (let lp ((ls (cdr x))
+               (depth (caar x))
+               (parent (cadr (car x)))
+               (kids '())
+               (res '()))
         (define (collect)
           (cons `(li ,parent ,(get-contents (reverse kids))) res))
         ;; take a span of all sub-headers, recurse and repeat on next span
         (cond
          ((null? ls)
           `(ol ,@(reverse (collect))))
-           ((> (caar ls) d)
-            (lp (cdr ls) parent (cons (car ls) kids) res))
+         ((> (caar ls) depth)
+          (lp (cdr ls) depth parent (cons (car ls) kids) res))
          (else
-            (lp (cdr ls) (car (cdar ls)) '() (collect))))))))
+          (lp (cdr ls) (caar ls) (cadr (car ls)) '() (collect)))))))
 
 (define (fix-header x)
-  `(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
+  `((!DOCTYPE html)
+    (html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
                         (else '()))
                 "\n"
+                (meta (@ (charset . "UTF-8")))
                 (style (@ (type . "text/css"))
                   "
-body {color: #000; background-color: #FFF}
-div#menu  {font-size: smaller; position: absolute; top: 50px; left: 0; width: 190px; height: 100%}
-div#main  {position: absolute; top: 0; left: 200px; width: 540px; height: 100%}
-div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;}
+body {color: #000; background-color: #FFFFF8;}
+div#menu  {font-size: smaller; position: absolute; top: 50px; left: 0; width: 250px; height: 100%}
+div#menu a:link {text-decoration: none}
+div#main  {font-size: large; position: absolute; top: 0; left: 260px; max-width: 590px; height: 100%}
+div#notes {position: relative; top: 2em; left: 620px; width: 200px; height: 0px; font-size: smaller;}
 div#footer {padding-bottom: 50px}
+div#menu ol {list-style-position:inside; padding-left: 5px; margin-left: 5px}
+div#menu ol ol {list-style: lower-alpha; padding-left: 15px; margin-left: 15px}
+div#menu ol ol ol {list-style: decimal; padding-left: 5px; margin-left: 5px}
+h2 { color: #888888; border-top: 3px solid #4588ba; }
+h3 { color: #666666; border-top: 2px solid #4588ba; }
+h4 { color: #222288; border-top: 1px solid #4588ba; }
 .result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
+.output { color: #000; background-color: beige; width: 100%; padding: 3px}
+.error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px}
 .command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
 "
                   ,(highlight-style))
@@ -397,7 +525,7 @@ div#footer {padding-bottom: 50px}
                              (cons 'h1 (cdr x))
                              x))
                        x)
-               (div (@ (id . "footer")))))))
+                (div (@ (id . "footer"))))))))
 
 (define (fix-paragraphs x)
   (let lp ((ls x) (p '()) (res '()))
@@ -513,10 +641,14 @@ div#footer {padding-bottom: 50px}
                      ((v ('if ('and ('pair? (? o?)) ('pair? ('cdr (? o?))))
                              ('cadr (? o?))
                              default))
-                      (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
+                      (lp (cdr ls)
+                          (cons (cons v (+ 1 (if ordered? j i))) vars)
+                          j))
                      ((v ('and ('pair? (? o?)) ('pair? ('cdr (? o?)))
                                ('cadr (? o?))))
-                      (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
+                      (lp (cdr ls)
+                          (cons (cons v (+ 1 (if ordered? j i))) vars)
+                          j))
                      (else
                       (lp (cdr ls) vars j))))
                   (else
@@ -528,14 +660,13 @@ div#footer {padding-bottom: 50px}
              (let lp ((ls var) (vars vars) (i i))
                (cond
                 ((pair? ls)
-                 (lp (cdr ls) (cons (cons (caar ls) i) vars) (+ i 1)))
+                 (lp (cdr ls) (cons (cons (car ls) i) vars) (+ i 1)))
                 (else
                  (extract body vars i)))))
-            (else
-             (let ((opts (map car (sort vars < cdr)))
-                   (rest-var? (contains? x o)))
-               (append (reverse pre)
-                       (cond
+            (_
+             (let* ((opts (map car (sort vars < cdr)))
+                    (rest-var? (contains? x o))
+                    (tail (cond
                            ((and (pair? opts) rest-var?)
                             (list (append opts o)))
                            (rest-var?
@@ -543,17 +674,19 @@ div#footer {padding-bottom: 50px}
                            ((pair? opts)
                             (list opts))
                            (else
-                         '()))))))))))))
+                            o))))
+               (append (reverse pre) tail))))))))))
 
 (define (get-procedure-signature mod id proc)
+  (protect (exn (else '()))
     (cond ((and mod (procedure? proc) (procedure-signature id mod))
            => (lambda (sig)
                 (list (cons (or id (procedure-name proc)) (cdr sig)))))
-        (else '())))
+          (else '()))))
 
 (define (get-value-signature mod id proc name value)
   (match value
-    (('(or let let* letrec letrec*) vars body0 ... body)
+    (((or 'let 'let* 'letrec 'letrec*) vars body0 ... body)
      (get-value-signature mod id proc name body))
     (('lambda args . body)
      (list (cons name (get-optionals-signature args body))))
@@ -562,8 +695,6 @@ div#footer {padding-bottom: 50px}
     (('begin body0 ... body) (get-value-signature mod id proc name body))
     (else (get-procedure-signature mod id proc))))
 
-;; TODO: analyze and match on AST instead of making assumptions about
-;; bindings
 (define (get-signature mod id proc source form)
   (match form
     (('define (name args ...) . body)
@@ -577,7 +708,11 @@ div#footer {padding-bottom: 50px}
      (map (lambda (x) (cons name (cdr x)))
           (filter external-clause? clause)))
     (else
-     (get-procedure-signature mod id proc))))
+     (cond
+      ((procedure-analysis proc mod)
+       => (lambda (lam) (list (cons (lambda-name lam) (lambda-params lam)))))
+      (else
+       (get-procedure-signature mod id proc))))))
 
 (define (get-ffi-signatures form)
   (match form
@@ -590,6 +725,8 @@ div#footer {padding-bottom: 50px}
                               args)))))
     (('define-c-const type (or (name _) name))
      (list (list 'const: type name)))
+    (('cond-expand (test . clauses) . rest)
+     (append-map get-ffi-signatures clauses))
     (((or 'define-c-struct 'define-c-class 'define-c-type) name . rest)
      (let lp ((ls rest) (res '()))
        (cond
@@ -618,7 +755,7 @@ div#footer {padding-bottom: 50px}
   (let ((sections '(section subsection subsubsection subsubsubsection)))
     (lambda (x)
       (cond ((memq x sections) => length)
-            ((memq x '(procedure macro)) (section-number 'subsection))
+            ((memq x '(procedure macro)) (section-number 'subsubsection))
             (else 0)))))
 
 (define (section>=? x n)
@@ -676,9 +813,10 @@ div#footer {padding-bottom: 50px}
       (write-to-string sig)))
 
 (define (insert-signature orig-ls name sig)
+  (let ((sig (if (pair? sig) sig (and name (list name)))))
     (cond
     ((not (pair? sig))
-    orig-ls)
+     '())
     (else
      (let ((name
             (cond
@@ -689,15 +827,16 @@ div#footer {padding-bottom: 50px}
        (let lp ((ls orig-ls) (rev-pre '()))
          (cond
           ((or (null? ls)
-              (section>=? (car ls) (section-number 'subsection)))
+               (section>=? (car ls) (section-number 'subsubsection)))
            `(,@(reverse rev-pre)
              ,@(if (and (pair? ls)
                         (section-describes?
-                        (extract-sxml '(subsection procedure macro)
+                         (extract-sxml
+                          '(subsubsection procedure macro)
                           (car ls))
                          name))
                    '()
-                  `((subsection
+                   `((subsubsection
                       tag: ,(write-to-string name)
                       (rawcode
                        ,@(if (and (pair? (car sig)) (eq? 'const: (caar sig)))
@@ -706,7 +845,7 @@ div#footer {padding-bottom: 50px}
                              (intersperse (map write-signature sig) '(br)))))))
              ,@ls))
           (else
-          (lp (cdr ls) (cons (car ls) rev-pre)))))))))
+           (lp (cdr ls) (cons (car ls) rev-pre))))))))))
 
 ;;> Extract inline Scribble documentation (with the ;;> prefix) from
 ;;> the source file \var{file}, associating any signatures from the
@@ -714,17 +853,22 @@ div#footer {padding-bottom: 50px}
 
 (define (extract-file-docs mod file all-defs strict? . o)
   ;; extract (<file> . <line>) macro source or
-  ;; (<offset> <file . <line>>) procedure source
+  ;; (<offset> <file . <line>) procedure source or
+  ;; ((<offset> <file . <line>) ...) bytecode sources
   (define (source-line source)
     (and (pair? source)
-         (if (string? (car source))
+         (cond
+          ((string? (car source))
            (and (equal? file (car source))
                 (number? (cdr source))
-                  (cdr source))
+                (cdr source)))
+          ((pair? (car source))
+           (source-line (car source)))
+          (else
            (and (number? (car source))
                 (pair? (cdr source))
                 (equal? file (cadr source))
-                  (cddr source)))))
+                (cddr source))))))
   (define (read-to-paren in)
     (let lp1 ((res '()))
       (let ((ch (peek-char in)))
@@ -894,21 +1038,28 @@ div#footer {padding-bottom: 50px}
         (else #f)))
 
 ;; helper for below functions
-(define (extract-module-docs-from-files mod srcs includes stubs strict? exports)
-  (let ((defs (map (lambda (x)
-                     (let ((val (and mod (module-ref mod x))))
+(define (extract-module-docs-from-files mod srcs includes stubs strict? exports . o)
+  (let ((dir (or (and (pair? o) (car o)) (module-dir mod)))
+        (defs (map (lambda (x)
+                     (let ((val (and mod (protect (exn (else #f))
+                                           (module-ref mod x)))))
                        `(,x ,val ,(object-source val))))
                    exports)))
+    (define (resolve-file file)
+      (let ((res (make-path dir file)))
+        (if (file-exists? res)
+            res
+            file)))
     (append
      (reverse
       (append-map (lambda (x)
-                    (extract-file-docs mod x defs strict? 'module))
+                    (extract-file-docs mod (resolve-file x) defs strict? 'module))
                   srcs))
      (reverse
-      (append-map (lambda (x) (extract-file-docs mod x defs strict?))
+      (append-map (lambda (x) (extract-file-docs mod (resolve-file x) defs strict?))
                   includes))
      (reverse
-      (append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
+      (append-map (lambda (x) (extract-file-docs mod (resolve-file x) defs strict? 'ffi))
                   stubs)))))
 
 ;;> Extract the literate Scribble docs from module \var{mod-name} and
@@ -939,30 +1090,55 @@ div#footer {padding-bottom: 50px}
                   (memq (caar forms) '(define-library library))))
         (error "file doesn't define a library" file))
     (let* ((mod-form (car forms))
-           (mod-name (cadr mod-form)))
-      (load file (vector-ref (find-module '(meta)) 1))
-      (let* ((mod (protect (exn (else #f)) (load-module mod-name)))
-             (dir (path-directory file))
-             (resolve (lambda (f) (make-path dir f))))
-        (define (get-forms name)
+           (mod-name (cadr mod-form))
+           (lib-dir (module-lib-dir file mod-name))
+           (orig-mod-path (current-module-path))
+           (new-mod-path (cons lib-dir orig-mod-path))
+           (mod (protect (exn (else #f))
+                  (dynamic-wind
+                    (lambda () (current-module-path new-mod-path))
+                    (lambda ()
+                      (let ((mod (load-module mod-name)))
+                        (protect (exn (else #f)) (analyze-module mod-name))
+                        mod))
+                    (lambda () (current-module-path orig-mod-path)))))
+           (dir (path-directory file)))
+      (define (get-forms ls names dir . o)
+        (let ((resolve? (and (pair? o) (car o))))
+          (let lp ((ls ls) (res '()))
+            (if (null? ls)
+                (reverse res)
+                (let ((x (car ls)))
+                  (lp (cdr ls)
+                      (append
+                       (if (and (pair? x) (memq (car x) names))
+                           (map (lambda (y)
+                                  (if (and resolve? (string? y))
+                                      (make-path dir y)
+                                      y))
+                                (reverse (cdr x)))
+                           '())
+                       (if (and (pair? x)
+                                (eq? 'include-library-declarations (car x)))
                            (append-map
-           (lambda (x) (if (and (pair? x) (eq? name (car x))) (cdr x) '()))
-           (cddr mod-form)))
+                            (lambda (inc)
+                              (let* ((file (make-path dir inc))
+                                     (sexps (file->sexp-list file))
+                                     (dir (path-directory file)))
+                                (get-forms sexps names dir resolve?)))
+                            (cdr x))
+                           '())
+                       res)))))))
       (define (get-exports)
-          (if mod (module-exports mod) (get-forms 'exports)))
+        (if mod (module-exports mod) (get-forms (cddr mod-form) '(exports) dir)))
       (define (get-decls)
-          (if mod
-              (module-include-library-declarations mod)
-              (map resolve (get-forms 'include-library-declarations))))
+        (get-forms (cddr mod-form) '(include-library-declarations) dir #t))
       (define (get-includes)
-          (if mod
-              (module-includes mod)
-              (map resolve (get-forms 'include))))
+        (get-forms (cddr mod-form) '(include include-ci) dir #t))
       (define (get-shared-includes)
-          (if mod
-              (module-shared-includes mod)
-              (map resolve (get-forms 'shared-include))))
+        (map (lambda (f) (string-append f ".stub"))
+             (get-forms (cddr mod-form) '(include-shared) dir #t)))
       (let* ((exports (if (pair? o) (car o) (get-exports)))
              (srcs (cons file (get-decls))))
         (extract-module-docs-from-files
-           mod srcs (get-includes) (get-shared-includes) strict? exports))))))
+         mod srcs (get-includes) (get-shared-includes) strict? exports)))))

lib/chibi/doc.sld

@@ -1,7 +1,7 @@
 
 (define-library (chibi doc)
   (import
-   (except (chibi) eval) (scheme eval) (srfi 1) (srfi 95)
+   (except (chibi) eval) (scheme eval) (srfi 1) (srfi 39) (srfi 95)
    (chibi modules) (chibi ast) (chibi io) (chibi match)
    (chibi time) (chibi filesystem) (chibi process) (chibi pathname)
    (chibi string) (chibi scribble) (chibi sxml) (chibi highlight)
@@ -11,5 +11,6 @@
           generate-docs expand-docs fixup-docs
           extract-module-docs extract-module-file-docs extract-file-docs
           make-default-doc-env make-module-doc-env
-          get-optionals-signature)
+          get-optionals-signature
+          ansi->sxml)
   (include "doc.scm"))

lib/chibi/edit-distance-test.sld

@@ -0,0 +1,14 @@
+
+(define-library (chibi edit-distance-test)
+  (export run-tests)
+  (import (scheme base) (chibi edit-distance) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "(chibi edit-distance)")
+      (test 0 (edit-distance "" ""))
+      (test 0 (edit-distance "same" "same"))
+      (test 1 (edit-distance "same" "game"))
+      (test 2 (edit-distance "same" "sand"))
+      (test 3 (edit-distance "kitten" "sitting"))
+      (test 3 (edit-distance "Saturday" "Sunday"))
+      (test-end))))

lib/chibi/edit-distance.sld

@@ -0,0 +1,52 @@
+
+(define-library (chibi edit-distance)
+  (export edit-distance find-nearest-edits)
+  (import (scheme base) (srfi 130))
+  (begin
+    ;;> Returns the levenshtein distance between s1 and s2 - a cost of
+    ;;> 1 per character insertion, deletion or update.  Runs in
+    ;;> quadratic time and linear memory.
+    ;;>
+    ;;> \example{(edit-distance "same" "same")}
+    ;;> \example{(edit-distance "same" "sand")}
+    ;;> \example{(edit-distance "Saturday" "Sunday")}
+    (define (edit-distance s1 s2)
+      (let* ((len1 (string-length s1))
+             (len2 (string-length s2))
+             (vec (make-vector (+ len1 1) 0)))
+        (do ((i 0 (+ i 1)))
+            ((> i len1))
+          (vector-set! vec i i))
+        (do ((i 1 (+ i 1))
+             (sc2 (string-cursor-start s2) (string-cursor-next s2 sc2)))
+            ((> i len2)
+             (vector-ref vec len1))
+          (vector-set! vec 0 i)
+          (let ((ch2 (string-ref/cursor s2 sc2)))
+            (let lp ((j 1)
+                     (sc1 (string-cursor-start s1))
+                     (last-diag (- i 1)))
+              (when (<= j len1)
+                (let ((old-diag (vector-ref vec j))
+                      (ch1 (string-ref/cursor s1 sc1)))
+                  (vector-set! vec j (min (+ (vector-ref vec j) 1)
+                                          (+ (vector-ref vec (- j 1)) 1)
+                                          (+ last-diag
+                                             (if (eqv? ch1 ch2) 0 1))))
+                  (lp (+ j 1)
+                      (string-cursor-next s1 sc1)
+                      old-diag))))))))
+    ;;> Returns a list of strings in \var{str-ls} with the smallest
+    ;;> edit distance to \var{str}, preserving order.  If
+    ;;> \var{max-distance} is provided and positive, only return if
+    ;;> the edits are less or equal to that distance.
+    (define (find-nearest-edits str str-ls . o)
+      (let ((max-distance (if (pair? o) (car o) 1e100)))
+        (let lp ((ls str-ls) (dist (+ max-distance 1)) (res '()))
+          (if (null? ls)
+              (reverse res)
+              (let ((ed (edit-distance str (car ls))))
+                (cond
+                 ((= ed dist) (lp (cdr ls) dist (cons (car ls) res)))
+                 ((< ed dist) (lp (cdr ls) ed (list (car ls))))
+                 (else (lp (cdr ls) dist res))))))))))

lib/chibi/equiv.scm

@@ -45,5 +45,5 @@
                              (lp (- i 1))))))))))
        (else
         (equal? a b))))
-    (let ((res (equal?/bounded a b 100000 100000)))
+    (let ((res (equal?/bounded a b 10000 10000)))
       (and res (or (> res 0) (equiv? a b)) #t))))

lib/chibi/filesystem-test.sld

@@ -1,7 +1,14 @@
 (define-library (chibi filesystem-test)
   (export run-tests)
-  (import (chibi) (chibi io) (chibi filesystem) (chibi test) (srfi 33))
+  (import (scheme base) (scheme file) (scheme write)
+          (chibi filesystem) (chibi test))
+  (cond-expand
+   ((library (srfi 151)) (import (srfi 151)))
+   ((library (srfi 33)) (import (srfi 33)))
+   (else (import (srfi 60))))
   (begin
+    (define (port->string in)
+      (read-string 1024 in))
     (define (run-tests)
       (define tmp-file "/tmp/chibi-fs-test-0123456789")
       (define tmp-file2 "/tmp/chibi-fs-test-0123456789-2")

lib/chibi/filesystem.scm

@@ -10,10 +10,11 @@
   (let ((mode (if (pair? o) (car o) #o755)))
     (or (file-directory? dir)
         (create-directory dir mode)
-        (let ((slash
-               (string-find-right dir #\/ 0 (string-skip-right dir #\/))))
-          (and (> slash 0)
-               (let ((parent (substring-cursor dir 0 slash)))
+        (let* ((start (string-cursor-start dir))
+               (slash
+                (string-find-right dir #\/ start (string-skip-right dir #\/))))
+          (and (string-cursor>? slash start)
+               (let ((parent (substring-cursor dir start slash)))
                  (and (not (equal? parent dir))
                       (not (file-exists? parent))
                       (create-directory* parent mode)
@@ -77,7 +78,7 @@
 (define (delete-file file)
   (if (not (%delete-file file))
       (raise-continuable
-       (make-exception 'file "couldn't delete file" file delete-file #f))))
+       (make-exception 'file "couldn't delete file" (list file) delete-file #f))))
 
 ;;> Recursively delete all files and directories under \var{dir}.
 ;;> Unless optional arg \var{ignore-errors?} is true, raises an error
@@ -103,7 +104,9 @@
 (define (with-directory dir thunk)
   (let ((pwd (current-directory)))
     (dynamic-wind
-      (lambda () (change-directory dir))
+      (lambda ()
+        (if (not (change-directory dir))
+            (error "couldn't change directory" dir)))
       thunk
       (lambda () (change-directory pwd)))))
 
@@ -122,10 +125,18 @@
 (define (file-group x) (stat-gid (if (stat? x) x (file-status x))))
 (define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x))))
 (define (file-size x) (stat-size (if (stat? x) x (file-status x))))
-(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
-(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))
+(cond-expand
+  (windows
+    (define (file-block-size x) 1)
+    (define (file-num-blocks x) (file-size x)))
+  (else
+    (define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
+    (define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))))
 (define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
 (define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
+(define (file-modification-time/safe x)
+  (let ((status (if (stat? x) x (file-status x))))
+    (and status (stat-mtime status))))
 (define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
 
 ;;> File status accessors.  \var{x} should be a string indicating
@@ -145,9 +156,13 @@
 (define (file-character? x) (file-test-mode S_ISCHR x))
 (define (file-block? x) (file-test-mode S_ISBLK x))
 (define (file-fifo? x) (file-test-mode S_ISFIFO x))
-(define (file-link? x)
+(cond-expand
+  (windows
+    (define (file-link? x) #f))
+  (else
+    (define (file-link? x)
       (let ((st (if (stat? x) x (file-link-status x))))
-    (and st (S_ISLNK (stat-mode st)))))
+       (and st (S_ISLNK (stat-mode st)))))))
 (define (file-socket? x) (file-test-mode S_ISSOCK x))
 (define (file-exists? x) (and (if (stat? x) #t (file-status x)) #t))
 
@@ -176,8 +191,12 @@
 ;;> Returns the path the symbolic link \var{file} points to, or
 ;;> \scheme{#f} on error.
 
-(define (read-link file)
+(cond-expand
+  (windows
+    (define (read-link file) #f))
+  (else
+    (define (read-link file)
       (let* ((buf (make-string 512))
              (res (readlink file buf 512)))
         (and (positive? res)
-         (substring buf 0 res))))
+             (substring buf 0 res))))))