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

@@ -46,18 +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
@@ -70,3 +82,5 @@ tmp
 
 js/chibi.*
 
+build-lib/chibi/char-set/derived.scm
+build-lib/chibi/char-set/width.scm

AUTHORS

@@ -1,8 +1,8 @@
 Alex Shinn wrote the initial version of chibi-scheme and all
 distributed modules.
 
-The Emscripten build, SRFI 139 implementation, and various other
+The Emscripten build, syntax-case and SRFI 139 implementation, and
-patches were contributed by Marc Nieper-Wißkirchen.
+various other patches were contributed by Marc Nieper-Wißkirchen.
 
 The image handling code in gc_heap.c was written by Chris Walsh.
 
@@ -14,11 +14,16 @@ 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
@@ -27,35 +32,57 @@ 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
+  * Vasilij Schneidermann
+  * Vitaliy Mysak
+  * Yota Toyama
   * Yuki Okumura
 
 If you would prefer not to be listed, or are one of the users listed

CMakeLists.txt

@@ -1,20 +1,28 @@
-#
-# FIXME: This CMakeLists.txt is only for Win32 platforms for now
-#
 
-cmake_minimum_required(VERSION 2.8.7)
+cmake_minimum_required(VERSION 3.12)
-project(chibi-scheme)
+
+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)
 
-if(APPLE)
+set(CMAKE_EXPORT_COMPILE_COMMANDS ON)
-    message(FATAL_ERROR 
-        "DYLD platforms are not supported with this CMakeLists.txt. Use Makefile instead.")
-endif()
 
-if(UNIX)
+set(CMAKE_BUILD_TYPE "${CMAKE_BUILD_TYPE}" CACHE STRING
-    message(FATAL_ERROR 
+    "Build type: None, Debug, Release, RelWithDebInfo, MinSizeRel, or Sanitizer." FORCE)
-        "UNIX platforms are not supported with this CMakeLists.txt. Use Makefile instead.")
+
+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()
 
 #
@@ -22,48 +30,77 @@ endif()
 #
 
 check_include_file(poll.h HAVE_POLL_H)
-check_include_file(stdint.h HAVE_STDINT_H)
+check_symbol_exists(ntp_gettime sys/timex.h HAVE_NTP_GETTIME)
-# option(CHIBI_SCHEME_USE_DL "Use dynamic loading" ON)
+check_symbol_exists(int_least8_t inttypes.h HAVE_STDINT_H)
-set(CHIBI_SCHEME_USE_DL OFF)
 
-if(CHIBI_SCHEME_USE_DL)
+if (WIN32 AND NOT CYGWIN)
-    add_definitions(-DSEXP_USE_DL=1)
+    set(DEFAULT_SHARED_LIBS OFF)
 else()
-    add_definitions(-DSEXP_USE_DL=0)
+    set(DEFAULT_SHARED_LIBS ON)
 endif()
 
-if(CMAKE_SIZEOF_VOID_P EQUAL 8)
+option(BUILD_SHARED_LIBS "Build chibi-scheme as a shared library" ${DEFAULT_SHARED_LIBS})
-    if(MSVC)
+option(SEXP_USE_BOEHM "Use Boehm garbage collection library" OFF)
-        # On MSVC, SEXP_64_BIT is not supported for now (#438)
-        add_definitions(-DSEXP_64_BIT=0)
-    else()
-        add_definitions(-DSEXP_64_BIT=1)
-    endif()
-elseif(CMAKE_SIZEOF_VOID_P EQUAL 4)
-    add_definitions(-DSEXP_64_BIT=0)
-endif()
 
-if(HAVE_STDINT_H)
+if(SEXP_USE_BOEHM)
-    add_definitions(-DSEXP_USE_INTTYPES=1)
+    find_library(BOEHMGC gc REQUIRED)
-endif()
+    find_path(BOEHMGC_INCLUDE NAMES gc/gc.h)
-
-if(NOT HAVE_POLL_H)
-    # Disable green threads: It depends on non-blocking I/O
-    add_definitions(-DSEXP_USE_GREEN_THREADS=0)
 endif()
 
 set(chibi-scheme-exclude-modules)
 if(WIN32)
-    add_definitions(-DBUILDING_DLL)
     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/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
 #
@@ -81,65 +118,163 @@ set(chibi-scheme-srcs
     eval.c
     simplify.c)
 
-include_directories(
-    include
-    ${CMAKE_CURRENT_BINARY_DIR}/include)
-
 #
 # Bootstrap
 #
 
 add_executable(chibi-scheme-bootstrap
+    EXCLUDE_FROM_ALL
     ${chibi-scheme-srcs}
     main.c)
 
-if(WIN32)
+target_link_libraries(chibi-scheme-bootstrap PRIVATE libchibi-common)
-    target_link_libraries(chibi-scheme-bootstrap ws2_32)
+
-endif()
+
+#
+# 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})
 
-if(CYGWIN OR WIN32)
-    set(soext ".dll")
-else()
-    set(soext ".so")
-endif()
 
 #
 # Generate modules
 #
 
-# FIXME: Currently, it depends on GLOB thus we have to re-run CMake
-#        when we've gotten additional/removed library 
-
-file(GLOB_RECURSE stubs RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib 
-    ${CMAKE_CURRENT_SOURCE_DIR}/lib/*.stub)
 file(GLOB_RECURSE slds RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}
-    ${CMAKE_CURRENT_SOURCE_DIR}/lib/*.sld)
+    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)
 
-set(stuboutdir ${CMAKE_CURRENT_BINARY_DIR}/stubs/lib)
+add_custom_target(chibi-compiled-libs)
-foreach(e ${stubs})
+
-    get_filename_component(stubdir ${e} PATH)
+function(add_compiled_library cfile)
-    get_filename_component(basename ${e} NAME_WE)
+    if (NOT BUILD_SHARED_LIBS)
-    set(stubfile ${CMAKE_CURRENT_SOURCE_DIR}/lib/${e})
+        return()
-    set(stubdir ${stuboutdir}/${stubdir})
+    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 chibi-scheme-bootstrap
+        COMMAND ${bootstrap} ${chibi-ffi} ${stubfile} ${stubout}
-        ${chibi-ffi} ${stubfile} ${stubout}
         DEPENDS ${stubfile} ${chibi-ffi}
         WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
-    list(APPEND stubouts ${stubout})
+
-endforeach()
+    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)
@@ -162,70 +297,75 @@ add_custom_command(OUTPUT ${clibout}
         ${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
 #
 
-include_directories(
-    .
-    ${stuboutdir}/..)
 add_executable(chibi-scheme
-    ${chibi-scheme-srcs}
-    ${clibout}
     main.c)
 
-set_target_properties(chibi-scheme
+target_link_libraries(chibi-scheme
-    PROPERTIES COMPILE_DEFINITIONS "SEXP_USE_STATIC_LIBS=1")
+    PRIVATE libchibi-scheme)
-
-add_dependencies(chibi-scheme chibi-scheme-stubs)
-
-if(WIN32)
-    target_link_libraries(chibi-scheme ws2_32)
-endif()
 
 #
 # Generate "chibi/install.h"
 #
 
-if(CYGWIN OR WIN32)
-    set(thePrefix "bin")
-else()
-    set(thePrefix "lib")
-endif()
-
-if(WIN32)
-    set(pathsep "\\;")
-else()
-    set(pathsep ":")
-endif()
-
 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 "unknown")
+    set(platform "unix")
 endif()
 
-file(READ ${CMAKE_CURRENT_SOURCE_DIR}/RELEASE release)
+if(WIN32)
-string(STRIP ${release} release)
+    # 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()
 
-file(READ ${CMAKE_CURRENT_SOURCE_DIR}/VERSION version)
+configure_file(include/chibi/install.h.in include/chibi/install.h)
-string(STRIP ${version} version)
-set(version "${version}-cmake")
-
-set(default_module_path
-    ""
-    #"${CMAKE_INSTALL_PREFIX}/${thePrefix}${pathsep}${CMAKE_INSTALL_PREFIX}/bin"
-    )
-
-file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/include/chibi)
-
-file(WRITE
-    ${CMAKE_CURRENT_BINARY_DIR}/include/chibi/install.h
-    "#define sexp_so_extension \"${soext}\"
-#define sexp_default_module_path \"${default_module_path}\"
-#define sexp_platform \"${platform}\"
-#define sexp_version \"\"
-#define sexp_release_name \"${release}\"")
 
 #
 # Testing
@@ -235,28 +375,27 @@ enable_testing()
 
 set(chibi-scheme-tests
     r7rs-tests
-    ## Not connected
+    division-tests
-    #division-tests
+    syntax-tests
-    #r5rs-tests
+    unicode-tests)
-    #syntax-tests
-    #unicode-tests
-    ## Require threads
-    # lib-tests
-    )
 
 foreach(e ${chibi-scheme-tests})
     add_test(NAME "${e}"
-        COMMAND chibi-scheme tests/${e}.scm
+        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
-    ${CMAKE_CURRENT_SOURCE_DIR}/lib/srfi/*/test.sld)
+    CONFIGURE_DEPENDS lib/srfi/*/test.sld)
 
 file(GLOB_RECURSE chibi_scheme_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
-    ${CMAKE_CURRENT_SOURCE_DIR}/lib/chibi/*-test.sld)
+    CONFIGURE_DEPENDS lib/chibi/*-test.sld)
 
-set(testexcludes
+set(win32testexcludes
     # Excluded tests
     chibi/filesystem-test
     chibi/memoize-test
@@ -270,22 +409,195 @@ set(testexcludes
     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
     )
 
-set(testlibs)
 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()
-list(REMOVE_ITEM testlibs ${testexcludes})
+
+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 -e "(import (${form}))"
+        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-2018 Alex Shinn
+Copyright (c) 2009-2021 Alex Shinn
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

Makefile

@@ -1,49 +1,33 @@
 # -*- 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)
+CHIBI_VERSION ?= $(shell cat VERSION)
-SOVERSION ?= $(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 ?= tools/snow-chibi
 
-TEMPFILE := $(shell mktemp -t chibi.XXXXXX)
-
-########################################################################
-
-# 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_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/emscripten$(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/net$(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)
@@ -51,91 +35,78 @@ CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
 	lib/chibi/optimize/profile$(SO)
 EXTRA_COMPILED_LIBS ?=
 
-ifndef EXCLUDE_POSIX_LIBS
-CHIBI_COMPILED_LIBS += $(CHIBI_POSIX_COMPILED_LIBS)
-else
-CHIBI_COMPILED_LIBS += $(CHIBI_WIN32_COMPILED_LIBS)
-endif
-
 COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
 	$(CHIBI_OPT_COMPILED_LIBS) $(CHIBI_CRYPTO_COMPILED_LIBS) \
 	$(EXTRA_COMPILED_LIBS) \
 	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/srfi/144/math$(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)
-ifndef EXCLUDE_POSIX_LIBS
-COMPILED_LIBS += lib/srfi/18/threads$(SO) 
-endif
 
 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 include/chibi/gc_heap.h
 
-MODULE_DOCS := app ast config disasm equiv filesystem generic heap-stats io \
+MODULE_DOCS := app assert ast base64 binary-record bytevector config \
-	loop match mime modules net parse pathname process repl scribble stty \
+	crypto/md5 crypto/rsa crypto/sha2 diff disasm doc edit-distance \
-	system test time trace type-inference uri weak monad/environment \
+	equiv filesystem generic heap-stats io \
-	show show/base crypto/sha2
+	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
 
 IMAGE_FILES = lib/chibi.img lib/red.img lib/snow.img
 
-HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
+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)
 
+# 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 -O3 chibi-scheme-static.bc -o $@ -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"` --pre-js js/pre.js --post-js js/post.js
+	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 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
+	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) dist-clean
+	$(MAKE) distclean
 	$(MAKE) chibi-scheme-static PLATFORM=emscripten SEXP_USE_DL=0
-	mv chibi-scheme-static$(EXE) $(TEMPFILE)
+	(tempfile="`mktemp -t chibi.XXXXXX`" && \
-	$(MAKE) dist-clean
+	mv chibi-scheme-static$(EXE) "$$tempfile" && \
-	mv $(TEMPFILE) chibi-scheme-emscripten
+	$(MAKE) distclean; \
+	mv "$$tempfile" chibi-scheme-emscripten)
 
-include/chibi/install.h: Makefile
+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 $@ $<
 
@@ -168,16 +139,20 @@ 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
@@ -185,14 +160,21 @@ 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 $@
@@ -208,9 +190,9 @@ 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
@@ -223,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/UnicodeData.txt chibi-scheme$(EXE) all-libs
+lib/chibi/show/width.scm: build-lib/chibi/char-set/width.scm chibi-scheme$(EXE)
-	$(CHIBI) tools/extract-case-offsets.scm $< > $@
+	$(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
@@ -270,7 +263,11 @@ test-snow: chibi-scheme$(EXE) $(IMAGE_FILES)
 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)
@@ -279,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
 
@@ -298,12 +302,15 @@ clean: clean-libs
 cleaner: clean
 	-$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \
 	    $(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-base: all
 	$(MKDIR) $(DESTDIR)$(BINDIR)
@@ -312,10 +319,10 @@ install-base: all
 	$(INSTALL) -m0755 tools/chibi-doc $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 tools/snow-chibi $(DESTDIR)$(BINDIR)/
 	$(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
+	$(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/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
+	$(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/
@@ -334,6 +341,7 @@ install-base: 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/
@@ -359,17 +367,29 @@ install-base: all
 	$(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/151 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/144
+	$(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
@@ -378,6 +398,7 @@ install-base: all
 	$(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)
@@ -392,14 +413,14 @@ install-base: all
 	$(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"
-	-cd / && LD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) -d $(DESTDIR)$(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) -mchibi.repl -d $(MODDIR)/chibi.img
-	-cd / && LD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) -xscheme.red -d $(DESTDIR)$(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) -xscheme.red -mchibi.repl -d $(MODDIR)/red.img
-	-cd / && LD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils -d $(DESTDIR)$(MODDIR)/snow.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:
@@ -414,7 +435,8 @@ uninstall:
 	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
 	-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
 	-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
-	-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
+	-$(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
@@ -438,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
@@ -451,21 +474,38 @@ uninstall:
 	-$(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)$(PKGCONFDIR)/chibi-scheme.pc
 
-dist: dist-clean
+dist: distclean
-	$(RM) chibi-scheme-$(VERSION).tgz
+	$(RM) chibi-scheme-$(CHIBI_VERSION).tgz
-	$(MKDIR) chibi-scheme-$(VERSION)
+	$(MKDIR) chibi-scheme-$(CHIBI_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
+	@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-$(VERSION).tgz chibi-scheme-$(VERSION)
+	$(TAR) cphzvf chibi-scheme-$(CHIBI_VERSION).tgz chibi-scheme-$(CHIBI_VERSION)
-	$(RM) -r chibi-scheme-$(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
@@ -473,7 +513,7 @@ 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
@@ -484,9 +524,11 @@ snowballs:
 	$(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 lib/chibi/iset/optimize.sld
-	$(SNOW_CHIBI) package -r lib/chibi/show.sld lib/chibi/show/pretty.sld
+	$(SNOW_CHIBI) package --doc https://srfi.schemers.org/srfi-115/srfi-115.html --test-library lib/srfi/115.sld
-	$(SNOW_CHIBI) package 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
@@ -494,6 +536,8 @@ snowballs:
 	$(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

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
@@ -35,6 +36,9 @@ else
 ifeq ($(shell uname -o),GNU/Linux)
 PLATFORM=linux
 else
+ifeq ($(shell uname),SunOS)
+PLATFORM=solaris
+else
 PLATFORM=unix
 endif
 endif
@@ -46,6 +50,11 @@ endif
 endif
 endif
 endif
+endif
+
+ifndef ARCH
+ARCH = $(shell uname -m)
+endif
 
 ########################################################################
 # Set default variables for the platform.
@@ -53,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
@@ -70,6 +80,15 @@ EXE =
 CLIBFLAGS = -fPIC
 CLINKFLAGS = -shared
 LIBDL = 
+RLDFLAGS=-Wl,-R$(LIBDIR)
+else
+ifeq ($(PLATFORM),solaris)
+SO = .so
+EXE =
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
+LIBDL = -ldl
+RLDFLAGS=-Wl,-R$(LIBDIR)
 else
 ifeq ($(PLATFORM),windows)
 SO  = .dll
@@ -80,6 +99,7 @@ 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)
@@ -90,6 +110,7 @@ CLIBFLAGS =
 CLINKFLAGS = -shared
 CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
 LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATIC_LDFLAGS = -lm -ldl
 else
 ifeq ($(PLATFORM),cygwin)
 SO  = .dll
@@ -99,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 =
@@ -106,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
@@ -116,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)
+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)
+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

@@ -21,21 +21,42 @@ MKDIR     ?= $(INSTALL) -d
 RMDIR     ?= rmdir
 TAR       ?= tar
 DIFF      ?= diff
+GIT       ?= git
 GREP      ?= grep
 FIND      ?= find
 SYMLINK   ?= ln -s
 LDCONFIG  ?= ldconfig
 
-PREFIX    ?= /usr/local
+# gnu coding standards
-BINDIR    ?= $(PREFIX)/bin
+prefix      ?= /usr/local
-LIBDIR    ?= $(PREFIX)/lib
+PREFIX      ?= $(prefix)
-SOLIBDIR  ?= $(PREFIX)/lib
+exec_prefix ?= $(PREFIX)
-INCDIR    ?= $(PREFIX)/include/chibi
+bindir      ?= $(exec_prefix)/bin
-MODDIR    ?= $(PREFIX)/share/chibi
+libdir      ?= $(exec_prefix)/lib
-BINMODDIR ?= $(PREFIX)/lib/chibi
+includedir  ?= $(PREFIX)/include
-PKGCONFDIR ?= $(SOLIBDIR)/pkgconfig
+datarootdir ?= $(PREFIX)/share
-MANDIR    ?= $(PREFIX)/share/man/man1
+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       ?=
 
 ########################################################################
@@ -46,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-win32.md

@@ -12,7 +12,7 @@ Supported Environments
 
 Chibi-scheme can be compiled with following platforms:
 
-* Microsoft Visual Studio 2017 (32bit only)
+* Microsoft Visual Studio 2017
 * MinGW32
 * MinGW64
 * MSYS
@@ -74,8 +74,8 @@ 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-Release" or "x86-Debug" configuration
+3. Choose "x86-" or "x64-" configuration
 4. "CMake" => "Build all"
-5. "CMake" => "Run Tests" => "chibi-scheme"
+5. "CMake" => "Tests" => "Run chibi-scheme Tests"
 
 

README.md

@@ -2,7 +2,7 @@
 
 **Minimal Scheme Implementation for use as an Extension Language**
 
-http://synthcode.com/wiki/chibi-scheme
+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
@@ -12,22 +12,32 @@ allowing multiple VMs to run simultaneously in different OS threads.
 There are no external dependencies so is relatively easy to drop into
 any project.
 
-The default repl language contains all bindings from
+Despite the small size, Chibi-Scheme attempts to do The Right Thing.
-[R7RS small](http://trac.sacrideo.us/wg/wiki/R7RSHomePage),
+The default settings include:
-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,
+* a full numeric tower, with rational and complex numbers
-FreeBSD and OS X, Plan 9, Windows (using Cygwin), iOS, Android,
+* full and seamless Unicode support
-ARM and [Emscripten](https://kripken.github.io/emscripten-site).
+* low-level and high-level hygienic macros
-Basic support for native Windows desktop also exists. See 
+* an extensible module system
-README-win32.md for details and build instructions.
 
-To build on most platforms just run `make && make test`.  This will
+Specifically, the default repl language contains all bindings from
-provide a shared library *libchibi-scheme*, as well as a sample
+[R7RS small](https://small.r7rs.org/), available explicitly as the
-*chibi-scheme* command-line repl.  You can then run
+`(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
 
@@ -40,7 +50,11 @@ to install the binaries and libraries.  You can optionally specify a
 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.
+`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*.
+*doc/chibi.html* or read the [manual](http://synthcode.com/scheme/chibi/)
+online.

RELEASE

@@ -1 +1 @@
-oxygen
+sodium

TODO

@@ -91,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

VERSION

@@ -1 +1 @@
-0.8.0
+0.11.0

appveyor.yml

@@ -20,11 +20,15 @@ environment:
         - 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%.==MSVC. call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build\vcvars32.bat"
+    - 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%

benchmarks/gabriel/chibi-prelude.scm

@@ -5,26 +5,42 @@
   (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)))
+             (end-rusage (get-resource-usage))
              (gc-end (gc-usecs))
              (gc-msecs (quotient (- gc-end gc-start) 1000))
-             (msecs (- (timeval->milliseconds end)
+             (real-msecs (timeval-diff start end))
-                       (timeval->milliseconds start))))
+             (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 user-msecs)
-        (display " system: 0")
+        (display " system: ")
+        (display system-msecs)
         (display " real: ")
-        (display msecs)
+        (display real-msecs)
         (display " gc: ")
         (display gc-msecs)
         (display " (")
-        (display (gc-count))
+        (display (- (gc-count) gc-start-count))
         (display " times)\n")
         (display "result: ")
         (write result)

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)
+# set -ex
-if [ "${BENCHDIR%%/*}" == "." ]; then
-    BENCHDIR=$(pwd)${BENCHDIR#.}
-fi
-CHIBIHOME=${BENCHDIR%%/benchmarks/gabriel}
-CHIBI="${CHIBI:-${CHIBIHOME}/chibi-scheme} -I$CHIBIHOME"
 
-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
+        $CHIBI -I"$CHIBIHOME/lib" -h"$HEAP" -q -lchibi-prelude.scm "$t"
-done
+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)) {
+  if (lsint_is_fixnum(x)) {
-    res = sexp_make_fixnum(x);
+    res = sexp_make_fixnum(lsint_to_sint(x));
-  } else {
+  } 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] = (sexp_uint_t)-x;
+      sexp_bignum_data(res)[0] = (sexp_uint_t)-lsint_to_sint(x);
     } else {
       sexp_bignum_sign(res) = 1;
-      sexp_bignum_data(res)[0] = (sexp_uint_t)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) {
+  if (luint_is_fixnum(x)) {
-    res = sexp_make_fixnum(x);
+    res = sexp_make_fixnum(luint_to_uint(x));
-  } else {
+  } else if (sexp_luint_fits_uint(x)) {
     res = sexp_make_bignum(ctx, 1);
     sexp_bignum_sign(res) = 1;
-    sexp_bignum_data(res)[0] = (sexp_uint_t)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)) {
+  for (f=fabs(f); f >= 1.0; f=trunc(f/16)) {
-    tmp = sexp_bignum_fxmul(ctx, NULL, scale, (sexp_uint_t)double_10s_digit(f), 0);
+    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;
+    n = luint_add(luint_mul_uint(luint_from_uint(adata[i]), b), luint_from_uint(carry));
-    data[i+offset] = (sexp_uint_t)n;
+    data[i+offset] = luint_to_uint(n);
-    carry = n >> (sizeof(sexp_uint_t)*8);
+    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];
+    n = luint_add(luint_shl(n,  sizeof(sexp_uint_t)*8), luint_from_uint(data[i]));
-    q = (sexp_uint_t)(n / b);
+    q = luint_to_uint(luint_div_uint(n, b));
-    r = (sexp_uint_t)(n - (sexp_luint_t)q * 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,7 +282,7 @@ 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)
@@ -239,18 +293,18 @@ sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) {
     return sexp_xtype_exception(ctx, NULL, "divide by zero", a);
   }
   for (i=len-1; i>=0; i--) {
-    n = (n << sizeof(sexp_uint_t)*8) + data[i];
+    n = luint_add(luint_shl(n, sizeof(sexp_uint_t)*8), luint_from_uint(data[i]));
-    q = (sexp_uint_t)(n / b0);
+    q = luint_to_uint(luint_div_uint(n, b0));
-    n -= (sexp_luint_t)q * b0;
+    n = luint_sub(n, luint_mul_uint(luint_from_uint(q), b0));
   }
-  return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)n);
+  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_var3(res, tmp, imag);
-  sexp_gc_preserve1(ctx, res);
+  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;
@@ -264,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 {
+    } else if (c=='.') {
-      if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */
       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=='/') {
@@ -287,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);
 }
 
@@ -524,38 +601,38 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
     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]
+    dn = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(a1)[alen-1])
-           << (sizeof(sexp_uint_t)*8))
+           , (sizeof(sexp_uint_t)*8))
-          + sexp_bignum_data(a1)[alen-2]);
+          , sexp_bignum_data(a1)[alen-2]);
-    dd = (((sexp_luint_t)sexp_bignum_data(b1)[blen-1]
+    dd = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(b1)[blen-1])
-           << (sizeof(sexp_uint_t)*8))
+           , (sizeof(sexp_uint_t)*8))
-          + sexp_bignum_data(b1)[blen-2]);
+          , sexp_bignum_data(b1)[blen-2]);
     if (alen > 2 && blen > 2 &&
-        sexp_bignum_data(a1)[alen-1] < ((sexp_luint_t)1<<(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))) &&
-        sexp_bignum_data(b1)[blen-1] < ((sexp_luint_t)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 = (dn << (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));
+        , (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4)));
-      dd = (dd << (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));
+        , (sexp_bignum_data(b1)[blen-3] >> (sizeof(sexp_uint_t)*4)));
     }
-    d = dn / dd;
+    d = luint_div(dn, dd);
-    if (d == 0) {
+    if (luint_eq(d, luint_from_uint(0))) {
-      dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
+      dn = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(a1)[alen-1])
-             << (sizeof(sexp_uint_t)*8))
+             , (sizeof(sexp_uint_t)*8))
-            + sexp_bignum_data(a1)[alen-2]);
+            , sexp_bignum_data(a1)[alen-2]);
-      dd = sexp_bignum_data(b1)[blen-1];
+      dd = luint_from_uint(sexp_bignum_data(b1)[blen-1]);
-      if (sexp_bignum_data(a1)[alen-1] < ((sexp_luint_t)1<<(sizeof(sexp_uint_t)*4)) &&
+      if (luint_lt(luint_from_uint(sexp_bignum_data(a1)[alen-1]), (luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4)))) &&
-          sexp_bignum_data(b1)[blen-1] < ((sexp_luint_t)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 = (dn << (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));
+          , (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4)));
-        dd = (dd << (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));
+          , (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);
+    dhi = luint_to_uint(luint_shr(d, (sizeof(sexp_uint_t)*8)));
-    dlo = d & (((sexp_luint_t)1<<(sizeof(sexp_uint_t)*8))-1);
+    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 */
@@ -608,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))
+  for (; abs_e; abs_e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
-    if (e & 1)
+    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);
 }
@@ -695,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) {
@@ -730,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);
@@ -786,7 +918,7 @@ sexp sexp_ratio_round (sexp ctx, sexp a) {
     r = sexp_mul(ctx, r, SEXP_TWO);
     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_exact_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;
@@ -818,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
@@ -852,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_maybe_ratio(sexp_complex_real(tmp));
-  sexp_negate(sexp_complex_imag(tmp));
+  sexp_negate_maybe_ratio(sexp_complex_imag(tmp));
   res = sexp_complex_add(ctx, a, tmp);
   sexp_gc_release2(ctx);
   return res;
@@ -899,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);
@@ -924,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
@@ -934,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))),
+  double e2x = exp(sexp_to_double(ctx, sexp_complex_real(z))),
-    y = sexp_to_double(sexp_complex_imag(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);
@@ -946,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)),
+  double x = sexp_to_double(ctx, sexp_complex_real(z)),
-    y = sexp_to_double(sexp_complex_imag(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);
@@ -971,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)),
+  double x = sexp_to_double(ctx, sexp_complex_real(z)),
-    y = sexp_to_double(sexp_complex_imag(z)), r;
+    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||(y==0&&1/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)),
+  double x = sexp_to_double(ctx, sexp_complex_real(z)),
-    y = sexp_to_double(sexp_complex_imag(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);
@@ -996,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)),
+  double x = sexp_to_double(ctx, sexp_complex_real(z)),
-    y = sexp_to_double(sexp_complex_imag(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);
@@ -1211,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:
@@ -1271,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);
@@ -1300,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:
@@ -1321,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_maybe_ratio(r);
-        sexp_negate_exact(sexp_ratio_numerator(r));
-      } else {
-        sexp_negate_exact(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:
@@ -1357,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_maybe_ratio(sexp_complex_real(r));
-        sexp_negate(sexp_complex_imag(r));
+        sexp_negate_maybe_ratio(sexp_complex_imag(r));
       } else {
-        sexp_negate(r);
+        sexp_negate_maybe_ratio(r);
       }
     }
     break;
@@ -1386,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);
+    prod = lsint_mul_sint(lsint_from_sint(sexp_unbox_fixnum(a)), sexp_unbox_fixnum(b));
-    if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM))
+    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)));
@@ -1411,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:
@@ -1518,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:
@@ -1539,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:
@@ -1550,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:
@@ -1634,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;
@@ -1667,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);
@@ -1691,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)));
@@ -1732,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_CPX: case SEXP_NUM_FIX_CPX:
-    case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG:
+    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);
@@ -1750,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);
+      if (isinf(sexp_flonum_value(b))) {
-      g = sexp_flonum_value(b);
+        r = sexp_flonum_value(b) > 0 ? SEXP_NEG_ONE : SEXP_ONE;
-      r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
+      } 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) ||
@@ -1764,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:
@@ -1789,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_compare(ctx, tmp=sexp_inexact_to_exact(ctx, NULL, 1, a), b);
-        r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
       }
       break;
     case SEXP_NUM_FIX_RAT:
@@ -1801,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-run

@@ -1 +0,0 @@
-LD_LIBRARY_PATH=.: DYLD_LIBRARY_PATH=.: CHIBI_MODULE_PATH=lib ./chibi-scheme "$@"

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-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}

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

@@ -139,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
@@ -225,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
@@ -242,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
+If CHIBI_MODULE_PATH is unset, the directories "./lib", and "." are
-search in order.
+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

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,
+Chibi is known to build and run on 32 and 64-bit Linux, OpenBSD, FreeBSD,
-DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
+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:
+R5RS.  You can specify the -f option on the command-line to enable
-fixnums, flonums, bignums, exact rationals and complex numbers, though
+case-folding.  The default configuration includes the full numeric
-this can be customized at compile time.
+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
+keywords.  To minimize conflicts Chibi offers a special module named
-effectively unbound when matching auxiliary keywords, so this case
+\scheme{(auto)} which can export any identifier requested with
-will "just work".  This decision was made because the chance of
+\scheme{only}, e.g. \scheme{(import (only (auto) foo))} will import
-different modules using the same keywords seems more likely than user
+an auxiliary syntax \scheme{foo} binding.  Separate modules can use
-code unintentionally matching a top-level keyword with a different
+this to get the same binding without needing to know about each other
-binding, however if you want to use R7RS semantics you can compile
+in advance.  This is a Chibi-specific extension so is non-portable, but
-with \ccode{SEXP_USE_STRICT_TOPLEVEL_BINDINGS=1}.
+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
+Chibi supports the R7RS module system natively, which is a simple
-module system in the style of the
+static module system.  The Chibi implementation is actually a
-\hyperlink["http://s48.org/"]{Scheme48} module system.  As with most
+hierarchy of languages in the style of the
-features this is optional, and can be ignored or completely disabled
+\hyperlink["http://s48.org/"]{Scheme48} module system, allowing easy
-at compile time.
+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>)}.
 
@@ -285,23 +310,31 @@ constructors:
 
 \subsection{Unicode}
 
-Chibi supports Unicode strings, encoding them as utf8.  This provides easy
+Chibi supports Unicode strings and I/O natively.  Case mappings and
-interoperability with many C libraries, but means that \scheme{string-ref} and
+comparisons, character properties, formatting and regular expressions
-\scheme{string-set!} are O(n), so they should be avoided in
+are all Unicode aware, supporting the latest version 13.0 of the
-performance-sensitive code.
+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
+and portable way to efficiently iterate and construct strings, by
-input string or accumulating characters in an output string.
+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
+writing your own iterator protocol, you should use string cursors.
-string cursor API instead of indexes.
+\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)}
@@ -337,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.
+All definitions begin with a "sexp_" prefix, or "SEXP_" for constants
-In addition to the prototypes and utility macros, this includes the
+(deliberately chosen not to conflict with other Scheme implementations
-following type definitions:
+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}
@@ -373,6 +407,7 @@ 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, 1);
@@ -400,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},
@@ -522,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
@@ -626,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
@@ -660,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}
@@ -721,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
@@ -739,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}
@@ -755,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}}
@@ -785,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}).}
@@ -810,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}
@@ -823,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}}
@@ -903,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
@@ -1177,7 +1260,7 @@ snow-fort):
 \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-11/srfi-14.html"]{(srfi 14) - character-set library}}
+\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}}
@@ -1191,6 +1274,7 @@ snow-fort):
 \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}}
@@ -1214,13 +1298,25 @@ snow-fort):
 \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-159/srfi-159.html"]{(srfi 159) - combinator formatting}}
+\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}}
 
 ]
 
@@ -1233,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}}
@@ -1247,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}}
@@ -1265,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/string.html"]{(chibi string) - Cursor-based string library (predecessor to SRFI 130)}}
-
-\item{\hyperlink["lib/chibi/show/base.scm"]{(chibi show base) - Base combinator formatting}}
 
 \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}}
@@ -1292,7 +1434,7 @@ 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}.  The
@@ -1306,7 +1448,9 @@ with image files on your platform you can run
 
 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.
 
@@ -1338,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
@@ -1346,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.
@@ -1369,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
@@ -1466,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}
 ]

eval.c

@@ -45,7 +45,9 @@ void sexp_warn (sexp ctx, const char *msg, sexp x) {
   if (sexp_oportp(out)) {
     sexp_write_string(ctx, strictp ? "ERROR: " : "WARNING: ", out);
     sexp_write_string(ctx, msg, out);
+    if (x != SEXP_UNDEF) {
       sexp_write(ctx, x, out);
+    }
     sexp_write_char(ctx, '\n', out);
     if (strictp) sexp_stack_trace(ctx, out);
   }
@@ -206,7 +208,7 @@ sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
   res = SEXP_NULL;
 #if SEXP_USE_RENAME_BINDINGS
   for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
-    sexp_push(ctx, res, sexp_cadr(ls));
+    sexp_push(ctx, res, sexp_car(ls));
 #endif
   for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
     if (sexp_env_value(ls) != SEXP_UNDEF)
@@ -221,7 +223,7 @@ sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
   e = sexp_alloc_type(ctx, env, SEXP_ENV);
   sexp_env_parent(e) = env;
   sexp_env_bindings(e) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
   sexp_env_renames(e) = SEXP_NULL;
 #endif
   for ( ; sexp_pairp(vars); vars = sexp_cdr(vars))
@@ -241,7 +243,7 @@ sexp sexp_extend_synclo_env (sexp ctx, sexp env) {
       e2 = e2 ? (sexp_env_parent(e2) = sexp_alloc_type(ctx, env, SEXP_ENV)) : e;
       sexp_env_bindings(e2) = sexp_env_bindings(e1);
       sexp_env_syntactic_p(e2) = 1;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
       sexp_env_renames(e2) = sexp_env_renames(e1);
 #endif
     }
@@ -361,6 +363,17 @@ sexp sexp_complete_bytecode (sexp ctx) {
 #if SEXP_USE_FULL_SOURCE_INFO
   if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) {
     sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc));
+    /* omit the leading -1 source marker for the bytecode if the next */
+    /* entry is in the same file */
+    if (sexp_pairp(sexp_cdr(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_car(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cdar(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cadr(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cdr(sexp_cadr(sexp_bytecode_source(bc)))) &&
+        sexp_cadr(sexp_car(sexp_bytecode_source(bc)))
+        == sexp_cadr(sexp_cadr(sexp_bytecode_source(bc)))) {
+      sexp_bytecode_source(bc) = sexp_cdr(sexp_bytecode_source(bc));
+    }
     sexp_bytecode_source(bc) = sexp_list_to_vector(ctx, sexp_bytecode_source(bc));
   }
 #endif
@@ -384,6 +397,7 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) {
   sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO);
   sexp_macro_env(mac) = e;
   sexp_macro_proc(mac) = p;
+  sexp_macro_aux(mac) = SEXP_FALSE;
   return mac;
 }
 
@@ -397,10 +411,12 @@ sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv,
     sexp_synclo_env(res) = sexp_synclo_env(expr);
     sexp_synclo_free_vars(res) = sexp_synclo_free_vars(expr);
     sexp_synclo_expr(res) = sexp_synclo_expr(expr);
+    sexp_synclo_rename(res) = sexp_synclo_rename(expr);
   } else {
     sexp_synclo_env(res) = env;
     sexp_synclo_free_vars(res) = fv;
     sexp_synclo_expr(res) = expr;
+    sexp_synclo_rename(res) = SEXP_FALSE;
   }
   return res;
 }
@@ -486,16 +502,19 @@ static void sexp_init_eval_context_bytecodes (sexp ctx) {
 #endif
 
 void sexp_init_eval_context_globals (sexp ctx) {
+  const char* no_sys_path;
   const char* user_path;
   ctx = sexp_make_child_context(ctx, NULL);
 #if ! SEXP_USE_NATIVE_X86
   sexp_init_eval_context_bytecodes(ctx);
 #endif
   sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL;
-  sexp_add_path(ctx, sexp_default_module_path);
   user_path = getenv(SEXP_MODULE_PATH_VAR);
   if (!user_path) user_path = sexp_default_user_module_path;
   sexp_add_path(ctx, user_path);
+  no_sys_path = getenv(SEXP_NO_SYSTEM_PATH_VAR);
+  if (!no_sys_path || strcmp(no_sys_path, "0")==0)
+    sexp_add_path(ctx, sexp_default_module_path);
 #if SEXP_USE_GREEN_THREADS
   sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)
     = sexp_user_exception(ctx, SEXP_FALSE, "I/O would block", SEXP_NULL);
@@ -593,30 +612,28 @@ sexp sexp_syntactic_closure_expr_op (sexp ctx, sexp self, sexp_sint_t n, sexp x)
   return (sexp_synclop(x) ? sexp_synclo_expr(x) : x);
 }
 
-#if SEXP_USE_READER_LABELS
+static int sexp_contains_syntax_p_bound(sexp x, int depth) {
-static int sexp_cyclic_synclop(sexp x) {
+  int i;
   sexp ls1, ls2;
-  if (!sexp_pairp(x))
+  if (sexp_synclop(x))
-    return 0;
-  for (ls1=x, ls2=sexp_id_name(sexp_cdr(ls1));
-       sexp_pairp(ls2) && sexp_pairp(sexp_id_name(sexp_cdr(ls2)));
-       ls1=sexp_id_name(sexp_cdr(ls1)),
-         ls2=sexp_id_name(sexp_cdr(sexp_id_name(sexp_cdr(ls2))))) {
-    if (ls1 == ls2 || ls1 == sexp_id_name(sexp_car(ls2)))
     return 1;
+  if (depth <= 0)
+    return 0;
+  if (sexp_pairp(x)) {
+    for (i=0, ls1=x, ls2=x; sexp_pairp(ls1); ls1=sexp_cdr(ls1), ls2=(i++ & 1 ? sexp_cdr(ls2) : ls2)) {
+      if (sexp_contains_syntax_p_bound(sexp_car(ls1), depth-1))
+        return 1;
+      if (i > 0 && (ls1 == ls2 || ls1 == sexp_car(ls2)))
+        return 0; /* cycle, no synclo found, assume none */
     }
-  for (ls1=x, ls2=sexp_id_name(sexp_car(ls1));
+    return sexp_contains_syntax_p_bound(ls1, depth-1);
-       sexp_pairp(ls2) && sexp_pairp(sexp_id_name(sexp_car(ls2)));
+  } else if (sexp_vectorp(x)) {
-       ls1=sexp_id_name(sexp_car(ls1)),
+    for (i = 0; i < sexp_vector_length(x); ++i)
-         ls2=sexp_id_name(sexp_car(sexp_id_name(sexp_car(ls2))))) {
+      if (sexp_contains_syntax_p_bound(sexp_vector_ref(x, sexp_make_fixnum(i)), depth-1))
-    if (ls1 == ls2 || ls1 == sexp_id_name(sexp_cdr(ls2)))
         return 1;
   }
   return 0;
 }
-#else
-#define sexp_cyclic_synclop(x) 0
-#endif
 
 sexp sexp_strip_synclos_bound (sexp ctx, sexp x, int depth) {
   int i;
@@ -624,7 +641,7 @@ sexp sexp_strip_synclos_bound (sexp ctx, sexp x, int depth) {
   if (depth <= 0) return x;
   sexp_gc_preserve3(ctx, res, kar, kdr);
   x = sexp_id_name(x);
-  if (sexp_pairp(x) && !sexp_cyclic_synclop(x)) {
+  if (sexp_pairp(x)) {
     kar = sexp_strip_synclos_bound(ctx, sexp_car(x), depth-1);
     kdr = sexp_strip_synclos_bound(ctx, sexp_cdr(x), depth-1);
     res = sexp_cons(ctx, kar, kdr);
@@ -641,11 +658,15 @@ sexp sexp_strip_synclos_bound (sexp ctx, sexp x, int depth) {
 }
 
 sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  if (!sexp_contains_syntax_p_bound(x, SEXP_STRIP_SYNCLOS_BOUND))
+    return x;
   return sexp_strip_synclos_bound(ctx, x, SEXP_STRIP_SYNCLOS_BOUND);
 }
 
 sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) {
   sexp cell1, cell2;
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2);
   cell1 = sexp_env_cell(ctx, e1, id1, 0);
   cell2 = sexp_env_cell(ctx, e2, id2, 0);
   if (cell1 && (cell1 == cell2))
@@ -746,6 +767,26 @@ static sexp analyze_seq (sexp ctx, sexp ls, int depth, int defok) {
   return res;
 }
 
+static sexp analyze_macro_once (sexp ctx, sexp x, sexp op, int depth) {
+  sexp res;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
+  tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
+  tmp = sexp_cons(ctx, x, tmp);
+  res = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+  if (!sexp_exceptionp(res) && !sexp_exceptionp(sexp_context_exception(ctx)))
+    res = sexp_apply(res, sexp_macro_proc(op), tmp);
+  if (sexp_pairp(sexp_car(tmp)) && sexp_pair_source(sexp_car(tmp))) {
+    if (sexp_pairp(res))
+      sexp_pair_source(res) = sexp_pair_source(sexp_car(tmp));
+    else if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(x)))
+      sexp_exception_source(res) = sexp_pair_source(sexp_car(tmp));
+  }
+  sexp_gc_release1(ctx);
+  return res;
+}
+
 static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
   sexp env = sexp_context_env(ctx), res;
   sexp_gc_var1(cell);
@@ -765,14 +806,23 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
 
 static sexp analyze_set (sexp ctx, sexp x, int depth) {
   sexp res, varenv;
-  sexp_gc_var2(ref, value);
+  sexp_gc_var4(ref, value, cell, op);
-  sexp_gc_preserve2(ctx, ref, value);
+  sexp_gc_preserve4(ctx, ref, value, cell, op);
   if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
          && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
     res = sexp_compile_error(ctx, "bad set! syntax", x);
+  } else {
+    cell = sexp_env_cell(ctx, sexp_context_env(ctx), sexp_cadr(x), 0);
+    op = cell ? sexp_cdr(cell) : NULL;
+    if (op && sexp_macrop(op)) {
+      if (!sexp_procedure_variable_transformer_p(sexp_macro_proc(op))) {
+        res = sexp_compile_error(ctx, "can't mutate a syntax keyword", sexp_cadr(x));
+      } else {
+        res = analyze_macro_once(ctx, x, op, depth);
+      }
     } else {
       ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv);
-    if (sexp_lambdap(sexp_ref_loc(ref)))
+      if (sexp_refp(ref) && sexp_lambdap(sexp_ref_loc(ref)))
         sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
       value = analyze(ctx, sexp_caddr(x), depth, 0);
       if (sexp_exceptionp(ref)) {
@@ -787,25 +837,33 @@ static sexp analyze_set (sexp ctx, sexp x, int depth) {
         sexp_set_source(res) = sexp_pair_source(x);
       }
     }
-  sexp_gc_release2(ctx);
+  }
+  sexp_gc_release4(ctx);
   return res;
 }
 
 #define sexp_return(res, val) do {res=val; goto cleanup;} while (0)
 
 static sexp analyze_lambda (sexp ctx, sexp x, int depth) {
-  int trailing_non_procs;
+  int trailing_non_procs, verify_duplicates_p;
   sexp name, ls, ctx3;
   sexp_gc_var6(res, body, tmp, value, defs, ctx2);
   sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2);
   /* verify syntax */
   if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
     sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x));
+  verify_duplicates_p = sexp_length_unboxed(sexp_cadr(x)) < 100;
   for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
     if (! sexp_idp(sexp_car(ls)))
       sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
-    else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls))))
+    else if (verify_duplicates_p && sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls))))
       sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
+  if (! sexp_nullp(ls)) { /* verify rest param */
+    if (! sexp_idp(ls))
+      sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
+    else if (sexp_truep(sexp_memq(ctx, ls, sexp_cadr(x))))
+      sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
+  }
   /* build lambda and analyze body */
   res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x)));
   if (sexp_exceptionp(res)) sexp_return(res, res);
@@ -870,14 +928,23 @@ static sexp analyze_if (sexp ctx, sexp x, int depth) {
   sexp_gc_var3(test, pass, fail);
   sexp_gc_preserve3(ctx, test, pass, fail);
   if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
-    res = sexp_compile_error(ctx, "bad if syntax", x);
+    res = sexp_compile_error(ctx, "not enough args to if", x);
+  } else if (sexp_pairp(sexp_cdddr(x)) && sexp_cdr(sexp_cdddr(x)) != SEXP_NULL) {
+    res = sexp_compile_error(ctx, "too many args to if", x);
   } else {
     test = analyze(ctx, sexp_cadr(x), depth, 0);
+    if (sexp_exceptionp(test)) {
+      res = test;
+    } else {
       pass = analyze(ctx, sexp_caddr(x), depth, 0);
+      if (sexp_exceptionp(pass)) {
+        res = pass;
+      } else {
         fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
         fail = analyze(ctx, fail_expr, depth, 0);
-    res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
+        res = sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail);
-           sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
+      }
+    }
     if (sexp_cndp(res)) sexp_cnd_source(res) = sexp_pair_source(x);
   }
   sexp_gc_release3(ctx);
@@ -995,7 +1062,7 @@ static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp, int depth) {
     sexp_env_syntactic_p(env) = 1;
     sexp_env_parent(env) = sexp_context_env(ctx);
     sexp_env_bindings(env) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
     sexp_env_renames(env) = SEXP_NULL;
 #endif
     ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
@@ -1035,8 +1102,13 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
     } else if (sexp_idp(sexp_car(x))) {
       if (! cell) {
         res = analyze_app(ctx, x, depth);
-        if (sexp_exceptionp(res))
+        if (sexp_exceptionp(res)) {
           sexp_warn(ctx, "exception inside undefined operator: ", sexp_car(x));
+          /* the common case of no imports */
+          if (!sexp_env_parent(sexp_context_env(ctx))) {
+            sexp_warn(ctx, "did you forget to import a language? e.g. (import (scheme base))", SEXP_UNDEF);
+          }
+        }
       } else {
         op = sexp_cdr(cell);
         if (sexp_corep(op)) {
@@ -1048,7 +1120,12 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
               : sexp_compile_error(ctx, "unexpected define", x);
             break;
           case SEXP_CORE_SET:
-            res = analyze_set(ctx, x, depth); break;
+            x = analyze_set(ctx, x, depth);
+            if (!sexp_exceptionp(x) && !sexp_setp(x))
+              goto loop;
+            else
+              res = x;
+            break;
           case SEXP_CORE_LAMBDA:
             res = analyze_lambda(ctx, x, depth); break;
           case SEXP_CORE_IF:
@@ -1079,14 +1156,7 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
             res = sexp_compile_error(ctx, "unknown core form", op); break;
           }
         } else if (sexp_macrop(op)) {
-          tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
+          x = analyze_macro_once(ctx, x, op, depth);
-          tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
-          tmp = sexp_cons(ctx, x, tmp);
-          x = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
-          if (!sexp_exceptionp(x) && !sexp_exceptionp(sexp_context_exception(ctx)))
-            x = sexp_apply(x, sexp_macro_proc(op), tmp);
-          if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x)))
-            sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp));
           goto loop;
         } else if (sexp_opcodep(op)) {
           res = sexp_length(ctx, sexp_cdr(x));
@@ -1118,7 +1188,14 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
         sexp_warn(ctx, "invalid operator in application: ", x);
     }
   } else if (sexp_idp(x)) {
+    cell = sexp_env_cell(ctx, sexp_context_env(ctx), x, 0);
+    op = cell ? sexp_cdr(cell) : NULL;
+    if (op && sexp_macrop(op)) {
+      x = analyze_macro_once(ctx, x, op, depth);
+      goto loop;
+    } else {
       res = analyze_var_ref(ctx, x, NULL);
+    }
   } else if (sexp_synclop(x)) {
     tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
     if (sexp_pairp(sexp_synclo_free_vars(x))) {
@@ -1296,27 +1373,60 @@ sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
     return sexp_make_fixnum(fd);
   return SEXP_FALSE;
 }
+sexp sexp_stream_portp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
+  return sexp_make_boolean(sexp_stream_portp(port));
+}
 #endif
 
 #if SEXP_USE_STATIC_LIBS
-#if SEXP_USE_STATIC_LIBS_NO_INCLUDE
+#if SEXP_USE_STATIC_LIBS_EMPTY
+struct sexp_library_entry_t* sexp_static_libraries = NULL;
+#elif SEXP_USE_STATIC_LIBS_NO_INCLUDE
 extern struct sexp_library_entry_t* sexp_static_libraries;
 #else
 #include "clibs.c"
 #endif
+
+void sexp_add_static_libraries(struct sexp_library_entry_t* libraries)
+{
+  struct sexp_library_entry_t *entry, *table;
+
+  if (!sexp_static_libraries) {
+    sexp_static_libraries = libraries;
+    return;
+  }
+
+  for (table = sexp_static_libraries; ;
+       table = (struct sexp_library_entry_t*)entry->init) {
+    for (entry = &table[0]; entry->name; entry++)
+       ;
+    if (!entry->init) {
+      entry->init = (sexp_init_proc)libraries;
+      return;
+    }
+  }
+}
+
 static struct sexp_library_entry_t *sexp_find_static_library(const char *file)
 {
   size_t base_len;
-  struct sexp_library_entry_t *entry;
+  struct sexp_library_entry_t *entry, *table;
 
+  if(!sexp_static_libraries)
+    return NULL;
   if (file[0] == '.' && file[1] == '/')
     file += 2;
   base_len = strlen(file) - strlen(sexp_so_extension);
   if (strcmp(file + base_len, sexp_so_extension))
     return NULL;
-  for (entry = &sexp_static_libraries[0]; entry->name; entry++)
+  for (table = sexp_static_libraries;
+       table;
+       table = (struct sexp_library_entry_t*)entry->init) {
+    for (entry = &table[0]; entry->name; entry++)
       if (! strncmp(file, entry->name, base_len))
         return entry;
+  }
   return NULL;
 }
 #else
@@ -1466,10 +1576,10 @@ sexp sexp_register_optimization (sexp ctx, sexp self, sexp_sint_t n, sexp f, sex
 #endif
 
 #if SEXP_USE_RATIOS
-#define maybe_convert_ratio(z)                          \
+#define maybe_convert_ratio(ctx, z)                             \
-  else if (sexp_ratiop(z)) d = sexp_ratio_to_double(z);
+  else if (sexp_ratiop(z)) d = sexp_ratio_to_double(ctx, z);
 #else
-#define maybe_convert_ratio(z)
+#define maybe_convert_ratio(ctx, z)
 #endif
 
 #if SEXP_USE_COMPLEX
@@ -1487,7 +1597,7 @@ sexp sexp_register_optimization (sexp ctx, sexp self, sexp_sint_t n, sexp f, sex
       d = sexp_flonum_value(z);                                         \
     else if (sexp_fixnump(z))                                           \
       d = (double)sexp_unbox_fixnum(z);                                 \
-    maybe_convert_ratio(z)                                              \
+    maybe_convert_ratio(ctx, z)                                         \
     maybe_convert_bignum(z)                                             \
     maybe_convert_complex(z, f)                                         \
     else                                                                \
@@ -1503,7 +1613,7 @@ sexp sexp_register_optimization (sexp ctx, sexp self, sexp_sint_t n, sexp f, sex
       d = sexp_flonum_value(z);                                         \
     else if (sexp_fixnump(z))                                           \
       d = (double)sexp_unbox_fixnum(z);                                 \
-    maybe_convert_ratio(z)                                              \
+    maybe_convert_ratio(ctx, z)                                         \
     maybe_convert_bignum(z)                                             \
     maybe_convert_complex(z, f)                                         \
     else                                                                \
@@ -1566,7 +1676,7 @@ sexp sexp_log (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
     d = sexp_flonum_value(z);
   else if (sexp_fixnump(z))
     d = (double)sexp_unbox_fixnum(z);
-  maybe_convert_ratio(z)
+  maybe_convert_ratio(ctx, z)
   maybe_convert_bignum(z)
   else
     return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
@@ -1592,8 +1702,8 @@ sexp sexp_inexact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
   if (sexp_flonump(z))
     d = sexp_flonum_value(z);
   else if (sexp_fixnump(z))
-    d = (double)sexp_unbox_fixnum(z);
+    d = (double)sexp_unbox_fixnum(z); /* may be larger or smaller than z */
-  maybe_convert_ratio(z)        /* XXXX add ratio sqrt */
+  maybe_convert_ratio(ctx, z)         /* TODO: add ratio sqrt */
   maybe_convert_complex(z, sexp_complex_sqrt)
   else
     return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
@@ -1633,6 +1743,11 @@ sexp sexp_exact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
     if (!sexp_exceptionp(res)) {
       rem = sexp_mul(ctx, res, res);
       rem = sexp_sub(ctx, z, rem);
+      if (sexp_negativep(rem)) {
+        res = sexp_sub(ctx, res, SEXP_ONE);
+        rem = sexp_mul(ctx, res, res);
+        rem = sexp_sub(ctx, z, rem);
+      }
       res = sexp_cons(ctx, res, rem);
     }
   }
@@ -1642,8 +1757,10 @@ sexp sexp_exact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
 #endif
 
 sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
-#if SEXP_USE_BIGNUMS
+#if SEXP_USE_BIGNUMS || SEXP_USE_RATIOS
   sexp_gc_var2(res, rem);
+#endif
+#if SEXP_USE_BIGNUMS
   if (sexp_bignump(z)) {
     sexp_gc_preserve2(ctx, res, rem);
     res = sexp_bignum_sqrt(ctx, z, &rem);
@@ -1653,6 +1770,20 @@ sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
     sexp_gc_release2(ctx);
     return res;
   }
+#endif
+#if SEXP_USE_RATIOS
+  if (sexp_ratiop(z)) {
+    sexp_gc_preserve2(ctx, res, rem);
+    res = sexp_sqrt(ctx, self, n, sexp_ratio_numerator(z));
+    rem = sexp_sqrt(ctx, self, n, sexp_ratio_denominator(z));
+    if (sexp_exactp(res) && sexp_exactp(rem)) {
+      res = sexp_make_ratio(ctx, res, rem);
+    } else {
+      res = sexp_inexact_sqrt(ctx, self, n, z);
+    }
+    sexp_gc_release2(ctx);
+    return res;
+  }
 #endif
   return sexp_inexact_sqrt(ctx, self, n, z);
 }
@@ -1710,7 +1841,7 @@ sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
     if (sexp_fixnump(e)) {
       return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
     } else {
-      x1 = sexp_ratio_to_double(x);
+      x1 = sexp_ratio_to_double(ctx, x);
     }
   }
 #endif
@@ -1722,7 +1853,7 @@ sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
     e1 = sexp_flonum_value(e);
 #if SEXP_USE_RATIOS
   else if (sexp_ratiop(e))
-    e1 = sexp_ratio_to_double(e);
+    e1 = sexp_ratio_to_double(ctx, e);
 #endif
   else
     return sexp_type_exception(ctx, self, SEXP_FIXNUM, e);
@@ -1730,7 +1861,7 @@ sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
   if ((f*1000.0 > SEXP_MAX_FIXNUM) || (f*1000.0 < SEXP_MIN_FIXNUM)
       || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) || (e1 < 0.0)) {
 #if SEXP_USE_BIGNUMS
-    if (sexp_fixnump(x) && sexp_fixnump(e) && (e1 >= 0.0)) {
+    if (sexp_fixnump(x) && sexp_fixnump(e)) {
       sexp_gc_preserve1(ctx, tmp);
       tmp = sexp_fixnum_to_bignum(ctx, x);
       res = sexp_bignum_expt(ctx, tmp, e);
@@ -1784,7 +1915,7 @@ sexp sexp_exact_to_inexact (sexp ctx, sexp self, sexp_sint_t n, sexp i) {
 #endif
 #if SEXP_USE_RATIOS
   else if (sexp_ratiop(i))
-    res = sexp_make_flonum(ctx, sexp_ratio_to_double(i));
+    res = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, i));
 #endif
 #if SEXP_USE_COMPLEX
   else if (sexp_complexp(i)) {
@@ -1811,13 +1942,13 @@ sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
       res = sexp_xtype_exception(ctx, self, "exact: not a finite number", z);
     } else if (sexp_flonum_value(z) != trunc(sexp_flonum_value(z))) {
 #if SEXP_USE_RATIOS
-      res = sexp_double_to_ratio(ctx, sexp_flonum_value(z));
+      res = sexp_double_to_ratio_2(ctx, sexp_flonum_value(z));
 #else
       res = sexp_xtype_exception(ctx, self, "exact: not an integer", z);
 #endif
 #if SEXP_USE_BIGNUMS
-    } else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM)
+    } else if ((sexp_flonum_value(z) > (double)SEXP_MAX_FIXNUM)
-               || sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
+               || sexp_flonum_value(z) < (double)SEXP_MIN_FIXNUM) {
       res = sexp_double_to_bignum(ctx, sexp_flonum_value(z));
 #endif
     } else {
@@ -1916,7 +2047,7 @@ void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) {
   p = (unsigned char*)sexp_string_data(str) + i;
   old_len = sexp_utf8_initial_byte_count(*p);
   new_len = sexp_utf8_char_byte_count(c);
-  if (old_len != new_len) { /* resize bytes if needed */
+  if (sexp_copy_on_writep(str) || old_len != new_len) { /* resize bytes if needed */
     len = sexp_string_size(str)+(new_len-old_len);
     b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID);
     if (! sexp_exceptionp(b)) {
@@ -1927,8 +2058,17 @@ void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) {
       p = q + i;
     }
     sexp_string_size(str) += new_len - old_len;
+    sexp_copy_on_writep(str) = 0;
   }
   sexp_utf8_encode_char(p, new_len, c);
+  if (old_len != new_len) {
+#if SEXP_USE_STRING_INDEX_TABLE
+    sexp_update_string_index_lookup(ctx, str);
+#elif SEXP_USE_STRING_REF_CACHE
+  sexp_cached_char_idx(str) = 0;
+  sexp_cached_cursor(str) = sexp_make_string_cursor(0);
+#endif
+  }
 }
 
 sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch) {
@@ -1936,6 +2076,8 @@ sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, s
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
   sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
+  if (sexp_immutablep(str))
+    return sexp_xtype_exception(ctx, self, "string-set!: immutable string", str);
   off = sexp_string_index_to_cursor(ctx, self, n, str, i);
   if (sexp_exceptionp(off)) return off;
   if (sexp_unbox_string_cursor(off) >= (sexp_sint_t)sexp_string_size(str))
@@ -2160,7 +2302,7 @@ sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
   sexp_env_lambda(e) = NULL;
   sexp_env_parent(e) = NULL;
   sexp_env_bindings(e) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
   sexp_env_renames(e) = SEXP_NULL;
 #endif
   return e;
@@ -2180,6 +2322,8 @@ sexp sexp_make_null_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
   return e;
 }
 
+extern struct sexp_opcode_struct* sexp_primitive_opcodes;  /* from opcodes.c */
+
 sexp sexp_make_primitive_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
   int i;
   sexp_gc_var4(e, op, sym, name);
@@ -2263,6 +2407,10 @@ sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) {
   return res;
 }
 
+sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_context_env(ctx);
+}
+
 #if SEXP_USE_MODULES
 sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   if (sexp_pairp(x) && sexp_stringp(sexp_car(x))) {
@@ -2280,9 +2428,6 @@ sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, se
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   return sexp_load_module_file(ctx, sexp_string_data(file), env);
 }
-sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n) {
-  return sexp_context_env(ctx);
-}
 sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
   sexp oldenv;
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
@@ -2400,9 +2545,9 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
     = sexp_env_ref(ctx, e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE);
   /* load init-7.scm */
   len = strlen(sexp_init_file);
-  strncpy(init_file, sexp_init_file, len);
+  strncpy(init_file, sexp_init_file, len+1);
   init_file[len] = (char)sexp_unbox_fixnum(version) + '0';
-  strncpy(init_file + len + 1, sexp_init_file_suffix, strlen(sexp_init_file_suffix));
+  strncpy(init_file + len + 1, sexp_init_file_suffix, strlen(sexp_init_file_suffix)+1);
   init_file[len + 1 + strlen(sexp_init_file_suffix)] = 0;
   tmp = sexp_load_module_file(ctx, init_file, e);
   sexp_set_parameter(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e);
@@ -2440,10 +2585,19 @@ sexp sexp_make_standard_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version
   sexp_gc_preserve1(ctx, env);
   env = sexp_make_primitive_env(ctx, version);
   if (! sexp_exceptionp(env)) env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
+  if (sexp_envp(env)) sexp_immutablep(env) = 1;
   sexp_gc_release1(ctx);
   return env;
 }
 
+sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  if (sexp_pointerp(x)) {
+    sexp_immutablep(x) = 1;
+    return SEXP_TRUE;
+  }
+  return SEXP_FALSE;
+}
+
 sexp sexp_env_parent_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;

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

@@ -37,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));
@@ -99,7 +137,7 @@ SEXP_API 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
@@ -187,7 +225,35 @@ int sexp_valid_object_p (sexp ctx, sexp x) {
 #define sexp_gc_pass_ctx(x)
 #endif
 
-void sexp_mark_one (sexp_gc_pass_ctx(sexp ctx) sexp* types, 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;
@@ -197,26 +263,42 @@ void sexp_mark_one (sexp_gc_pass_ctx(sexp ctx) sexp* types, 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_one(sexp_gc_pass_ctx(ctx) types, *(saves->var));
+      if (saves->var) sexp_mark_one(ctx, types, *(saves->var));
   }
   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)
+    if (p < q) {
-      sexp_mark_one(sexp_gc_pass_ctx(ctx) types, *p++);
+      sexp_mark_stack_push(ctx, p, q);
-    x = *p;
+    }
+    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(sexp_gc_pass_ctx(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)), x);
+  sexp_mark_one_start(ctx, sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)), x);
 }
 
 #if SEXP_USE_CONSERVATIVE_GC
@@ -483,11 +565,11 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) {
   sexp_reset_weak_references(ctx);
   finalized = sexp_finalize(ctx);
   res = sexp_sweep(ctx, sum_freed);
+  ++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_count(ctx);
   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),
@@ -500,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,
+  h =  mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE,
-            MAP_ANON|MAP_PRIVATE, 0, 0);
+            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;
@@ -534,26 +617,38 @@ int sexp_grow_heap (sexp ctx, size_t size, size_t chunk_size) {
 #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);
+  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) {
@@ -580,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)))
@@ -600,8 +733,16 @@ 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;
 }
+#endif
 
 
 void sexp_gc_init (void) {
@@ -617,4 +758,4 @@ void sexp_gc_init (void) {
 #endif
 }
 
-#endif
+#endif  /* ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC */

gc_heap.c

@@ -7,7 +7,7 @@
 #if SEXP_USE_IMAGE_LOADING
 
 #define ERR_STR_SIZE 256
-char gc_heap_err_str[ERR_STR_SIZE];
+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) {
@@ -55,7 +55,7 @@ sexp sexp_gc_heap_walk(sexp ctx,
           return res; }
         size = sexp_gc_allocated_bytes(ctx, t, t_cnt, p);
         if (size == 0) {
-          strcpy(gc_heap_err_str, "Heap element with a zero size detected");
+          snprintf(gc_heap_err_str, ERR_STR_SIZE, "Heap element with a zero size detected");
           goto done;
         }
       }
@@ -68,7 +68,7 @@ sexp sexp_gc_heap_walk(sexp ctx,
   }
   res = SEXP_TRUE;
 done:
-  if (res != SEXP_TRUE) res = sexp_user_exception(ctx, NULL, gc_heap_err_str, NULL);
+  if (res != SEXP_TRUE) res = sexp_user_exception(ctx, NULL, gc_heap_err_str, SEXP_NULL);
   return res;
 }
 
@@ -145,7 +145,7 @@ static sexp sexp_gc_heap_pack_src_to_dst(void* adata, sexp srcp) {
       imax = imid - 1;
     }
   }
-  strcpy(gc_heap_err_str, "Source SEXP not found in src->dst mapping");
+  snprintf(gc_heap_err_str, ERR_STR_SIZE, "Source SEXP not found in src->dst mapping");
   return SEXP_FALSE;
 }
 
@@ -233,7 +233,7 @@ done:
 }
 
 static sexp sexp_gc_heap_pack_adjust(sexp dstp, sexp* types, struct sexp_remap_state* state) {
-  sexp res = NULL;
+  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) {
@@ -260,7 +260,7 @@ static sexp_heap sexp_gc_packed_heap_make(size_t packed_size, size_t 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) {
-    strcpy(gc_heap_err_str, "Could not allocate memory for heap");
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "Could not allocate memory for heap");
     return NULL;
   }
   sexp base = sexp_heap_first_block(heap);
@@ -418,7 +418,7 @@ sexp sexp_save_image (sexp ctx_in, const char* filename) {
 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, NULL);
+  if (res != SEXP_TRUE) res = sexp_user_exception(ctx_in, NULL, gc_heap_err_str, SEXP_NULL);
   return res;
 }
 
@@ -573,11 +573,11 @@ static sexp load_image_callback_p2 (sexp ctx, sexp dstp, void *user) {
 }
 
 
-int load_image_header(FILE *fp, struct sexp_image_header_t* header) {
+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) {
-    strcpy(gc_heap_err_str, "couldn't read image header");
+    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) {
@@ -609,7 +609,7 @@ sexp sexp_load_image (const char* filename, off_t offset, sexp_uint_t heap_free_
   const char *mod_path, *colon, *end;
   char path[512];
   FILE *fp;
-  int i;
+  int i, len;
   sexp res = NULL, ctx = NULL, base, *ctx_globals, *ctx_types;
 
   gc_heap_err_str[0] = 0;
@@ -623,9 +623,10 @@ sexp sexp_load_image (const char* filename, off_t offset, sexp_uint_t heap_free_
     for (mod_path=all_paths[i]; *mod_path; mod_path=colon+1) {
       colon = strchr(mod_path, ':');
       end = colon ? colon : mod_path + strlen(mod_path);
-      strncpy(path, mod_path, end-mod_path);
+      snprintf(path, sizeof(path), "%s", mod_path);
       if (end[-1] != '/') path[end-mod_path] = '/';
-      strcpy(path + (end-mod_path) + (end[-1] == '/' ? 0 : 1), filename);
+      len = (end-mod_path) + (end[-1] == '/' ? 0 : 1);
+      snprintf(path + len, sizeof(path) - len, "%s", filename);
       fp = fopen(path, "rb");
       if (fp || !colon) break;
     }
@@ -635,7 +636,7 @@ sexp sexp_load_image (const char* filename, off_t offset, sexp_uint_t heap_free_
     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 -> "PRIoff": %s\n", filename, offset, strerror(errno));
+    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;
   }
 
@@ -707,6 +708,9 @@ sexp sexp_load_image (const char* filename, sexp_uint_t heap_free_size, sexp_uin
 
 /****************** 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 {
@@ -780,5 +784,6 @@ void sexp_gc_heap_stats_print(sexp ctx)
   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,6 +400,7 @@ 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);
@@ -44,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
@@ -131,6 +129,7 @@ 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, 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);
@@ -196,6 +195,8 @@ SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name
 #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)
@@ -239,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 */
+/* uncomment this to support statically compiled C libs */
-/*   If set, this will statically include the clibs.c file */
+/*   Unless SEXP_USE_STATIC_LIBS_EMPTY is set (see below), this */
-/*   into the standard environment, so that you can have */
+/*   will statically include the clibs.c file into the standard */
-/*   access to a predefined set of C libraries without */
+/*   environment, so that you can have access to a predefined set */
-/*   needing dynamic loading.  The clibs.c file is generated */
+/*   of C libraries without needing dynamic loading.  The clibs.c */
-/*   automatically by searching the lib directory for */
+/*   file is generated automatically by searching the lib directory */
-/*   modules with include-shared, but can be hand-tailored */
+/*   for modules with include-shared, but can be hand-tailored to */
-/*   to your needs. */
+/*   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 */
 
@@ -168,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 */
@@ -210,12 +246,32 @@
 /*   Making them immutable allows for packed UTF-8 strings. */
 /* #define SEXP_USE_MUTABLE_STRINGS 0 */
 
-/* uncomment this to make string cursors just fixnum offsets */
+/* uncomment this to enable precomputed index->cursor tables for strings */
-/*   The default when using UTF-8 is to have a disjoint string */
+/*   This makes string-ref faster at the expensive of making string */
-/*   cursor type.  This is an immediate type with no loss in  */
+/*   construction (including string-append and I/O) slower. */
-/*   performance, and prevents confusion mixing indexes and */
+/*   You can configure with SEXP_STRING_INDEX_TABLE_CHUNK_SIZE below, */
-/*   cursors. */
+/*   the default is caching every 64th index (<=12.5% string overhead). */
-/* #define SEXP_USE_DISJOINT_STRING_CURSORS 0 */
+/*   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 */
@@ -245,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 */
@@ -271,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
@@ -280,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__) || defined(__mips64__) || defined(__sparc64__)
+#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
@@ -301,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
@@ -309,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
@@ -349,13 +478,17 @@
 #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
-#ifdef 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
@@ -374,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
@@ -399,7 +540,11 @@
 #endif
 
 #ifndef SEXP_USE_TIME_GC
-#define SEXP_USE_TIME_GC SEXP_USE_DEBUG_GC > 0
+#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
@@ -422,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
@@ -459,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
@@ -533,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
@@ -549,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
@@ -629,6 +802,18 @@
 #define SEXP_USE_PACKED_STRINGS 1
 #endif
 
+#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
@@ -695,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
@@ -703,6 +892,10 @@
 #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
@@ -713,7 +906,7 @@
 #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
@@ -810,11 +1003,15 @@
 #endif
 
 #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

@@ -7,6 +7,12 @@
 
 #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.
    
@@ -90,10 +96,10 @@ SEXP_API sexp sexp_load_image (const char* filename, off_t offset, sexp_uint_t h
 */
 SEXP_API char* sexp_load_image_err();
 
+#ifdef __cplusplus
+}
+#endif
 
-/* Debugging tool.  Prints a summary of the heap structure to stdout.
+#endif  /* SEXP_USE_IMAGE_LOADING */
- */
-SEXP_API void sexp_gc_heap_stats_print(sexp ctx);
-
 
 #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-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],

include/chibi/sexp.h

@@ -1,5 +1,5 @@
 /*  sexp.h -- header for sexp library                         */
-/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2022 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #ifndef SEXP_H
@@ -7,12 +7,13 @@
 
 #ifdef __cplusplus
 extern "C" {
-#define SEXP_FLEXIBLE_ARRAY [1]
+#define SEXP_FLEXIBLE_ARRAY [SEXP_FLEXIBLE_ARRAY_SIZE]
 #else
 #define SEXP_FLEXIBLE_ARRAY []
 #endif
 
 #define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH"
+#define SEXP_NO_SYSTEM_PATH_VAR "CHIBI_IGNORE_SYSTEM_PATH"
 
 #include "chibi/features.h"
 #include "chibi/install.h"
@@ -81,6 +82,12 @@ typedef long long off_t;
 #define exit(x)           exits(TOSTRING(x))
 #define fabsl          fabs
 #define M_LN10         2.30258509299404568402  /* log_e 10 */
+#define FLT_RADIX 2
+#define isfinite(x) !(isNaN(x) || isInf(x,0))
+typedef u32int uint32_t;
+typedef s32int int32_t;
+typedef u64int uint64_t;
+typedef s64int int64_t;
 #else
 #include <stddef.h>
 #include <stdlib.h>
@@ -162,13 +169,13 @@ enum sexp_types {
   SEXP_VECTOR,
   SEXP_FLONUM,
   SEXP_BIGNUM,
-#if SEXP_USE_RATIOS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RATIOS
   SEXP_RATIO,
 #endif
-#if SEXP_USE_COMPLEX
+#if SEXP_USE_STABLE_ABI || SEXP_USE_COMPLEX
   SEXP_COMPLEX,
 #endif
-#if SEXP_USE_DISJOINT_STRING_CURSORS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_DISJOINT_STRING_CURSORS
   SEXP_STRING_CURSOR,
 #endif
   SEXP_IPORT,
@@ -181,7 +188,7 @@ enum sexp_types {
   SEXP_ENV,
   SEXP_BYTECODE,
   SEXP_CORE,
-#if SEXP_USE_DL
+#if SEXP_USE_STABLE_ABI || SEXP_USE_DL
   SEXP_DL,
 #endif
   SEXP_OPCODE,
@@ -195,10 +202,11 @@ enum sexp_types {
   SEXP_STACK,
   SEXP_CONTEXT,
   SEXP_CPOINTER,
-#if SEXP_USE_AUTO_FORCE
+  SEXP_UNIFORM_VECTOR,
+#if SEXP_USE_STABLE_ABI || SEXP_USE_AUTO_FORCE
   SEXP_PROMISE,
 #endif
-#if SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_STABLE_ABI || SEXP_USE_WEAK_REFERENCES
   SEXP_EPHEMERON,
 #endif
   SEXP_NUM_CORE_TYPES
@@ -209,37 +217,51 @@ enum sexp_types {
 #endif
 
 #ifdef _WIN32
-#if defined(_MSC_VER) && SEXP_64_BIT
-/* On SEXP_64_BIT, 128bits arithmetic is mandatory */
-#error Unsupported configuration
-#endif
 #if SEXP_64_BIT
 typedef unsigned int sexp_tag_t;
 typedef unsigned long long sexp_uint_t;
 typedef long long sexp_sint_t;
+#define SEXP_PRIdFIXNUM "lld"
 #else
 typedef unsigned short sexp_tag_t;
 typedef unsigned int sexp_uint_t;
 typedef int sexp_sint_t;
+#define SEXP_PRIdFIXNUM "d"
 #endif
 #define sexp_heap_align(n) sexp_align(n, 5)
 #define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
 #elif SEXP_64_BIT
+#if PLAN9
+typedef uintptr sexp_tag_t;
+typedef uintptr sexp_uint_t;
+typedef intptr sexp_sint_t;
+#else
 typedef unsigned int sexp_tag_t;
 typedef unsigned long sexp_uint_t;
 typedef long sexp_sint_t;
+#endif
+#define SEXP_PRIdFIXNUM "ld"
 #define sexp_heap_align(n) sexp_align(n, 5)
 #define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
 #elif defined(__CYGWIN__)
 typedef unsigned short sexp_tag_t;
 typedef unsigned int sexp_uint_t;
 typedef int sexp_sint_t;
+#define SEXP_PRIdFIXNUM "d"
 #define sexp_heap_align(n) sexp_align(n, 5)
 #define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
+#elif PLAN9
+typedef uintptr sexp_tag_t;
+typedef unsigned int sexp_uint_t;
+typedef int sexp_sint_t;
+#define SEXP_PRIdFIXNUM "d"
+#define sexp_heap_align(n) sexp_align(n, 4)
+#define sexp_heap_chunks(n) (sexp_heap_align(n)>>4)
 #else
 typedef unsigned short sexp_tag_t;
 typedef unsigned int sexp_uint_t;
 typedef int sexp_sint_t;
+#define SEXP_PRIdFIXNUM "d"
 #define sexp_heap_align(n) sexp_align(n, 4)
 #define sexp_heap_chunks(n) (sexp_heap_align(n)>>4)
 #endif
@@ -248,10 +270,15 @@ typedef int sexp_sint_t;
 #define SEXP_PROC_NONE ((sexp_uint_t)0)
 #define SEXP_PROC_VARIADIC ((sexp_uint_t)1)
 #define SEXP_PROC_UNUSED_REST ((sexp_uint_t)2)
+#define SEXP_PROC_VARIABLE_TRANSFORMER ((sexp_uint_t)4)
 
 
 #ifdef SEXP_USE_INTTYPES
-# include <inttypes.h>
+#ifdef PLAN9
+#include <ape/stdint.h>
+#else
+#include <stdint.h>
+#endif
 # ifdef UINT8_MAX
 #  define SEXP_UINT8_DEFINED 1
 typedef uint8_t  sexp_uint8_t;
@@ -266,6 +293,13 @@ typedef int32_t sexp_int32_t;
 # include <ape/limits.h>
 # else
 # include <limits.h>
+# if SEXP_USE_UNIFORM_VECTOR_LITERALS
+# ifdef PLAN9
+# include <ape/stdint.h>
+# else
+# include <stdint.h>
+# endif
+# endif
 # endif
 # if UCHAR_MAX == 255
 #  define SEXP_UINT8_DEFINED 1
@@ -284,12 +318,12 @@ typedef long sexp_int32_t;
 typedef unsigned short sexp_uint32_t;
 typedef short sexp_int32_t;
 # endif
-#endif
+#endif  /* SEXP_USE_INTTYPES */
 
 #if defined(__APPLE__) || defined(_WIN64) || (defined(__CYGWIN__) && __SIZEOF_POINTER__ == 8)
-#define PRIoff "%lld"
+#define SEXP_PRIdOFF "lld"
 #else
-#define PRIoff "%ld"
+#define SEXP_PRIdOFF "ld"
 #endif
 
 #if SEXP_USE_LONG_PROCEDURE_ARGS
@@ -361,12 +395,13 @@ struct sexp_gc_var_t {
   struct sexp_gc_var_t *next;
 };
 
-struct sexp_library_entry_t {   /* for static builds */
+struct sexp_library_entry_t {   /* for static builds and user exported C */
-  const char *name;
+  const char *name;             /* libaries */
   sexp_init_proc init;
 };
 
 struct sexp_type_struct {
+  sexp name, cpl, slots, getters, setters, id, print, dl, finalize_name;
   sexp_tag_t tag;
   short field_base, field_eq_len_base, field_len_base, field_len_off;
   unsigned short field_len_scale;
@@ -374,14 +409,13 @@ struct sexp_type_struct {
   unsigned short size_scale;
   short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra;
   short depth;
-  sexp name, cpl, slots, getters, setters, id, print, dl, finalize_name;
   sexp_proc2 finalize;
 };
 
 struct sexp_opcode_struct {
-  unsigned char op_class, code, num_args, flags, inverse;
   sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type,
     argn_type, methods, dl;
+  unsigned char op_class, code, num_args, flags, inverse;
   sexp_proc1 func;
 };
 
@@ -390,6 +424,17 @@ struct sexp_core_form_struct {
   sexp name;
 };
 
+struct sexp_mark_stack_ptr_t {
+  sexp *start, *end;
+  struct sexp_mark_stack_ptr_t *prev; /* TODO: remove for allocations on stack */
+};
+
+/* Note this must be kept in sync with the _sexp_type_specs type            */
+/* registry in sexp.c.  The structure of a sexp type is:                    */
+/*   [ HEADER [[EQ_FIELDS... ] GC_FIELDS...] [WEAK_FIELDS...] [OTHER...] ]  */
+/* Thus all sexp's must be contiguous and align at the start of the type.   */
+/* This is used by the gc, equal? and slot-ref (although only the latter    */
+/* expects the alignment at the start of the type). */
 struct sexp_struct {
   sexp_tag_t tag;
   char markedp;
@@ -397,6 +442,7 @@ struct sexp_struct {
   unsigned int freep:1;
   unsigned int brokenp:1;
   unsigned int syntacticp:1;
+  unsigned int copyonwritep:1;
 #if SEXP_USE_TRACK_ALLOC_SOURCE
   const char* source;
   void* backtrace[SEXP_BACKTRACE_SIZE];
@@ -415,47 +461,56 @@ struct sexp_struct {
     } pair;
     struct {
       sexp_uint_t length;
-      sexp data SEXP_FLEXIBLE_ARRAY;
     } vector;
     struct {
       sexp_uint_t length;
-      char data SEXP_FLEXIBLE_ARRAY;
     } bytes;
     struct {
-#if SEXP_USE_PACKED_STRINGS
-      sexp_uint_t length;
-      char data SEXP_FLEXIBLE_ARRAY;
-#else
-      sexp_uint_t offset, length;
       sexp bytes;
+      unsigned char element_type;
+      sexp_sint_t length;
+    } uvector;
+    struct {
+#if SEXP_USE_PACKED_STRINGS
+#if SEXP_USE_STRING_INDEX_TABLE
+      sexp charlens;
+#endif
+      sexp_uint_t length;
+#else
+      sexp bytes;
+#if SEXP_USE_STRING_INDEX_TABLE
+      sexp charlens;
+#elif SEXP_USE_STRING_REF_CACHE
+      sexp_uint_t cached_char_idx;
+      sexp cached_cursor;
+#endif
+      sexp_uint_t offset, length;
 #endif
     } string;
     struct {
       sexp_uint_t length;
-      char data SEXP_FLEXIBLE_ARRAY;
     } symbol;
     struct {
+      sexp name;
+      sexp cookie;
+      sexp fd;
       FILE *stream;
       char *buf;
       char openp, bidirp, binaryp, shutdownp, no_closep, sourcep,
         blockedp, fold_casep;
       sexp_uint_t offset, line, flags;
       size_t size;
-      sexp name;
-      sexp cookie;
-      sexp fd;
     } port;
     struct {
       char openp, no_closep;
       sexp_sint_t fd, count;
     } fileno;
     struct {
-      sexp kind, message, irritants, procedure, source;
+      sexp kind, message, irritants, procedure, source, stack_trace;
     } exception;
     struct {
       signed char sign;
       sexp_uint_t length;
-      sexp_uint_t data SEXP_FLEXIBLE_ARRAY;
     } bignum;
     struct {
       sexp numerator, denominator;
@@ -464,33 +519,31 @@ struct sexp_struct {
       sexp real, imag;
     } complex;
     struct {
+      sexp parent;
       sexp_uint_t length;
       void *value;
-      sexp parent;
-      char body SEXP_FLEXIBLE_ARRAY;
     } cpointer;
     /* runtime types */
     struct {
       sexp parent, lambda, bindings;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
       sexp renames;
 #endif
     } env;
     struct {
-      sexp_uint_t length, max_depth;
       sexp name, literals, source;
-      unsigned char data SEXP_FLEXIBLE_ARRAY;
+      sexp_uint_t length, max_depth;
     } bytecode;
     struct {
-      char flags;
-      sexp_proc_num_args_t num_args;
       sexp bc, vars;
+      char flags;  /* a boxed fixnum truncated to char */
+      sexp_proc_num_args_t num_args;
     } procedure;
     struct {
-      sexp proc, env, source;
+      sexp proc, env, source, aux;
     } macro;
     struct {
-      sexp env, free_vars, expr;
+      sexp env, free_vars, expr, rename;
     } synclo;
     struct {
       sexp file;
@@ -523,34 +576,43 @@ struct sexp_struct {
     /* compiler state */
     struct {
       sexp_uint_t length, top;
-      sexp data SEXP_FLEXIBLE_ARRAY;
     } stack;
     struct {
+      sexp stack, env, parent, child,
+        globals, dk, params, proc, name, specific, event, result;
+#if SEXP_USE_STABLE_ABI || SEXP_USE_DL
+      sexp dl;
+#endif
       sexp_heap heap;
+      struct sexp_mark_stack_ptr_t mark_stack[SEXP_MARK_STACK_COUNT];
+      struct sexp_mark_stack_ptr_t *mark_stack_ptr;
       struct sexp_gc_var_t *saves;
 #if SEXP_USE_GREEN_THREADS
       sexp_sint_t refuel;
       unsigned char* ip;
       struct timeval tval;
 #endif
-      char tailp, tracep, timeoutp, waitp, errorp;
+      char tailp, tracep, timeoutp, waitp, errorp, interruptp;
       sexp_uint_t last_fp;
+      sexp_uint_t gc_count;
 #if SEXP_USE_TIME_GC
-      sexp_uint_t gc_count, gc_usecs;
+      sexp_uint_t gc_usecs;
 #endif
-      sexp stack, env, parent, child,
+#if SEXP_USE_TRACK_ALLOC_TIMES
-        globals, dk, params, proc, name, specific, event, result;
+      sexp_uint_t alloc_count, alloc_usecs;
-#if SEXP_USE_DL
+      double alloc_usecs_sq;
-      sexp dl;
+#endif
+#if SEXP_USE_TRACK_ALLOC_SIZES
+      sexp_uint_t alloc_histogram[SEXP_ALLOC_HISTOGRAM_BUCKETS];
 #endif
     } context;
-#if SEXP_USE_AUTO_FORCE
+#if SEXP_USE_STABLE_ABI || SEXP_USE_AUTO_FORCE
     struct {
-      int donep;
       sexp value;
+      int donep;
     } promise;
 #endif
-#if SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_STABLE_ABI || SEXP_USE_WEAK_REFERENCES
     struct {
       sexp key, value;
     } ephemeron;
@@ -571,9 +633,10 @@ struct sexp_struct {
 #define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
 #define SEXP_STRING_OPORT SEXP_MAKE_IMMEDIATE(8)  /* internal use */
 #define SEXP_TRAMPOLINE   SEXP_MAKE_IMMEDIATE(9)  /* internal use */
-#define SEXP_ABI_ERROR    SEXP_MAKE_IMMEDIATE(10) /* internal use */
+#define SEXP_UNCAUGHT     SEXP_MAKE_IMMEDIATE(10) /* internal use */
+#define SEXP_ABI_ERROR    SEXP_MAKE_IMMEDIATE(11) /* internal use */
 #if SEXP_USE_OBJECT_BRACE_LITERALS
-#define SEXP_CLOSE_BRACE  SEXP_MAKE_IMMEDIATE(11) /* internal use */
+#define SEXP_CLOSE_BRACE  SEXP_MAKE_IMMEDIATE(12) /* internal use */
 #endif
 
 #if SEXP_USE_LIMITED_MALLOC
@@ -711,9 +774,11 @@ void* sexp_alloc(sexp ctx, size_t size);
 #define sexp_markedp(x)          ((x)->markedp)
 #define sexp_flags(x)            ((x)->flags)
 #define sexp_immutablep(x)       ((x)->immutablep)
+#define sexp_mutablep(x)         (!(x)->immutablep)
 #define sexp_freep(x)            ((x)->freep)
 #define sexp_brokenp(x)          ((x)->brokenp)
 #define sexp_pointer_magic(x)    ((x)->magic)
+#define sexp_copy_on_writep(x)   ((x)->copyonwritep)
 
 #if SEXP_USE_TRACK_ALLOC_SOURCE
 #define sexp_pointer_source(x)   ((x)->source)
@@ -728,15 +793,17 @@ void* sexp_alloc(sexp ctx, size_t size);
 
 #define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b)))
 
-#if SEXP_USE_IMMEDIATE_FLONUMS
 union sexp_flonum_conv {
   float flonum;
   unsigned int bits;
 };
+
+#if SEXP_USE_IMMEDIATE_FLONUMS
 #define sexp_flonump(x)      (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_IFLONUM_TAG)
 SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x);
 #if SEXP_64_BIT
 SEXP_API float sexp_flonum_value (sexp x);
+#define sexp_flonum_value_set(f, x) (f = sexp_make_flonum(NULL, x))
 #define sexp_flonum_bits(f) ((char*)&f)
 SEXP_API sexp sexp_make_flonum(sexp ctx, float f);
 #else
@@ -746,6 +813,7 @@ SEXP_API sexp sexp_make_flonum(sexp ctx, float f);
 #else
 #define sexp_flonump(x)      (sexp_check_tag(x, SEXP_FLONUM))
 #define sexp_flonum_value(f) ((f)->value.flonum)
+#define sexp_flonum_value_set(f, x) ((f)->value.flonum = x)
 #define sexp_flonum_bits(f) ((f)->value.flonum_bits)
 SEXP_API sexp sexp_make_flonum(sexp ctx, double f);
 #endif
@@ -800,6 +868,42 @@ SEXP_API sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_promisep(x)    (sexp_check_tag(x, SEXP_PROMISE))
 #define sexp_ephemeronp(x)  (sexp_check_tag(x, SEXP_EPHEMERON))
 
+#if SEXP_USE_UNIFORM_VECTOR_LITERALS
+#define sexp_uvectorp(x)    (sexp_check_tag(x, SEXP_UNIFORM_VECTOR))
+#define sexp_u1vectorp(x)   (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U1)
+#define sexp_u8vectorp(x)   (sexp_bytesp(x))
+#define sexp_s8vectorp(x)   (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S8)
+#define sexp_u16vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U16)
+#define sexp_s16vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S16)
+#define sexp_u32vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U32)
+#define sexp_s32vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S32)
+#define sexp_u64vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U64)
+#define sexp_s64vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S64)
+#define sexp_f8vectorp(x)   (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F8)
+#define sexp_f16vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F16)
+#define sexp_f32vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F32)
+#define sexp_f64vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F64)
+#define sexp_c64vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_C64)
+#define sexp_c128vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_C128)
+#else
+#define sexp_uvectorp(x)    (sexp_vectorp(x))
+#define sexp_u1vectorp(x)   (sexp_vectorp(x))
+#define sexp_u8vectorp(x)   (sexp_bytesp(x))
+#define sexp_s8vectorp(x)   (sexp_vectorp(x))
+#define sexp_u16vectorp(x)  (sexp_vectorp(x))
+#define sexp_s16vectorp(x)  (sexp_vectorp(x))
+#define sexp_u32vectorp(x)  (sexp_vectorp(x))
+#define sexp_s32vectorp(x)  (sexp_vectorp(x))
+#define sexp_u64vectorp(x)  (sexp_vectorp(x))
+#define sexp_s64vectorp(x)  (sexp_vectorp(x))
+#define sexp_f8vectorp(x)   (sexp_vectorp(x))
+#define sexp_f16vectorp(x)  (sexp_vectorp(x))
+#define sexp_f32vectorp(x)  (sexp_vectorp(x))
+#define sexp_f64vectorp(x)  (sexp_vectorp(x))
+#define sexp_c64vectorp(x)  (sexp_vectorp(x))
+#define sexp_c128vectorp(x) (sexp_vectorp(x))
+#endif
+
 #define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x))
 
 #if SEXP_USE_HUFF_SYMS
@@ -891,8 +995,15 @@ SEXP_API int sexp_idp(sexp x);
 #endif
 
 #if SEXP_USE_BIGNUMS
+SEXP_API sexp sexp_make_integer_from_lsint(sexp ctx, sexp_lsint_t x);
+SEXP_API sexp sexp_make_unsigned_integer_from_luint(sexp ctx, sexp_luint_t x);
+#if SEXP_USE_CUSTOM_LONG_LONGS
+SEXP_API sexp sexp_make_integer(sexp ctx, long long x);
+SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, unsigned long long x);
+#else
 SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x);
 SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
+#endif
 #define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x))
 #else
 #define sexp_make_integer(ctx, x) sexp_make_fixnum(x)
@@ -922,8 +1033,12 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 
 #if SEXP_USE_COMPLEX
 #define sexp_numberp(x) (sexp_realp(x) || sexp_complexp(x))
+#define sexp_real_part(x) (sexp_complexp(x) ? sexp_complex_real(x) : x)
+#define sexp_imag_part(x) (sexp_complexp(x) ? sexp_complex_imag(x) : SEXP_ZERO)
 #else
 #define sexp_numberp(x) (sexp_realp(x))
+#define sexp_real_part(x) (x)
+#define sexp_imag_part(x) SEXP_ZERO
 #endif
 
 #define sexp_exact_negativep(x) (sexp_fixnump(x) ? (sexp_unbox_fixnum(x) < 0) \
@@ -935,7 +1050,10 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_negativep(x) (sexp_exact_negativep(x) ||                   \
                            (sexp_flonump(x) && sexp_flonum_value(x) < 0))
 #define sexp_positivep(x) (!(sexp_negativep(x)))
-#define sexp_pedantic_negativep(x) (sexp_exact_negativep(x) ||          \
+#define sexp_pedantic_negativep(x) (                 \
+  sexp_exact_negativep(x) ||                         \
+  (sexp_ratiop(x) &&                                 \
+   sexp_exact_negativep(sexp_ratio_numerator(x))) || \
   (sexp_flonump(x) &&                                \
    ((sexp_flonum_value(x) < 0) ||                    \
     (sexp_flonum_value(x) == 0 &&                    \
@@ -961,19 +1079,39 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_negate_flonum(x) sexp_flonum_value(x) = -(sexp_flonum_value(x))
 #endif
 
+/* TODO: Doesn't support x == SEXP_MIN_FIXNUM. */
 #define sexp_negate(x)                                  \
   if (sexp_flonump(x))                                  \
     sexp_negate_flonum(x);                              \
   else                                                  \
     sexp_negate_exact(x)
 
+#define sexp_negate_maybe_ratio(x)                      \
+  if (sexp_ratiop(x)) {                                 \
+    sexp_negate_exact(sexp_ratio_numerator(x));         \
+  } else {                                              \
+    sexp_negate(x);                                     \
+  }
+
 #if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS
-#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignump(x) ? sexp_bignum_data(x)[0] : 0))
+
-#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignump(x) ? sexp_bignum_sign(x)*sexp_bignum_data(x)[0] : 0))
+#if SEXP_64_BIT
+#define sexp_bignum_to_sint(x) (sexp_bignum_sign(x)*sexp_bignum_data(x)[0])
+#define sexp_bignum_to_uint(x) (sexp_bignum_data(x)[0])
 #else
+SEXP_API long long sexp_bignum_to_sint(sexp x);
+SEXP_API unsigned long long sexp_bignum_to_uint(sexp x);
+#endif
+
+#define sexp_uint_value(x) ((unsigned long long)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignump(x) ? sexp_bignum_to_uint(x) : 0))
+#define sexp_sint_value(x) ((long long)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignump(x) ? sexp_bignum_to_sint(x) : 0))
+
+#else
+
 #define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x))
 #define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x))
-#endif
+
+#endif	/* SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS */
 
 #define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET)
 #define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET)
@@ -987,6 +1125,13 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_flonum_eqv(x, y) (sexp_flonum_value(x) == sexp_flonum_value(y))
 #endif
 
+#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
+SEXP_API double sexp_quarter_to_double(unsigned char q);
+SEXP_API unsigned char sexp_double_to_quarter(double f);
+SEXP_API double sexp_half_to_double(unsigned short x);
+SEXP_API unsigned short sexp_double_to_half(double x);
+#endif
+
 /*************************** field accessors **************************/
 
 #if SEXP_USE_SAFE_ACCESSORS
@@ -1005,8 +1150,11 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_cpointer_field(x, field) ((x)->value.cpointer.field)
 #endif
 
+#define sexp_flexible_array_field(x, type, field_type) \
+  ((field_type*)((char*)(x)+sexp_sizeof(type)))
+
 #define sexp_vector_length(x) (sexp_field(x, vector, SEXP_VECTOR, length))
-#define sexp_vector_data(x)   (sexp_field(x, vector, SEXP_VECTOR, data))
+#define sexp_vector_data(x)   sexp_flexible_array_field(x, vector, sexp)
 
 #if SEXP_USE_SAFE_VECTOR_ACCESSORS
 #define sexp_vector_ref(x,i)   (sexp_unbox_fixnum(i)>=0 && sexp_unbox_fixnum(i)<sexp_vector_length(x) ? sexp_vector_data(x)[sexp_unbox_fixnum(i)] : (fprintf(stderr, "vector-ref length out of range %s on line %d: vector %p (length %lu): %ld\n", __FILE__, __LINE__, x, sexp_vector_length(x), sexp_unbox_fixnum(i)), SEXP_VOID))
@@ -1020,23 +1168,66 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_procedure_flags(x)      (sexp_field(x, procedure, SEXP_PROCEDURE, flags))
 #define sexp_procedure_variadic_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIADIC)
 #define sexp_procedure_unused_rest_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_UNUSED_REST)
+#define sexp_procedure_variable_transformer_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIABLE_TRANSFORMER)
 #define sexp_procedure_code(x)       (sexp_field(x, procedure, SEXP_PROCEDURE, bc))
 #define sexp_procedure_vars(x)       (sexp_field(x, procedure, SEXP_PROCEDURE, vars))
 #define sexp_procedure_source(x)     sexp_bytecode_source(sexp_procedure_code(x))
 
 #define sexp_bytes_length(x)  (sexp_field(x, bytes, SEXP_BYTES, length))
-#define sexp_bytes_data(x)    (sexp_field(x, bytes, SEXP_BYTES, data))
+#define sexp_bytes_data(x)   sexp_flexible_array_field(x, bytes, char)
 #define sexp_bytes_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_bytes_data(x))
 
+static const unsigned char sexp_uvector_sizes[] = {
+  0, 1, 8, 8, 16, 16, 32, 32, 64, 64, 32, 64, 64, 128, 8, 16};
+static const unsigned char sexp_uvector_chars[] = "#ususususuffccff";
+
+enum sexp_uniform_vector_type {
+  SEXP_NOT_A_UNIFORM_TYPE,
+  SEXP_U1,
+  SEXP_S8,
+  SEXP_U8,
+  SEXP_S16,
+  SEXP_U16,
+  SEXP_S32,
+  SEXP_U32,
+  SEXP_S64,
+  SEXP_U64,
+  SEXP_F32,
+  SEXP_F64,
+  SEXP_C64,
+  SEXP_C128,
+  SEXP_F8,
+  SEXP_F16,
+  SEXP_END_OF_UNIFORM_TYPES
+};
+
+#define sexp_uvector_freep(x) (sexp_freep(x))
+#define sexp_uvector_element_size(uvt) (sexp_uvector_sizes[uvt])
+#define sexp_uvector_prefix(uvt) (sexp_uvector_chars[uvt])
+
+#define sexp_uvector_length(x) (sexp_field(x, uvector, SEXP_UNIFORM_VECTOR, length))
+#define sexp_uvector_type(x)   (sexp_field(x, uvector, SEXP_UNIFORM_VECTOR, element_type))
+#define sexp_uvector_data(x) sexp_bytes_data(sexp_uvector_bytes(x))
+#define sexp_uvector_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_uvector_data(x))
+#define sexp_uvector_bytes(x)  (sexp_field(x, uvector, SEXP_UNIFORM_VECTOR, bytes))
+
+#define sexp_bit_ref(u1v, i)    (((sexp_uvector_data(u1v)[i/8])>>(i%8))&1)
+#define sexp_bit_set(u1v, i, x) (x ? (sexp_uvector_data(u1v)[i/8]|=(1<<(i%8))) : (sexp_uvector_data(u1v)[i/8]&=~(1<<(i%8))))
+
 #define sexp_string_size(x)     (sexp_field(x, string, SEXP_STRING, length))
+#define sexp_string_charlens(x) (sexp_field(x, string, SEXP_STRING, charlens))
 #if SEXP_USE_PACKED_STRINGS
-#define sexp_string_data(x)   (sexp_field(x, string, SEXP_STRING, data))
+#define sexp_string_data(x)   sexp_flexible_array_field(x, string, char)
 #define sexp_string_bytes(x)  (x)
 #else
 #define sexp_string_bytes(x)  (sexp_field(x, string, SEXP_STRING, bytes))
 #define sexp_string_offset(x) (sexp_field(x, string, SEXP_STRING, offset))
 #define sexp_string_data(x)   (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x))
 #endif
+#if SEXP_USE_STRING_REF_CACHE
+#define sexp_cached_char_idx(x) (sexp_field(x, string, SEXP_STRING, cached_char_idx))
+#define sexp_cached_cursor(x) (sexp_field(x, string, SEXP_STRING, cached_cursor))
+#endif
 #define sexp_string_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_string_data(x))
 
 #if SEXP_USE_PACKED_STRINGS
@@ -1048,7 +1239,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_bytes_ref(x, i)    (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)]))
 #define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v))
 
-#define sexp_lsymbol_data(x)   (sexp_field(x, symbol, SEXP_SYMBOL, data))
+#define sexp_lsymbol_data(x)   sexp_flexible_array_field(x, symbol, char)
 #define sexp_lsymbol_length(x) (sexp_field(x, symbol, SEXP_SYMBOL, length))
 
 #define sexp_port_stream(p)     (sexp_pred_field(p, port, sexp_portp, stream))
@@ -1086,6 +1277,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_exception_irritants(x) (sexp_field(x, exception, SEXP_EXCEPTION, irritants))
 #define sexp_exception_procedure(x) (sexp_field(x, exception, SEXP_EXCEPTION, procedure))
 #define sexp_exception_source(x)    (sexp_field(x, exception, SEXP_EXCEPTION, source))
+#define sexp_exception_stack_trace(x) (sexp_field(x, exception, SEXP_EXCEPTION, stack_trace))
 
 #define sexp_trampolinep(x) (sexp_exceptionp(x) && sexp_exception_kind(x) == SEXP_TRAMPOLINE)
 #define sexp_trampoline_procedure(x) sexp_exception_procedure(x)
@@ -1094,7 +1286,6 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 
 #define sexp_cpointer_freep(x)      (sexp_freep(x))
 #define sexp_cpointer_length(x)     (sexp_cpointer_field(x, length))
-#define sexp_cpointer_body(x)       (sexp_cpointer_field(x, body))
 #define sexp_cpointer_parent(x)     (sexp_cpointer_field(x, parent))
 #define sexp_cpointer_value(x)      (sexp_cpointer_field(x, value))
 #define sexp_cpointer_maybe_null_value(x) (sexp_not(x) ? NULL : sexp_cpointer_value(x))
@@ -1104,7 +1295,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_bytecode_name(x)     (sexp_field(x, bytecode, SEXP_BYTECODE, name))
 #define sexp_bytecode_literals(x) (sexp_field(x, bytecode, SEXP_BYTECODE, literals))
 #define sexp_bytecode_source(x)   (sexp_field(x, bytecode, SEXP_BYTECODE, source))
-#define sexp_bytecode_data(x)     (sexp_field(x, bytecode, SEXP_BYTECODE, data))
+#define sexp_bytecode_data(x)     sexp_flexible_array_field(x, bytecode, unsigned char)
 
 #define sexp_env_cell_syntactic_p(x)   ((x)->syntacticp)
 
@@ -1119,10 +1310,12 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_macro_proc(x)        (sexp_field(x, macro, SEXP_MACRO, proc))
 #define sexp_macro_env(x)         (sexp_field(x, macro, SEXP_MACRO, env))
 #define sexp_macro_source(x)      (sexp_field(x, macro, SEXP_MACRO, source))
+#define sexp_macro_aux(x)         (sexp_field(x, macro, SEXP_MACRO, aux))
 
 #define sexp_synclo_env(x)        (sexp_field(x, synclo, SEXP_SYNCLO, env))
 #define sexp_synclo_free_vars(x)  (sexp_field(x, synclo, SEXP_SYNCLO, free_vars))
 #define sexp_synclo_expr(x)       (sexp_field(x, synclo, SEXP_SYNCLO, expr))
+#define sexp_synclo_rename(x)     (sexp_field(x, synclo, SEXP_SYNCLO, rename))
 
 #define sexp_core_code(x)         (sexp_field(x, core, SEXP_CORE, code))
 #define sexp_core_name(x)         (sexp_field(x, core, SEXP_CORE, name))
@@ -1192,7 +1385,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 
 #define sexp_stack_length(x)  (sexp_field(x, stack, SEXP_STACK, length))
 #define sexp_stack_top(x)     (sexp_field(x, stack, SEXP_STACK, top))
-#define sexp_stack_data(x)    (sexp_field(x, stack, SEXP_STACK, data))
+#define sexp_stack_data(x)    sexp_flexible_array_field(x, stack, sexp)
 
 #define sexp_promise_donep(x) (sexp_field(x, promise, SEXP_PROMISE, donep))
 #define sexp_promise_value(x) (sexp_field(x, promise, SEXP_PROMISE, value))
@@ -1204,6 +1397,8 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_context_stack(x)    (sexp_field(x, context, SEXP_CONTEXT, stack))
 #define sexp_context_parent(x)   (sexp_field(x, context, SEXP_CONTEXT, parent))
 #define sexp_context_child(x)    (sexp_field(x, context, SEXP_CONTEXT, child))
+#define sexp_context_mark_stack(x)     (sexp_field(x, context, SEXP_CONTEXT, mark_stack))
+#define sexp_context_mark_stack_ptr(x) (sexp_field(x, context, SEXP_CONTEXT, mark_stack_ptr))
 #define sexp_context_saves(x)    (sexp_field(x, context, SEXP_CONTEXT, saves))
 #define sexp_context_tailp(x)    (sexp_field(x, context, SEXP_CONTEXT, tailp))
 #define sexp_context_tracep(x)   (sexp_field(x, context, SEXP_CONTEXT, tracep))
@@ -1211,13 +1406,20 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_context_dk(x)       (sexp_field(x, context, SEXP_CONTEXT, dk))
 #define sexp_context_params(x)   (sexp_field(x, context, SEXP_CONTEXT, params))
 #define sexp_context_last_fp(x)  (sexp_field(x, context, SEXP_CONTEXT, last_fp))
-#if SEXP_USE_TIME_GC
 #define sexp_context_gc_count(x) (sexp_field(x, context, SEXP_CONTEXT, gc_count))
+#if SEXP_USE_TIME_GC
 #define sexp_context_gc_usecs(x) (sexp_field(x, context, SEXP_CONTEXT, gc_usecs))
 #else
-#define sexp_context_gc_count(x) 0
 #define sexp_context_gc_usecs(x) 0
 #endif
+#if SEXP_USE_TRACK_ALLOC_TIMES
+#define sexp_context_alloc_count(x) (sexp_field(x, context, SEXP_CONTEXT, alloc_count))
+#define sexp_context_alloc_usecs(x) (sexp_field(x, context, SEXP_CONTEXT, alloc_usecs))
+#define sexp_context_alloc_usecs_sq(x) (sexp_field(x, context, SEXP_CONTEXT, alloc_usecs_sq))
+#endif
+#if SEXP_USE_TRACK_ALLOC_SIZES
+#define sexp_context_alloc_histogram(x) (sexp_field(x, context, SEXP_CONTEXT, alloc_histogram))
+#endif
 #define sexp_context_refuel(x)   (sexp_field(x, context, SEXP_CONTEXT, refuel))
 #define sexp_context_ip(x)       (sexp_field(x, context, SEXP_CONTEXT, ip))
 #define sexp_context_proc(x)     (sexp_field(x, context, SEXP_CONTEXT, proc))
@@ -1231,6 +1433,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 
 #define sexp_context_result(x)   (sexp_field(x, context, SEXP_CONTEXT, result))
 #define sexp_context_errorp(x)   (sexp_field(x, context, SEXP_CONTEXT, errorp))
+#define sexp_context_interruptp(x) (sexp_field(x, context, SEXP_CONTEXT, interruptp))
 
 /* during compilation, sexp_context_specific is set to a vector */
 /* containing the following elements: */
@@ -1327,7 +1530,7 @@ SEXP_API sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
 
 #define sexp_bignum_sign(x)            (sexp_field(x, bignum, SEXP_BIGNUM, sign))
 #define sexp_bignum_length(x)          (sexp_field(x, bignum, SEXP_BIGNUM, length))
-#define sexp_bignum_data(x)            (sexp_field(x, bignum, SEXP_BIGNUM, data))
+#define sexp_bignum_data(x)            sexp_flexible_array_field(x, bignum, sexp_uint_t)
 
 /****************************** arithmetic ****************************/
 
@@ -1357,15 +1560,17 @@ SEXP_API sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
 /****************************** utilities *****************************/
 
 enum sexp_context_globals {
-#if ! SEXP_USE_GLOBAL_SYMBOLS
+#if SEXP_USE_STABLE_ABI || ! SEXP_USE_GLOBAL_SYMBOLS
   SEXP_G_SYMBOLS,
 #endif
+  SEXP_G_ENDIANNESS,
   SEXP_G_TYPES,
   SEXP_G_FEATURES,
   SEXP_G_NUM_TYPES,
   SEXP_G_OOM_ERROR,             /* out of memory exception object */
   SEXP_G_OOS_ERROR,             /* out of stack exception object */
   SEXP_G_ABI_ERROR,             /* incompatible ABI loading library */
+  SEXP_G_INTERRUPT_ERROR,       /* C-c in the repl */
   SEXP_G_OPTIMIZATIONS,
   SEXP_G_SIGNAL_HANDLERS,
   SEXP_G_META_ENV,
@@ -1374,6 +1579,10 @@ enum sexp_context_globals {
   SEXP_G_QUASIQUOTE_SYMBOL,
   SEXP_G_UNQUOTE_SYMBOL,
   SEXP_G_UNQUOTE_SPLICING_SYMBOL,
+  SEXP_G_SYNTAX_SYMBOL,
+  SEXP_G_QUASISYNTAX_SYMBOL,
+  SEXP_G_UNSYNTAX_SYMBOL,
+  SEXP_G_UNSYNTAX_SPLICING_SYMBOL,
   SEXP_G_EMPTY_VECTOR,
   SEXP_G_CUR_IN_SYMBOL,
   SEXP_G_CUR_OUT_SYMBOL,
@@ -1386,18 +1595,18 @@ enum sexp_context_globals {
   SEXP_G_RANDOM_SOURCE,
   SEXP_G_STRICT_P,
   SEXP_G_NO_TAIL_CALLS_P,
-#if SEXP_USE_FOLD_CASE_SYMS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_FOLD_CASE_SYMS
   SEXP_G_FOLD_CASE_P,
 #endif
-#if SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_STABLE_ABI || SEXP_USE_WEAK_REFERENCES
   SEXP_G_WEAK_OBJECTS_PRESENT,
   SEXP_G_FILE_DESCRIPTORS,
   SEXP_G_NUM_FILE_DESCRIPTORS,
 #endif
-#if ! SEXP_USE_BOEHM
+#if SEXP_USE_STABLE_ABI || ! SEXP_USE_BOEHM
   SEXP_G_PRESERVATIVES,
 #endif
-#if SEXP_USE_GREEN_THREADS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_GREEN_THREADS
   SEXP_G_IO_BLOCK_ERROR,
   SEXP_G_IO_BLOCK_ONCE_ERROR,
   SEXP_G_THREAD_TERMINATE_ERROR,
@@ -1495,10 +1704,21 @@ sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl);
 #define sexp_current_source_param
 #endif
 
+/* To export a library from the embedding C program to Scheme, so    */
+/* that it can be included into Scheme library foo/qux.sld as        */
+/* (include-shared "bar"), libraries should contain the entry        */
+/* {"foo/bar", init_bar}.  The signature and function of init_bar is */
+/* the same as that of sexp_init_library in shared libraries.  The   */
+/* array libraries must be terminated with {NULL, NULL} and must     */
+/* remain valid throughout its use by Chibi.                         */
+
+SEXP_API void sexp_add_static_libraries(struct sexp_library_entry_t* libraries);
+
 SEXP_API sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_current_source_param);
 SEXP_API sexp sexp_make_context(sexp ctx, size_t size, size_t max_size);
 SEXP_API sexp sexp_cons_op(sexp ctx, sexp self, sexp_sint_t n, sexp head, sexp tail);
 SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_list3(sexp ctx, sexp a, sexp b, sexp c);
 SEXP_API sexp sexp_equalp_bound (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp depth, sexp bound);
 SEXP_API sexp sexp_equalp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b);
 SEXP_API sexp sexp_listp_op(sexp ctx, sexp self, sexp_sint_t n, sexp obj);
@@ -1512,6 +1732,7 @@ SEXP_API sexp sexp_length_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls);
 SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen);
 SEXP_API sexp sexp_make_ephemeron_op(sexp ctx, sexp self, sexp_sint_t n, sexp key, sexp value);
 SEXP_API sexp sexp_make_bytes_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp i);
+SEXP_API sexp sexp_make_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp elt_type, sexp len);
 SEXP_API sexp sexp_make_string_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp ch);
 SEXP_API sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end);
 SEXP_API sexp sexp_subbytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end);
@@ -1523,6 +1744,7 @@ SEXP_API sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp
 SEXP_API sexp sexp_flonump_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_make_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp dflt);
 SEXP_API sexp sexp_list_to_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls);
+SEXP_API sexp sexp_list_to_uvector_op (sexp ctx, sexp self, sexp_sint_t n, sexp etype, sexp ls);
 SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep);
 SEXP_API int sexp_is_separator(int c);
 SEXP_API sexp sexp_write_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out);
@@ -1568,17 +1790,22 @@ SEXP_API sexp sexp_lookup_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name
 SEXP_API sexp sexp_open_input_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp str);
 SEXP_API sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n);
 SEXP_API sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source);
 SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x);
+SEXP_API sexp sexp_user_exception_ls (sexp ctx, sexp self, const char *msg, int n, ...);
 SEXP_API sexp sexp_file_exception (sexp ctx, sexp self, const char *msg, sexp x);
 SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x);
 SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x);
 SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
+SEXP_API sexp sexp_get_stack_trace (sexp ctx);
 SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
 SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
+SEXP_API sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
 SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
 SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
 SEXP_API sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y);
+SEXP_API sexp sexp_apply3 (sexp ctx, sexp f, sexp x, sexp y, sexp z);
 SEXP_API sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args);
 SEXP_API sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args);
 SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
@@ -1600,7 +1827,7 @@ SEXP_API int sexp_write_utf8_char (sexp ctx, int c, sexp out);
 #define sexp_string_ref(ctx, s, i)    (sexp_string_utf8_index_ref(ctx, NULL, 2, s, i))
 #define sexp_string_set(ctx, s, i, ch) (sexp_string_utf8_index_set(ctx, NULL, 3, s, i, ch))
 #define sexp_string_cursor_ref(ctx, s, i)    (sexp_string_utf8_ref(ctx, s, i))
-#define sexp_string_cursor_set(ctx, s, i)    (sexp_string_utf8_set(ctx, s, i))
+#define sexp_string_cursor_set(ctx, s, i, ch)    (sexp_string_utf8_set(ctx, s, i, ch))
 #define sexp_string_cursor_next(s, i) sexp_make_string_cursor(sexp_unbox_string_cursor(i) + sexp_utf8_initial_byte_count(((unsigned char*)sexp_string_data(s))[sexp_unbox_string_cursor(i)]))
 #define sexp_string_cursor_prev(s, i) sexp_make_string_cursor(sexp_string_utf8_prev((unsigned char*)sexp_string_data(s)+sexp_unbox_string_cursor(i)) - sexp_string_data(s))
 #define sexp_string_length(s) sexp_string_utf8_length((unsigned char*)sexp_string_data(s), sexp_string_size(s))
@@ -1618,6 +1845,12 @@ SEXP_API int sexp_write_utf8_char (sexp ctx, int c, sexp out);
 #define sexp_substring_cursor(ctx, s, i, j) sexp_substring_op(ctx, NULL, 3, s, i, j)
 #endif
 
+#if SEXP_USE_STRING_INDEX_TABLE
+SEXP_API void sexp_update_string_index_lookup(sexp ctx, sexp s);
+#else
+#define sexp_update_string_index_lookup(ctx, s)
+#endif
+
 #if SEXP_USE_GREEN_THREADS
 SEXP_API int sexp_maybe_block_port (sexp ctx, sexp in, int forcep);
 SEXP_API void sexp_maybe_unblock_port (sexp ctx, sexp in);
@@ -1653,9 +1886,13 @@ SEXP_API sexp sexp_finalize (sexp ctx);
 
 #if SEXP_USE_GLOBAL_HEAP
 #define sexp_free_heap(heap)
+#define sexp_debug_heap_stats(heap)
 #define sexp_destroy_context(ctx) SEXP_TRUE
 #else
 SEXP_API void sexp_free_heap (sexp_heap heap);
+SEXP_API void sexp_debug_heap_stats (sexp_heap heap);
+SEXP_API void sexp_debug_alloc_times(sexp ctx);
+SEXP_API void sexp_debug_alloc_sizes(sexp ctx);
 SEXP_API sexp sexp_destroy_context (sexp ctx);
 SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags);
 #endif
@@ -1699,6 +1936,7 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp);
 #define sexp_read(ctx, in) sexp_read_op(ctx, NULL, 1, in)
 #define sexp_write(ctx, obj, out) sexp_write_op(ctx, NULL, 2, obj, out)
 #define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx, NULL, 2, e, out)
+#define sexp_print_exception_stack_trace(ctx, e, out) sexp_print_exception_stack_trace_op(ctx, NULL, 2, e, out)
 #define sexp_flush_output(ctx, out) sexp_flush_output_op(ctx, NULL, 1, out)
 #define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx, NULL, 2, a, b)
 #define sexp_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x)
@@ -1711,12 +1949,20 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp);
 #define sexp_append2(ctx, a, b) sexp_append2_op(ctx, NULL, 2, a, b)
 #define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx, NULL, 2, a, b)
 #define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx, NULL, 1, x)
+#define sexp_list_to_uvector(ctx, etype, ls) sexp_list_to_uvector_op(ctx, NULL, 2, etype, ls)
 #define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx, NULL, 1, x)
 #define sexp_string_to_symbol(ctx, s) sexp_string_to_symbol_op(ctx, NULL, 1, s)
 #define sexp_string_to_number(ctx, s, b) sexp_string_to_number_op(ctx, NULL, 2, s, b)
 #define sexp_symbol_to_string(ctx, s) sexp_symbol_to_string_op(ctx, NULL, 1, s)
 #define sexp_make_ephemeron(ctx, k, v) sexp_make_ephemeron_op(ctx, NULL, 2, k, v)
 #define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx, NULL, 2, l, i)
+#if SEXP_USE_UNIFORM_VECTOR_LITERALS
+#define sexp_make_uvector(ctx, et, l) sexp_make_uvector_op(ctx, NULL, 2, et, l)
+#else
+#define sexp_make_uvector(ctx, et, l) sexp_make_vector(ctx, l, SEXP_ZERO)
+#define sexp_write_uvector NULL
+#define sexp_finalize_uvector NULL
+#endif
 #define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx, NULL, 2, l, c)
 #define sexp_subbytes(ctx, a, b, c) sexp_subbytes_op(ctx, NULL, 3, a, b, c)
 #define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx, NULL, 2, ls, s)

js/exported_functions.json

@@ -1,5 +1,4 @@
 [
-  '_main',
+    "_main",
-  '_sexp_resume'
+    "_sexp_resume"
 ]
-

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

@@ -41,4 +41,9 @@
           (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},
+;;> The high-level interface.  Parses a command-line with optional
-;;> parses the given command-line arguments \var{args} into a config
+;;> and/or positional arguments, with arbitrarily nested subcommands
-;;> object, prepended to the existing object \var{config} if given.
+;;> (optionally having their own arguments), and calls the
-;;> Then runs the corresponding command (or sub-command) procedure
+;;> corresponding main procedure on the parsed config.
-;;> from \var{spec}.
+;;>
+;;> 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{(@ <opt-spec>)} - option spec, described below}
-;;> \item[\scheme{(begin: <begin-proc>)} - procedure to run before main]
+;;> \item{\scheme{(begin: <begin-proc>)} - procedure to run before main}
-;;> \item[\scheme{(end: <end-proc>)} - procedure to run after main]
+;;> \item{\scheme{(end: <end-proc>)} - procedure to run after main}
-;;> \item[\scheme{(<proc> args ...)} - main procedure (args only for documentation)]
+;;> \item{\scheme{(types: (<type-name> <parser>) ...)} - additional types that can be used in argument parsing}
-;;> \item[\scheme{<app-spec>} - a subcommand described by the nested spec]
+;;> \item{\scheme{(<proc> args ...)} - main procedure (args only for documentation)}
-;;> \item[\scheme{(or <app-spec> ...)} - an alternate list of subcommands]
+;;> \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))
@@ -140,7 +184,7 @@
       (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
@@ -150,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))
@@ -187,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)))
@@ -302,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
@@ -312,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))))))))
 
@@ -332,23 +379,42 @@
 ;;> 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))) '())
           ((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
+                    (cond
-                    (error reason opt)))))
+                     ((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 fail))
+      (parse-app prefix (cdr spec) opt-spec args config init end types fail))
      ((pair? (car spec))
       (case (caar spec)
         ((@)
@@ -364,38 +430,41 @@
                    (car tail))))
                 (new-fail
                  (lambda (new-prefix new-spec new-opt new-args reason)
-                   (parse-option (prev-prefix prefix) opt-spec new-args fail)))
+                   (parse-option (prev-prefix prefix) opt-spec new-args types fail)))
-                (cfg+args (parse-options prefix new-opt-spec args new-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
@@ -469,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

@@ -72,7 +72,7 @@ sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, s
       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;
@@ -98,9 +98,26 @@ sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp pro
   return sexp_make_boolean(sexp_procedure_variadic_p(proc));
 }
 
+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_make_fixnum(sexp_procedure_flags(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) {
@@ -216,6 +233,18 @@ sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
   return SEXP_VOID;
 }
 
+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);
@@ -335,12 +364,21 @@ 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_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_immutable_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp s) {
-  if (sexp_pointerp(x)) {
+  sexp res;
-    sexp_immutablep(x) = 1;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, s);
-    return SEXP_TRUE;
+#if SEXP_USE_PACKED_STRINGS
-  }
+  /* no sharing with packed strings */
-  return SEXP_FALSE;
+  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) {
@@ -476,6 +514,12 @@ sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
 }
 #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_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
@@ -582,6 +626,7 @@ 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;
@@ -632,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);
@@ -656,23 +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, 0, "bytecode-name", "bytecode-name-set!");
-  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-literals", NULL);
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-literals", NULL);
-  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 4, "bytecode-source", 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);
@@ -695,6 +744,8 @@ 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);
@@ -712,7 +763,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   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, "make-immutable!", 1, sexp_make_immutable_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);
@@ -721,6 +772,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
 #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_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);
@@ -730,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{Object} - the parent of all types}
-;;> \item{\scheme{<number>} - abstract numeric type}
+;;> \item{\scheme{Number} - abstract numeric type}
-;;> \item{\scheme{<bignum>} - arbitrary precision exact integers}
+;;> \item{\scheme{Bignum} - arbitrary precision exact integers}
-;;> \item{\scheme{<flonum>} - inexact real numbers}
+;;> \item{\scheme{Flonum} - inexact real numbers}
-;;> \item{\scheme{<integer>} - abstract integer type}
+;;> \item{\scheme{Integer} - abstract integer type}
-;;> \item{\scheme{<symbol>} - symbols}
+;;> \item{\scheme{Symbol} - symbols}
-;;> \item{\scheme{<char>} - character}
+;;> \item{\scheme{Char} - character}
-;;> \item{\scheme{<boolean>} - \scheme{#t} or \scheme{#f}}
+;;> \item{\scheme{Boolean} - \scheme{#t} or \scheme{#f}}
-;;> \item{\scheme{<string>} - strings of characters}
+;;> \item{\scheme{String} - strings of characters}
-;;> \item{\scheme{<byte-vector>} - uniform vector of octets}
+;;> \item{\scheme{Byte-Vector} - uniform vector of octets}
-;;> \item{\scheme{<pair>} - a \var{car} and \var{cdr}, the basis for lists}
+;;> \item{\scheme{Pair} - a \var{car} and \var{cdr}, the basis for lists}
-;;> \item{\scheme{<vector>} - vectors}
+;;> \item{\scheme{Vector} - vectors}
-;;> \item{\scheme{<opcode>} - a primitive opcode or C function}
+;;> \item{\scheme{Opcode} - a primitive opcode or C function}
-;;> \item{\scheme{<procedure>} - a closure}
+;;> \item{\scheme{Procedure} - a closure}
-;;> \item{\scheme{<bytecode>} - the compiled code for a closure}
+;;> \item{\scheme{Bytecode} - the compiled code for a closure}
-;;> \item{\scheme{<env>} - an environment structure}
+;;> \item{\scheme{Env} - an environment structure}
-;;> \item{\scheme{<macro>} - a macro object, usually not first-class}
+;;> \item{\scheme{Macro} - a macro object, usually not first-class}
-;;> \item{\scheme{<lam>} - a lambda AST type}
+;;> \item{\scheme{Lam} - a lambda AST type}
-;;> \item{\scheme{<cnd>} - an conditional AST type (i.e. \scheme{if})}
+;;> \item{\scheme{Cnd} - an conditional AST type (i.e. \scheme{if})}
-;;> \item{\scheme{<ref>} - a reference AST type}
+;;> \item{\scheme{Ref} - a reference AST type}
-;;> \item{\scheme{<set>} - a mutation AST type (i.e. \scheme{set!})}
+;;> \item{\scheme{Set} - a mutation AST type (i.e. \scheme{set!})}
-;;> \item{\scheme{<seq>} - a sequence AST type}
+;;> \item{\scheme{Seq} - a sequence AST type}
-;;> \item{\scheme{<lit>} - a literal AST type}
+;;> \item{\scheme{Lit} - a literal AST type}
-;;> \item{\scheme{<sc>} - a syntactic closure}
+;;> \item{\scheme{Sc} - a syntactic closure}
-;;> \item{\scheme{<context>} - a context object (including threads)}
+;;> \item{\scheme{Context} - a context object (including threads)}
-;;> \item{\scheme{<exception>} - an exception object}
+;;> \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,7 +1,8 @@
 
 (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
@@ -20,17 +21,18 @@
    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?
+   opcode-class opcode-code opcode-data opcode-variadic? opcode?
-   macro-procedure macro-env macro-source
+   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-flags
+   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
@@ -39,7 +41,9 @@
    atomically thread-list abort
    string-contains string-cursor-copy! errno integer->error-string
    flatten-dot update-free-vars! setenv unsetenv safe-setenv
-   immutable? make-immutable!)
+   immutable? immutable-string make-immutable!
+   thread-interrupt!
+   chibi-version)
   (import (chibi))
   (include-shared "ast")
   (include "ast.scm"))

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,6 +1,80 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; binary records
+;; Binary Records
+
+;;> \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
+  (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:)
@@ -84,9 +158,3 @@
     ((defrec ((block:) . rest) n m p r w b f s)
      (defrec rest n m p r w b f s))
     ))
-
-(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.sld

@@ -8,6 +8,26 @@
   (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
@@ -16,9 +36,8 @@
    octal decimal hexadecimal
    ;; auxiliary syntax
    make: pred: read: write: block:
-   ;; indirect exports
+   ;; new types
-   define-binary-type defrec define-auxiliary-syntax
+   define-binary-type)
-   syntax-let-optionals*)
   (include "binary-types.scm")
   (cond-expand
    (chicken

lib/chibi/binary-types.scm

@@ -85,20 +85,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; syntax
 
-(define-syntax define-auxiliary-syntax
-  (syntax-rules ()
-    ((define-auxiliary-syntax name)
-     (define-syntax name
-       (syntax-rules ()
-         ((name . x)
-          (syntax-error "invalid use of auxilliary syntax" (name . x))))))))
-
-(define-auxiliary-syntax make:)
-(define-auxiliary-syntax pred:)
-(define-auxiliary-syntax read:)
-(define-auxiliary-syntax write:)
-(define-auxiliary-syntax block:)
-
 (define-syntax syntax-let-optionals*
   (syntax-rules ()
     ((syntax-let-optionals* () type-args expr)

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,13 +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)
+   bytevector->hex-string hex-string->bytevector
-  (import (scheme base))
+   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
+   (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"))
+  (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/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)

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?)))
+   (chibi
-   (else (begin (define file-directory? file-exists?))))
+    (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/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

@@ -22,13 +22,13 @@
 
 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);
 }
 
@@ -92,6 +92,12 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
       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:
@@ -178,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);

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
@@ -274,14 +367,29 @@
          (force (or (env-ref env 'example-env) (current-environment)))))
     `(div
       ,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
-      (code
+      ,(let* ((res-out (open-output-string))
-       (div (@ (class . "result"))
+              (tmp-out (open-output-string))
-            ,(call-with-output-string
+              (tmp-err (open-output-string))
-               (lambda (out)
+              (res (parameterize ((current-output-port tmp-out)
-                 (protect (exn (#t (print-exception exn out)))
+                                  (current-error-port tmp-err))
-                   (let ((res (eval expr example-env)))
+                     (protect (exn (#t (print-exception exn tmp-err)))
-                     (display "=> " out)
+                       (eval expr example-env)))))
-                     (write res out))))))))))
+         (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))
@@ -321,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))
@@ -360,31 +468,45 @@
 (define (get-contents x)
   (if (null? x)
       '()
-      (let ((d (caar x)))
+      (let lp ((ls (cdr x))
-        (let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '()))
+               (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)
+         ((> (caar ls) depth)
-            (lp (cdr ls) parent (cons (car ls) kids) res))
+          (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}
+body {color: #000; background-color: #FFFFF8;}
-div#menu  {font-size: smaller; position: absolute; top: 50px; left: 0; width: 190px; height: 100%}
+div#menu  {font-size: smaller; position: absolute; top: 50px; left: 0; width: 250px; height: 100%}
-div#main  {position: absolute; top: 0; left: 200px; width: 540px; height: 100%}
+div#menu a:link {text-decoration: none}
-div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;}
+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))
@@ -403,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 '()))
@@ -573,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)
@@ -588,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
@@ -601,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
@@ -629,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)
@@ -687,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
@@ -700,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)))
@@ -717,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
@@ -725,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)))
@@ -908,7 +1041,8 @@ div#footer {padding-bottom: 50px}
 (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 (module-ref mod x))))
+                     (let ((val (and mod (protect (exn (else #f))
+                                           (module-ref mod x)))))
                        `(,x ,val ,(object-source val))))
                    exports)))
     (define (resolve-file file)

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.scm

@@ -104,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)))))
 

lib/chibi/filesystem.sld

@@ -33,7 +33,7 @@
           open/append      open/non-block
           file-lock        file-truncate
           file-is-readable? file-is-writable? file-is-executable?
-          chmod is-a-tty?)
+          chmod chown is-a-tty?)
   (cond-expand
    (chibi
     (export lock/shared lock/exclusive lock/non-blocking lock/unlock)

lib/chibi/filesystem.stub

@@ -267,6 +267,12 @@
 
 (define-c int chmod (string int))
 
+;;> Sets the file owner and group as in chown.
+
+(cond-expand
+  ((not windows)
+   (define-c int chown (string uid_t gid_t))))
+
 ;;> Returns \scheme{#t} if the given port of file descriptor
 ;;> if backed by a TTY object, and \scheme{#f} otherwise.
 

lib/chibi/highlight.scm

@@ -121,10 +121,6 @@
     (cond
      ((eof-object? c) (reverse-list->string ls))
      ((eqv? c term) (reverse-list->string (cons c ls)))
-     ((eqv? c #\<) (read-escaped in term `(#\; #\t #\l #\& ,@ls)))
-     ;;((eqv? c #\>) (read-escaped in term `(#\; #\t #\g #\& ,@ls)))
-     ((eqv? c #\&) (read-escaped in term `(#\; #\p #\m #\a #\& ,@ls)))
-     ;;((eqv? c #\\) (read-escaped in term (cons (read-char in) (cons c ls))))
      (else (read-escaped in term (cons c ls))))))
 
 (define (read-to-eol in ls)
@@ -134,9 +130,6 @@
      ((eqv? c #\newline) (reverse-list->string (cons c ls)))
      (else (read-to-eol in (cons c ls))))))
 
-(define (html-escape str)
-  (call-with-input-string str (lambda (in) (read-escaped in #f '()))))
-
 (define (collect str res)
   (if (pair? str) (cons (reverse-list->string str) res) res))
 
@@ -162,7 +155,8 @@
              syntax-case parameterize module library require
              require-extension use use-modules import import-immutable
              define-module select-module provide autoload export
-             only except rename prefix include include-shared
+             only except rename prefix drop-prefix alias-for
+             include include-ci include-shared
              condition-case guard protect cond-expand for with to by
              in-list in-lists in-string in-string-reverse
              in-vector in-vector-reverse in-file listing appending

lib/chibi/ieee-754.scm

@@ -0,0 +1,224 @@
+;;; Copyright (c) 2004-2018 by Alex Shinn.
+
+;; Adapted from SRFI 56.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syntax
+
+(define-syntax combine
+  (syntax-rules ()
+    ((combine) 0)
+    ((combine b1) b1)
+    ((combine b1 b2 b3 ...)
+     (combine (+ (arithmetic-shift b1 8) b2) b3 ...))))
+
+(define-syntax bytes-u8-set-all!
+  (syntax-rules ()
+    ((_) bv off i)
+    ((_ bv off i b1) (bytevector-u8-set! bv (+ off i) b1))
+    ((_ bv off i b1 b2 b3 ...)
+     (begin
+       (bytevector-u8-set! bv (+ off i) b1)
+       (bytes-u8-set-all! bv off (+ i 1) b2 b3 ...)))))
+
+(define-syntax bytevector-u8-set-all!
+  (syntax-rules ()
+    ((_ bvapp iapp b1 ...)
+     (let ((bv bvapp)
+           (i iapp))
+       (bytes-u8-set-all! bv i 0 b1 ...)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; reading floating point numbers
+
+;; Inspired by Oleg's implementation from
+;;   http://okmij.org/ftp/Scheme/reading-IEEE-floats.txt
+;; but removes mutations and magic numbers and allows for manually
+;; specifying the endianness.
+;;
+;; See also
+;;   http://www.cs.auckland.ac.nz/~jham1/07.211/floats.html
+;; and
+;;   http://babbage.cs.qc.edu/courses/cs341/IEEE-754references.html
+;; as references to IEEE 754.
+
+(define (bytevector-ieee-single-ref bytevector k endianness)
+  (define (mantissa expn b2 b3 b4)
+    (case expn
+      ((255)     ; special exponents
+       (if (zero? (combine b2 b3 b4)) (/ 1. 0.) (/ 0. 0.)))
+      ((0)       ; denormalized
+       (inexact (* (expt 2.0 (- 1 (+ 127 23))) (combine b2 b3 b4))))
+      (else
+       (inexact
+        (* (expt 2.0 (- expn (+ 127 23)))
+           (combine (+ b2 128) b3 b4)))))) ; hidden bit
+  (define (exponent b1 b2 b3 b4)
+    (if (> b2 127)  ; 1st bit of b2 is low bit of expn
+        (mantissa (+ (* 2 b1) 1) (- b2 128) b3 b4)
+        (mantissa (* 2 b1) b2 b3 b4)))
+  (define (sign b1 b2 b3 b4)
+    (if (> b1 127)  ; 1st bit of b1 is sign
+        (- (exponent (- b1 128) b2 b3 b4))
+        (exponent b1 b2 b3 b4)))
+  (let* ((b1 (bytevector-u8-ref bytevector (+ k 0)))
+         (b2 (bytevector-u8-ref bytevector (+ k 1)))
+         (b3 (bytevector-u8-ref bytevector (+ k 2)))
+         (b4 (bytevector-u8-ref bytevector (+ k 3))))
+    (if (eq? endianness 'big)
+        (sign b1 b2 b3 b4)
+        (sign b4 b3 b2 b1))))
+
+(define (bytevector-ieee-single-native-ref bytevector k)
+  (bytevector-ieee-single-ref bytevector k (native-endianness)))
+
+(define (bytevector-ieee-double-ref bytevector k endianness)
+  (define (mantissa expn b2 b3 b4 b5 b6 b7 b8)
+    (case expn
+      ((255)     ; special exponents
+       (if (zero? (combine b2 b3 b4 b5 b6 b7 b8)) (/ 1. 0.) (/ 0. 0.)))
+      ((0)       ; denormalized
+       (inexact (* (expt 2.0 (- 1 (+ 1023 52)))
+                   (combine b2 b3 b4 b5 b6 b7 b8))))
+      (else
+       (inexact
+        (* (expt 2.0 (- expn (+ 1023 52)))
+           (combine (+ b2 16) b3 b4 b5 b6 b7 b8)))))) ; hidden bit
+  (define (exponent b1 b2 b3 b4 b5 b6 b7 b8)
+    (mantissa (bitwise-ior (arithmetic-shift b1 4)        ; 7 bits
+                           (arithmetic-shift b2 -4))      ; + 4 bits
+              (bitwise-and b2 #b1111)
+              b3 b4 b5 b6 b7 b8))
+  (define (sign b1 b2 b3 b4 b5 b6 b7 b8)
+    (if (> b1 127)  ; 1st bit of b1 is sign
+        (- (exponent (- b1 128) b2 b3 b4 b5 b6 b7 b8))
+        (exponent b1 b2 b3 b4 b5 b6 b7 b8)))
+  (let* ((b1 (bytevector-u8-ref bytevector (+ k 0)))
+         (b2 (bytevector-u8-ref bytevector (+ k 1)))
+         (b3 (bytevector-u8-ref bytevector (+ k 2)))
+         (b4 (bytevector-u8-ref bytevector (+ k 3)))
+         (b5 (bytevector-u8-ref bytevector (+ k 4)))
+         (b6 (bytevector-u8-ref bytevector (+ k 5)))
+         (b7 (bytevector-u8-ref bytevector (+ k 6)))
+         (b8 (bytevector-u8-ref bytevector (+ k 7))))
+    (if (eq? endianness 'big)
+        (sign b1 b2 b3 b4 b5 b6 b7 b8)
+        (sign b8 b7 b6 b5 b4 b3 b2 b1))))
+
+(define (bytevector-ieee-double-native-ref bytevector k)
+  (bytevector-ieee-double-ref bytevector k (native-endianness)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; writing floating point numbers
+
+;; Underflow rounds down to zero as in IEEE-754, and overflow gets
+;; written as +/- Infinity.
+
+;; Break a real number down to a normalized mantissa and exponent.
+;; Default base=2, mant-size=23 (52), exp-size=8 (11) for IEEE singles
+;; (doubles).
+;;
+;; Note: This should never be used in practice, since it can be
+;; implemented much faster in C.  See decode-float in ChezScheme or
+;; Gauche.
+(define (call-with-mantissa&exponent num base mant-size exp-size proc)
+  (cond
+   ((negative? num)
+    (call-with-mantissa&exponent (- num) base mant-size exp-size proc))
+   ((zero? num) (proc 0 0))
+   (else
+    (let* ((bot (expt base mant-size))
+           (top (* base bot)))
+      (let loop ((n (inexact num)) (e 0))
+        (cond
+         ((>= n top)
+          (loop (/ n base) (+ e 1)))
+         ((< n bot)
+          (loop (* n base) (- e 1)))
+         (else
+          (proc (exact (round n)) e))))))))
+
+(define (bytevector-ieee-single-set! bytevector k num endianness)
+  (define output
+    (if (eq? endianness 'big)
+        (lambda (b1 b2 b3 b4) (bytevector-u8-set-all! bytevector k b1 b2 b3 b4))
+        (lambda (b1 b2 b3 b4) (bytevector-u8-set-all! bytevector k b4 b3 b2 b1))))
+  (define (compute)
+    (call-with-mantissa&exponent num 2 23 8
+      (lambda (f e)
+        (let ((e0 (+ e 127 23)))
+          (cond
+           ((negative? e0)
+            (let* ((f1 (exact (round (* f (expt 2 (- e0 1))))))
+                   (b2 (bit-field f1 16 24))        ; mant:16-23
+                   (b3 (bit-field f1 8 16))         ; mant:8-15
+                   (b4 (bit-field f1 0 8)))         ; mant:0-7
+              (output (if (negative? num) 128 0) b2 b3 b4)))
+           ((> e0 255)  ; infinity
+            (output (if (negative? num) 255 127) 128 0 0))
+           (else
+            (let* ((b0 (arithmetic-shift e0 -1))
+                   (b1 (if (negative? num) (+ b0 128) b0)) ; sign + exp:1-7
+                   (b2 (bitwise-ior
+                        (if (odd? e0) 128 0)               ; exp:0
+                        (bit-field f 16 23)))              ;   + mant:16-23
+                   (b3 (bit-field f 8 16))                 ; mant:8-15
+                   (b4 (bit-field f 0 8)))                 ; mant:0-7
+              (output b1 b2 b3 b4))))))))
+  (cond
+   ((zero? num) (output 0 0 0 0))
+   ((nan? num) (output #xff #xff #xff #xff))
+   (else (compute))))
+
+(define (bytevector-ieee-single-native-set! bytevector k num)
+  (bytevector-ieee-single-set! bytevector k num (native-endianness)))
+
+(define (bytevector-ieee-double-set! bytevector k num endianness)
+  (define output
+    (if (eq? endianness 'big)
+        (lambda (b1 b2 b3 b4 b5 b6 b7 b8)
+          (bytevector-u8-set-all! bytevector k b1 b2 b3 b4 b5 b6 b7 b8))
+        (lambda (b1 b2 b3 b4 b5 b6 b7 b8)
+          (bytevector-u8-set-all! bytevector k b8 b7 b6 b5 b4 b3 b2 b1))))
+  (define (compute)
+    (call-with-mantissa&exponent num 2 52 11
+      (lambda (f e)
+        (let ((e0 (+ e 1023 52)))
+          (cond
+           ((negative? e0)
+            (let* ((f1 (exact (round (* f (expt 2 (- e0 1))))))
+                   (b2 (bit-field f1 48 52))
+                   (b3 (bit-field f1 40 48))
+                   (b4 (bit-field f1 32 40))
+                   (b5 (bit-field f1 24 32))
+                   (b6 (bit-field f1 16 24))
+                   (b7 (bit-field f1 8 16))
+                   (b8 (bit-field f1 0 8)))
+              (output (if (negative? num) 128 0) b2 b3 b4 b5 b6 b7 b8)))
+           ((> e0 4095) ; infinity
+            (output (if (negative? num) 255 127) 224 0 0 0 0 0 0))
+           (else
+            (let* ((b0 (bit-field e0 4 11))
+                   (b1 (if (negative? num) (+ b0 128) b0))
+                   (b2 (bitwise-ior (arithmetic-shift
+                                     (bit-field e0 0 4)
+                                     4)
+                                    (bit-field f 48 52)))
+                   (b3 (bit-field f 40 48))
+                   (b4 (bit-field f 32 40))
+                   (b5 (bit-field f 24 32))
+                   (b6 (bit-field f 16 24))
+                   (b7 (bit-field f 8 16))
+                   (b8 (bit-field f 0 8)))
+              (output b1 b2 b3 b4 b5 b6 b7 b8))))))))
+  (cond
+   ((zero? num) (output 0 0 0 0 0 0 0 0))
+   ((nan? num) (output #xff #xff #xff #xff #xff #xff #xff #xff))
+   (else (compute))))
+
+(define (bytevector-ieee-double-native-set! bytevector k num)
+  (bytevector-ieee-double-set! bytevector k num (native-endianness)))
+
+;; Local Variables:
+;; eval: (put 'call-with-mantissa&exponent 'scheme-indent-function 4)
+;; End:

lib/chibi/io-test.sld

@@ -134,6 +134,20 @@
             (read-string 4096 in)
             (read-line in)))
 
+      (let ((bv (string->utf8 "日本語")))
+        (test #\日 (utf8-ref bv 0))
+        (test #\本 (utf8-ref bv 3))
+        (test #\語 (utf8-ref bv 6))
+        (test 3 (utf8-next bv 0 9))
+        (test 6 (utf8-next bv 3 9))
+        (test 9 (utf8-next bv 6 9))
+        (test #f (utf8-next bv 9 9))
+        (test 6 (utf8-prev bv 9 0))
+        (test 3 (utf8-prev bv 6 0))
+        (test 0 (utf8-prev bv 3 0))
+        (test #f (utf8-prev bv 0 0))
+        )
+
       (test #u8(0 1 2)
         (let ((in (bytevectors->input-port (list #u8(0 1 2)))))
           (read-bytevector 3 in)))
@@ -179,7 +193,7 @@
                    (lambda (bv start end)
                      (do ((i start (+ i 1))
                           (x 0 (+ x (bytevector-u8-ref bv i))))
-                         ((= i end) (set! sum x)))))))
+                         ((= i end) (set! sum (+ sum x))))))))
         (write-bytevector #u8(0 1 2 3) out)
         (flush-output out)
         (test 6 sum)
@@ -187,6 +201,19 @@
         (flush-output out)
         (test 106 sum))
 
+      (let* ((ls '())
+             (out (make-custom-output-port
+                   (lambda (str start end)
+                     (set! ls (cons (substring str start end) ls))
+                     (- end start)))))
+        (display "Test1\n" out)
+        (flush-output out)
+        (display "Test2\n" out)
+        (flush-output out)
+        (display "Test3\n" out)
+        (flush-output out)
+        (test "Test1\nTest2\nTest3\n" (string-concatenate (reverse ls))))
+
       (test "file-position"
           '(0 1 2)
         (let* ((p (open-input-file "/etc/passwd"))

lib/chibi/io.sld

@@ -1,6 +1,6 @@
 
 (define-library (chibi io)
-  (export read-string read-string! read-line write-line
+  (export read-string read-string! read-line write-line %%read-line
           port-fold port-fold-right port-map
           port->list port->string-list port->sexp-list
           port->string port->bytevector
@@ -14,7 +14,8 @@
           make-filtered-output-port make-filtered-input-port
           string-count-chars
           open-input-bytevector open-output-bytevector get-output-bytevector
-          string->utf8 utf8->string
+          string->utf8 string->utf8! string-offset utf8->string utf8->string!
+          utf8-ref utf8-next utf8-prev
           write-string write-u8 read-u8 peek-u8 send-file
           is-a-socket?
           call-with-input-file call-with-output-file)

lib/chibi/io/io.scm

@@ -9,25 +9,10 @@
   (call-with-input-string " "
     (lambda (in) (read-char in) (read-char in))))
 
-;; Copy whole characters from the given cursor positions.
-;; Return the src cursor position of the next unwritten char,
-;; which may be before `to' if the char would overflow.
-;; Now provided as a primitive from (chibi ast).
-;; (define (string-cursor-copy! dst start src from to)
-;;   (let lp ((i from)
-;;            (j (string-cursor->index dst start)))
-;;     (let ((i2 (string-cursor-next src i)))
-;;       (cond ((> i2 to) i)
-;;             (else
-;;              (string-set! dst j (string-cursor-ref src i))
-;;              (lp i2 (+ j 1)))))))
-
 (define (utf8->string vec . o)
-  (if (pair? o)
+  (let ((start (if (pair? o) (car o) 0))
-      (let ((start (car o))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (bytevector-length vec))))
-            (end (if (pair? (cdr o)) (cadr o) (bytevector-length vec))))
+    (string-copy (utf8->string! vec start end))))
-        (utf8->string (subbytes vec start end)))
-      (string-copy (utf8->string! vec))))
 
 (define (string->utf8 str . o)
   (if (pair? o)
@@ -75,9 +60,12 @@
 ;;> a string not including the newline.  Reads at most \var{n}
 ;;> characters, defaulting to 8192.
 
-(cond-expand
- ((not string-streams)
 (define (%read-line n in)
+  (cond
+   ((stream-port? in) ;;(port-fileno in)
+    (port-line-set! in (+ 1 (port-line in)))
+    (%%read-line n in))
+   (else
     (let ((out (open-output-string)))
       (let lp ((i 0))
         (let ((ch (peek-char in)))
@@ -103,13 +91,10 @@
   (let ((in (if (pair? o) (car o) (current-input-port)))
         (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192)))
     (let ((res (%read-line n in)))
-      (cond-expand
-       (string-streams
-        (port-line-set! in (+ 1 (port-line in)))))
       (if (not res)
           eof
           (let ((len (string-length res)))
-            (cond
+            (cond  ;; strip crlf
              ((and (> len 0) (eqv? #\newline (string-ref res (- len 1))))
               (if (and (> len 1) (eqv? #\return (string-ref res (- len 2))))
                   (substring res 0 (- len 2))
@@ -128,9 +113,11 @@
 ;;> than \var{n} characters if the end of file is reached,
 ;;> or the eof-object if no characters are available.
 
-(cond-expand
- ((not string-streams)
 (define (%read-string n in)
+  (cond
+   ;;((port-fileno in)
+   ;; (%%read-string n in))
+   (else
     (let ((out (open-output-string)))
       (let lp ((i 0))
         (cond ((or (= i n) (eof-object? (peek-char in)))
@@ -159,9 +146,11 @@
 ;;> An error is signalled if the length of \var{str} is smaller
 ;;> than \var{n}.
 
-(cond-expand
- ((not string-streams)
 (define (%read-string! str n in)
+  (cond
+   ;;((port-fileno in)
+   ;; (%%read-string! str n in))
+   (else
     (let lp ((i 0))
       (cond ((or (= i n) (eof-object? (peek-char in))) i)
             (else (string-set! str i (read-char in)) (lp (+ i 1))))))))

lib/chibi/io/io.stub

@@ -1,15 +1,12 @@
 
-(cond-expand
+(define-c non-null-string (%%read-line "fgets")
- (string-streams
-  (define-c non-null-string (%read-line "fgets")
   ((result (array char arg1)) int (default (current-input-port) input-port)))
 
-  (define-c size_t (%read-string "fread")
+;;(define-c size_t (%%read-string "fread")
-    ((result (array char (result arg2))) (value 1 size_t) size_t (default (current-input-port) input-port)))
+;;  ((result (array char (result arg2))) (value 1 size_t) size_t (default (current-input-port) input-port)))
 
-  (define-c size_t (%read-string! "fread")
+;;(define-c size_t (%%read-string! "fread")
-    (string (value 1 size_t) size_t (default (current-input-port) input-port)))
+;;  (string (value 1 size_t) size_t (default (current-input-port) input-port)))
-  ))
 
 (c-include-verbatim "port.c")
 
@@ -53,8 +50,19 @@
   ((value ctx sexp) (value self sexp) sexp sexp sexp (default NULL sexp)))
 (define-c sexp (%string->utf8 "sexp_string_to_utf8")
   ((value ctx sexp) (value self sexp) sexp))
-(define-c sexp (utf8->string! "sexp_utf8_to_string_x")
+(define-c sexp (string->utf8! "sexp_string_to_utf8_x")
   ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (string-offset "sexp_string_offset_op")
+  ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (utf8->string! "sexp_utf8_to_string_x")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+
+(define-c sexp (utf8-ref "sexp_utf8_ref")
+  ((value ctx sexp) (value self sexp) sexp sexp))
+(define-c sexp (utf8-next "sexp_utf8_next")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+(define-c sexp (utf8-prev "sexp_utf8_prev")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
 
 (define-c sexp (write-u8 "sexp_write_u8")
   ((value ctx sexp) (value self sexp) sexp (default (current-output-port) sexp)))

lib/chibi/io/port.c

@@ -258,15 +258,15 @@ sexp sexp_make_custom_binary_output_port (sexp ctx, sexp self,
   return res;
 }
 
-sexp sexp_bytes_to_string (sexp ctx, sexp vec) {
+sexp sexp_bytes_to_string (sexp ctx, sexp vec, sexp_uint_t offset, sexp_uint_t size) {
   sexp res;
 #if SEXP_USE_PACKED_STRINGS
-  res = sexp_c_string(ctx, sexp_bytes_data(vec), sexp_bytes_length(vec));
+  res = sexp_c_string(ctx, sexp_bytes_data(vec) + offset, size);
 #else
   res = sexp_alloc_type(ctx, string, SEXP_STRING);
   sexp_string_bytes(res) = vec;
-  sexp_string_offset(res) = 0;
+  sexp_string_offset(res) = offset;
-  sexp_string_size(res) = sexp_bytes_length(vec);
+  sexp_string_size(res) = size - offset;
 #endif
   return res;
 }
@@ -275,7 +275,7 @@ sexp sexp_open_input_bytevector (sexp ctx, sexp self, sexp vec) {
   sexp_gc_var2(str, res);
   sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
   sexp_gc_preserve2(ctx, str, res);
-  str = sexp_bytes_to_string(ctx, vec);
+  str = sexp_bytes_to_string(ctx, vec, 0, sexp_bytes_length(vec));
   res = sexp_open_input_string(ctx, str);
   sexp_port_binaryp(res) = 1;
   sexp_gc_release2(ctx);
@@ -341,10 +341,72 @@ sexp sexp_string_to_utf8 (sexp ctx, sexp self, sexp str) {
   return sexp_string_to_bytes(ctx, res);
 }
 
-/* TODO: add validation */
+sexp sexp_string_to_utf8_x (sexp ctx, sexp self, sexp str) {
-sexp sexp_utf8_to_string_x (sexp ctx, sexp self, sexp vec) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+#if SEXP_USE_PACKED_STRINGS
+  return sexp_string_to_utf8(ctx, self, str);
+#else
+  return sexp_string_bytes(str);
+#endif
+}
+
+sexp sexp_string_offset_op (sexp ctx, sexp self, sexp str) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+#if SEXP_USE_PACKED_STRINGS
+  return SEXP_ZERO;
+#else
+  return sexp_make_fixnum(sexp_string_offset(str));
+#endif
+}
+
+sexp sexp_utf8_ref (sexp ctx, sexp self, sexp bv, sexp offset) {
+  sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, bv);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, offset);
+  unsigned char *p=(unsigned char*)sexp_bytes_data(bv) + sexp_unbox_fixnum(offset);
+  if (*p < 0x80)
+    return sexp_make_character(*p);
+  else if ((*p < 0xC0) || (*p > 0xF7))
+    return sexp_user_exception(ctx, NULL, "utf8-ref: invalid utf8 byte", offset);
+  else if (*p < 0xE0)
+    return sexp_make_character(((p[0]&0x3F)<<6) + (p[1]&0x3F));
+  else if (*p < 0xF0)
+    return sexp_make_character(((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F));
+  else
+    return sexp_make_character(((p[0]&0x0F)<<18) + ((p[1]&0x3F)<<12) + ((p[2]&0x3F)<<6) + (p[3]&0x3F));
+}
+
+/* computes length, consider scanning permissively */
+sexp sexp_utf8_next (sexp ctx, sexp self, sexp bv, sexp offset, sexp end) {
+  sexp_sint_t initial, res;
+  sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, bv);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, offset);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end);
+  if (sexp_unbox_fixnum(offset) >= sexp_unbox_fixnum(end)) return SEXP_FALSE;
+  initial = ((unsigned char*)sexp_bytes_data(bv) + sexp_unbox_fixnum(offset))[0];
+  res = sexp_unbox_fixnum(offset) + (initial < 0xC0 ? 1 : initial < 0xE0 ? 2 : 3 + ((initial>>4)&1));
+  return res > sexp_unbox_fixnum(end) ? SEXP_FALSE : sexp_make_fixnum(res);
+}
+
+/* scans backwards permissively */
+sexp sexp_utf8_prev (sexp ctx, sexp self, sexp bv, sexp offset, sexp start) {
+  sexp_sint_t i, limit;
+  sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, bv);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, offset);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
+  unsigned char *p=(unsigned char*)sexp_bytes_data(bv);
+  i = sexp_unbox_fixnum(offset) - 1;
+  limit = sexp_unbox_fixnum(start);
+  while (i >= limit && ((p[i]>>6) == 2))
+    --i;
+  return i < limit ? SEXP_FALSE : sexp_make_fixnum(i);
+}
+
+/* TODO: add optional encoding validation */
+sexp sexp_utf8_to_string_x (sexp ctx, sexp self, sexp vec, sexp offset, sexp size) {
   sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
-  return sexp_bytes_to_string(ctx, vec);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, offset);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, size);
+  return sexp_bytes_to_string(ctx, vec, sexp_unbox_fixnum(offset), sexp_unbox_fixnum(size));
 }
 
 sexp sexp_write_u8 (sexp ctx, sexp self, sexp u8, sexp out) {

lib/chibi/iset-test.sld

@@ -123,6 +123,11 @@
                ((1 2 3 4 1001 1002 1003 1004 2001 2003 2004)
                 (i 1 2 3 4 1001 1004 1005 2000 2001)
                 (= 1 2 3 4 1001 1004 2001))
+               ((0 1 2 3 4 5 6 7 8 9
+                 101 102 103 104 105
+                 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009)
+                (i 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120)
+                (= 101 102 103 104 105))
                ;; difference
                ((1 2 3 4 5) (d 1) (!? 0) (? 2 3 4 5) (!? 6))
                ((1 2 3 4 5) (d 1 2) (!? 0) (? 3 4 5) (!? 6))
@@ -238,4 +243,17 @@
         (test-assert (iset-contains? (iset-union a b) 119))
         (test-assert (iset-contains? (iset-union b a) 119)))
 
+      (let* ((elts '(0 1 5 27 42 113 114 256))
+             (is (list->iset elts)))
+        (test (iota (length elts))
+            (map (lambda (elt) (iset-rank is elt)) elts))
+        (test elts
+            (map (lambda (i) (iset-select is i)) (iota (length elts)))))
+
+      (let* ((elts '(903 595 694 581 91 628 648 152 188 29 347 876 381 945 508 890 816 654 871 228 200 397 116 952 60 878 361 205 691 318 87 998 35 886 580 787 856 535 964 133 245 314 711 598 180 984 458 235 599 692 568 1 740 514 995 930 625 638 881 997 412 151 195 512 857 948 956 750 896 813 988 40 85 426 740 83 294 249 235 45 20 784 837 640 56 519 211 780 771 684 408 510 677 773 574 114 537 934 477 136))
+             (is (list->iset elts)))
+        (test elts
+            (map (lambda (i) (iset-select is i))
+                 (map (lambda (elt) (iset-rank is elt)) elts))))
+
       (test-end))))

lib/chibi/iset.sld

@@ -19,4 +19,5 @@
    iset-difference iset-difference!
    iset-empty? iset-fold iset-fold-node iset-for-each iset-for-each-node
    iset-map iset->list iset-size iset= iset<= iset>=
-   iset-cursor iset-cursor? iset-cursor-next iset-ref end-of-iset?))
+   iset-cursor iset-cursor? iset-cursor-next iset-ref end-of-iset?
+   iset-rank iset-select))

lib/chibi/iset/constructors.scm

@@ -262,11 +262,6 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; High-level set operations.
-;;
-;; Union is optimized to work at the node level.  Intersection and
-;; difference iterate over individual elements and so have a lot of
-;; room for improvement, at the expense of the complexity of
-;; iset-adjoin-node!.
 
 (define (iset-union2! a b)
   (iset-for-each-node
@@ -295,25 +290,23 @@
 
 (define (iset-intersection2! a b)
   (let lp ((nodes-a (iset->node-list a))
-           (nodes-b (iset->node-list b)))
+           (nodes-b (iset->node-list b))
+           (res '()))
     (cond
-     ((null? nodes-a)
+     ((or (null? nodes-a) (null? nodes-b))
-      a)
+      (let ((is (iset)))
-     ((null? nodes-b)
+        (for-each (lambda (x) (iset-adjoin-node! is x)) res)
-      (iset-bits-set! (car nodes-a) 0)
+        is))
-      (iset-right-set! (car nodes-a) #f)
-      a)
      ((> (iset-start (car nodes-b)) (iset-end (car nodes-a)))
-      (iset-bits-set! (car nodes-a) 0)
+      (lp (cdr nodes-a) nodes-b res))
-      (lp (cdr nodes-a) nodes-b))
      ((> (iset-start (car nodes-a)) (iset-end (car nodes-b)))
-      (lp nodes-a (cdr nodes-b)))
+      (lp nodes-a (cdr nodes-b) res))
      (else
       (let* ((a (car nodes-a))
              (b (car nodes-b))
              (a-ls (iset-node-split a (iset-start b) (iset-end b)))
              (overlap (cadr a-ls))
-             (right (car (cddr a-ls)))
+             (a-right (car (cddr a-ls)))
              (b-ls (iset-node-split b (iset-start overlap) (iset-end overlap)))
              (b-overlap (cadr b-ls))
              (b-right (car (cddr b-ls))))
@@ -325,18 +318,16 @@
                   (b-bits (iset-bits b-overlap)))
               (iset-bits-set! a (bitwise-and a-bits b-bits)))
             (iset-bits-set! a (iset-bits overlap)))
-        (if right
+        (lp (if a-right (cons a-right (cdr nodes-a)) (cdr nodes-a))
-            (iset-insert-right! a right))
+            (if b-right (cons b-right (cdr nodes-b)) (cdr nodes-b))
-        (lp (if right (cons right (cdr nodes-a)) (cdr nodes-a))
+            (cons a res)))))))
-            (if b-right (cons b-right (cdr nodes-b)) (cdr nodes-b))))))))
 
 (define (iset-intersection! a . args)
-  (let ((b (and (pair? args) (car args))))
+  (let lp ((a a) (ls args))
-    (cond
+    (if (null? ls)
-     (b
+        a
-      (iset-intersection2! a b)
+        (lp (iset-intersection2! a (car ls))
-      (apply iset-intersection! a (cdr args)))
+            (cdr ls)))))
-     (else a))))
 
 ;;> Returns an iset containing all integers which occur in \var{a} and
 ;;> every of the isets \var{args}.  If no \var{args} are present

lib/chibi/iset/iterators.scm

@@ -95,6 +95,75 @@
          (not (iset-right node))
          (null? (iset-cursor-stack cur)))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Rank/Select operations, acting directly on isets without an
+;; optimized data structure.
+
+(define (iset-node-size iset)
+  (if (iset-bits iset)
+      (bit-count (iset-bits iset))
+      (+ 1 (- (iset-end iset) (iset-start iset)))))
+
+;; Number of bits set in i below index n.
+(define (bit-rank i n)
+  (bit-count (bitwise-and i (- (arithmetic-shift 1 n) 1))))
+
+;;> Returns the rank (i.e. index within the iset) of the given
+;;> element, a number in [0, size).  This can be used to compress an
+;;> integer set to a minimal consecutive set of integets.  Can also be
+;;> thought of as the number of elements in iset smaller than element.
+(define (iset-rank iset element)
+  (let lp ((iset iset) (count 0))
+    (cond
+     ((< element (iset-start iset))
+      (if (iset-left iset)
+          (lp (iset-left iset) count)
+          (error "integer not in iset" iset element)))
+     ((> element (iset-end iset))
+      (if (iset-right iset)
+          (lp (iset-right iset)
+              (+ count
+                 (cond ((iset-left iset) => iset-size) (else 0))
+                 (iset-node-size iset)))
+          (error "integer not in iset" iset element)))
+     ((iset-bits iset)
+      (+ count
+         (cond ((iset-left iset) => iset-size) (else 0))
+         (bit-rank (iset-bits iset)
+                   (- element (iset-start iset)))))
+     (else
+      (+ count
+         (cond ((iset-left iset) => iset-size) (else 0))
+         (integer-length (- element (iset-start iset))))))))
+
+(define (nth-set-bit i n)
+  ;; TODO: optimize
+  (if (zero? n)
+      (first-set-bit i)
+      (nth-set-bit (bitwise-and i (- i 1)) (- n 1))))
+
+;;> Selects the index-th element of iset starting at 0.  The inverse
+;;> operation of \scheme{iset-rank}.
+(define (iset-select iset index)
+  (let lp ((iset iset) (index index) (stack '()))
+    (if (and iset (iset-left iset))
+        (lp (iset-left iset) index (cons iset stack))
+        (let ((iset (if iset iset (car stack)))
+              (stack (if iset stack (cdr stack))))
+          (let ((node-size (iset-node-size iset)))
+            (cond
+             ((and (< index node-size) (iset-bits iset))
+              (+ (iset-start iset)
+                 (nth-set-bit (iset-bits iset) index)))
+             ((< index node-size)
+              (+ (iset-start iset) index))
+             ((iset-right iset)
+              (lp (iset-right iset) (- index node-size) stack))
+             ((pair? stack)
+              (lp #f  (- index node-size) stack))
+             (else
+              (error "iset index out of range" iset index))))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Equality
 
@@ -201,10 +270,6 @@
 
 (define (iset-size iset)
   (iset-fold-node
-   (lambda (is acc)
+   (lambda (is acc) (+ acc (iset-node-size is)))
-     (let ((bits (iset-bits is)))
-       (+ acc (if bits
-                  (bit-count bits)
-                  (+ 1 (- (iset-end is) (iset-start is)))))))
    0
    iset))

lib/chibi/iset/iterators.sld

@@ -12,5 +12,7 @@
   (export
    iset-empty? iset-fold iset-fold-node iset-for-each iset-for-each-node
    iset->list iset-size iset= iset<= iset>=
+   ;; rank/select
+   iset-rank iset-select
    ;; low-level cursors
    iset-cursor iset-cursor? iset-cursor-next iset-ref end-of-iset?))

lib/chibi/iset/optimize.scm

@@ -168,3 +168,23 @@
                     ,(iset-bits iset)
                     ,(iset->code (iset-left iset))
                     ,(iset->code (iset-right iset)))))
+
+;; uses only if, <, <=, >, and SRFI 151 bit-set?
+(define (iset->code/lambda iset)
+  (define (code iset)
+    (and iset
+         (if (and (not (iset-left iset))
+                  (not (iset-right iset))
+                  (not (iset-bits iset)))
+             `(<= ,(iset-start iset) n ,(iset-end iset))
+             `(if (< n ,(iset-start iset))
+               ,(code (iset-left iset))
+               ,(if (and (not (iset-right iset)) (not (iset-bits iset)))
+                    `(<= n ,(iset-end iset))
+                    `(if (> n ,(iset-end iset))
+                         ,(code (iset-right iset))
+                         ,(if (iset-bits iset)
+                              `(bit-set? (- n ,(iset-start iset))
+                                         ,(iset-bits iset))
+                              #t)))))))
+  `(lambda (n) ,(code iset)))

lib/chibi/iset/optimize.sld

@@ -17,4 +17,5 @@
         (bitwise-and (%mask size) (arithmetic-shift n (- position)))))))
   (include "optimize.scm")
   (export
-   iset-balance iset-balance! iset-optimize iset-optimize! iset->code))
+   iset-balance iset-balance! iset-optimize iset-optimize!
+   iset->code iset->code/lambda))

lib/chibi/json-test.sld

@@ -0,0 +1,157 @@
+
+(define-library (chibi json-test)
+  (import (scheme base) (chibi json) (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests)
+      (test-begin "json")
+      (test-begin "string->json")
+      (test 1 (string->json "1"))
+      (test 1.5 (string->json "1.5"))
+      (test 1000.0 (string->json "1e3"))
+      (test 'null (string->json "null"))
+      (test '((null . 3)) (string->json "{\"null\": 3}"))
+      (test "á" (string->json "\"\\u00e1\""))
+      (test "𐐷" (string->json "\"\\uD801\\uDC37\""))
+      (test "😐" (string->json "\"\\uD83D\\uDE10\""))
+      (test '((glossary
+               (title . "example glossary")
+               (GlossDiv
+                (title . "S")
+                (GlossList
+                 (GlossEntry
+                  (ID . "SGML")
+                  (SortAs . "SGML")
+                  (GlossTerm . "Standard Generalized Markup Language")
+                  (Acronym . "SGML")
+                  (Abbrev . "ISO 8879:1986")
+                  (GlossDef
+                   (para . "A meta-markup language, used to create markup languages such as DocBook.")
+                   (GlossSeeAlso . #("GML" "XML")))
+                  (GlossSee . "markup"))))))
+          (string->json "{
+    \"glossary\": {
+        \"title\": \"example glossary\",
+        \"GlossDiv\": {
+            \"title\": \"S\",
+            \"GlossList\": {
+                \"GlossEntry\": {
+                    \"ID\": \"SGML\",
+                    \"SortAs\": \"SGML\",
+                    \"GlossTerm\": \"Standard Generalized Markup Language\",
+                    \"Acronym\": \"SGML\",
+                    \"Abbrev\": \"ISO 8879:1986\",
+                    \"GlossDef\": {
+                        \"para\": \"A meta-markup language, used to create markup languages such as DocBook.\",
+                        \"GlossSeeAlso\": [\"GML\", \"XML\"]
+                    },
+                    \"GlossSee\": \"markup\"
+                }
+            }
+        }
+    }
+}"))
+      (test '((menu
+               (id . "file")
+               (value . "File")
+               (popup
+                (menuitem
+                 . #(((value . "New") (onclick . "CreateNewDoc()"))
+                     ((value . "Open") (onclick . "OpenDoc()"))
+                     ((value . "Close") (onclick . "CloseDoc()")))))))
+          (string->json "{\"menu\": {
+  \"id\": \"file\",
+  \"value\": \"File\",
+  \"popup\": {
+    \"menuitem\": [
+      {\"value\": \"New\", \"onclick\": \"CreateNewDoc()\"},
+      {\"value\": \"Open\", \"onclick\": \"OpenDoc()\"},
+      {\"value\": \"Close\", \"onclick\": \"CloseDoc()\"}
+    ]
+  }
+}}"))
+      (test-end)
+      (test-begin "make-json-reader")
+      (let ()
+        (define-record-type Employee
+          (make-employee name id title department)
+          employee?
+          (name employee-name)
+          (id employee-id)
+          (title employee-title)
+          (department employee-department))
+        (define-record-type Team
+          (make-team name lead devs)
+          team?
+          (name team-name)
+          (lead team-lead)
+          (devs team-devs))
+        (define read-employee (make-json-reader Employee))
+        (define read-team
+          (make-json-reader
+           `(,Team
+             (lead . ,Employee)
+             (name . ,string?)
+             (devs . #(,Employee)))))
+        (define (string->employee str)
+          (read-employee (open-input-string str)))
+        (define (string->team str)
+          (read-team (open-input-string str)))
+        (let ((emp1 (string->employee
+                     "{\"name\": \"Bob\", \"id\": 3, \"title\": \"CEO\"}")))
+          (test-assert (employee? emp1))
+          (test "Bob" (employee-name emp1))
+          (test 3 (employee-id emp1))
+          (test "CEO" (employee-title emp1)))
+        (test-assert (employee? (string->employee "{\"unknown\": \"foo\"}")))
+        (test-error ((make-json-reader Employee #t)
+                     (open-input-string "{\"unknown\": \"foo\"}")))
+        (test-error (string->team "{\"name\": 3}"))
+        (let ((team1 (string->team
+                      "{\"name\": \"Tiger Cats\", \"lead\": {\"name\": \"House\", \"id\": 321}, \"devs\": [{\"name\": \"Cameron\", \"id\": 7}, {\"name\": \"Thirteen\", \"id\": 13}]}")))
+          (test-assert (team? team1))
+          (test-assert (employee? (team-lead team1)))
+          (test "House" (employee-name (team-lead team1)))
+          (test-assert (vector? (team-devs team1)))
+          (test 2 (vector-length (team-devs team1)))
+          (test "Cameron" (employee-name (vector-ref (team-devs team1) 0)))
+          (test "Thirteen" (employee-name (vector-ref (team-devs team1) 1)))))
+      (test-end)
+      (test-begin "json->string")
+      (test "1" (json->string 1))
+      (test "1.5" (json->string 1.5))
+      (test "1000" (json->string 1E3))
+      (test "null" (json->string 'null))
+      (test "{\"null\":3}" (json->string  '((null . 3))))
+      (test  "\"\\u00E1\"" (json->string "á"))
+      (test  "\"\\uD801\\uDC37\"" (json->string "𐐷"))
+      (test  "\"\\uD83D\\uDE10\"" (json->string "😐"))
+      (test "{\"menu\":{\"id\":\"file\",\"value\":\"File\",\"popup\":{\"menuitem\":[{\"value\":\"New\",\"onclick\":\"CreateNewDoc()\"},{\"value\":\"Open\",\"onclick\":\"OpenDoc()\"},{\"value\":\"Close\",\"onclick\":\"CloseDoc()\"}]}}}"
+          (json->string '((menu
+                           (id . "file")
+                           (value . "File")
+                           (popup
+                            (menuitem
+                             . #(((value . "New") (onclick . "CreateNewDoc()"))
+                                 ((value . "Open") (onclick . "OpenDoc()"))
+                                 ((value . "Close") (onclick . "CloseDoc()")))))))))
+      (test "{\"glossary\":{\"title\":\"example glossary\",\"GlossDiv\":{\"title\":\"S\",\"GlossList\":{\"GlossEntry\":{\"ID\":\"SGML\",\"SortAs\":\"SGML\",\"GlossTerm\":\"Standard Generalized Markup Language\",\"Acronym\":\"SGML\",\"Abbrev\":\"ISO 8879:1986\",\"GlossDef\":{\"para\":\"A meta-markup language, used to create markup languages such as DocBook.\",\"GlossSeeAlso\":[\"GML\",\"XML\"]},\"GlossSee\":\"markup\"}}}}}"
+          (json->string '((glossary
+                           (title . "example glossary")
+                           (GlossDiv
+                            (title . "S")
+                            (GlossList
+                             (GlossEntry
+                              (ID . "SGML")
+                              (SortAs . "SGML")
+                              (GlossTerm . "Standard Generalized Markup Language")
+                              (Acronym . "SGML")
+                              (Abbrev . "ISO 8879:1986")
+                              (GlossDef
+                               (para . "A meta-markup language, used to create markup languages such as DocBook.")
+                               (GlossSeeAlso . #("GML" "XML")))
+                              (GlossSee . "markup"))))))))
+      (test-end)
+      (test-end)
+      )))
+

lib/chibi/json.c

@@ -0,0 +1,497 @@
+/*  json.c -- fast json I/O                                  */
+/*  Copyright (c) 2020 Alex Shinn.      All rights reserved. */
+/*  Copyright (c) 2020 Ekaitz Zarraga.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt      */
+
+#include <chibi/eval.h>
+
+static int digit_value (int c) {
+  return (((c)<='9') ? ((c) - '0') : ((sexp_tolower(c) - 'a') + 10));
+}
+
+sexp json_read (sexp ctx, sexp self, sexp in);
+
+sexp sexp_json_read_exception (sexp ctx, sexp self, const char* msg, sexp in, sexp ir) {
+  sexp res;
+  sexp_gc_var4(sym, name, str, irr);
+  sexp_gc_preserve4(ctx, sym, name, str, irr);
+  name = (sexp_port_name(in) ? sexp_port_name(in) : SEXP_FALSE);
+  name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(in)));
+  str = sexp_c_string(ctx, msg, -1);
+  irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir));
+  res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "json-read", -1),
+                            str, irr, SEXP_FALSE, name);
+  sexp_gc_release4(ctx);
+  return res;
+}
+
+sexp sexp_json_write_exception (sexp ctx, sexp self, const char* msg, sexp obj) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  tmp = sexp_list1(ctx, obj);
+  res = sexp_user_exception(ctx, self, msg, tmp);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp json_read_number (sexp ctx, sexp self, sexp in) {
+  double res = 0, scale = 1;
+  int sign = 1, inexactp = 0, scale_sign = 1, ch;
+  ch = sexp_read_char(ctx, in);
+  if (ch == '+') {
+    ch = sexp_read_char(ctx, in);
+  } else if (ch == '-') {
+    ch = sexp_read_char(ctx, in);
+    sign = -1;
+  }
+  for ( ; ch != EOF && isdigit(ch); ch = sexp_read_char(ctx, in))
+    res = res * 10 + ch - '0';
+  if (ch == '.') {
+    inexactp = 1;
+    for (ch = sexp_read_char(ctx, in); isdigit(ch); scale *= 10, ch = sexp_read_char(ctx, in))
+      res = res * 10 + ch - '0';
+    res /= scale;
+  } else if (ch == 'e') {
+    inexactp = 1;
+    ch = sexp_read_char(ctx, in);
+    if (ch == '+') {
+      ch = sexp_read_char(ctx, in);
+    } else if (ch == '-') {
+      ch = sexp_read_char(ctx, in);
+      scale_sign = -1;
+    }
+    for (scale=0; isdigit(ch); ch = sexp_read_char(ctx, in))
+      scale = scale * 10 + ch - '0';
+    res *= pow(10.0, scale_sign * scale);
+  }
+  if (ch != EOF) sexp_push_char(ctx, ch, in);
+  return (inexactp || fabs(res) > (double)SEXP_MAX_FIXNUM) ?
+    sexp_make_flonum(ctx, sign * res) :
+    sexp_make_fixnum(sign * res);  /* always return inexact? */
+}
+
+sexp json_read_literal (sexp ctx, sexp self, sexp in, char* name, sexp value) {
+  int ch;
+  for (++name; *name; )
+    if (*(name++) != (ch = sexp_read_char(ctx, in)))
+      sexp_json_read_exception(ctx, self, "unexpected character in json", in, sexp_make_character(ch));
+  return value;
+}
+
+#define USEQ_LEN 4
+
+long decode_useq(sexp ctx, sexp in) {
+  long result = 0, i, ch;
+  for (i=0; i < USEQ_LEN; i++) {
+    ch = sexp_read_char(ctx, in);
+    if (!isxdigit(ch)) {
+      sexp_push_char(ctx, ch, in);
+      return -1;
+    }
+    result = (result << 4) + digit_value(ch);
+  }
+  return result;
+}
+
+#define INIT_STRING_BUFFER_SIZE 128
+
+sexp json_read_string (sexp ctx, sexp self, sexp in) {
+  sexp_sint_t size=INIT_STRING_BUFFER_SIZE;
+  char initbuf[INIT_STRING_BUFFER_SIZE];
+  char *buf=initbuf, *tmp;
+  int i=0, ch, len;
+  long utfchar, utfchar2;
+  sexp res = SEXP_VOID;
+  for (ch = sexp_read_char(ctx, in); ch != '"'; ch = sexp_read_char(ctx, in)) {
+    if (ch == EOF) {
+      res = sexp_json_read_exception(ctx, self, "unterminated string in json", in, SEXP_NULL);
+      break;
+    }
+    if (i+4 >= size) {       /* expand buffer w/ malloc(), later free() it */
+      tmp = (char*) sexp_malloc(size*2);
+      if (!tmp) {res = sexp_global(ctx, SEXP_G_OOM_ERROR); break;}
+      memcpy(tmp, buf, i);
+      if (size != INIT_STRING_BUFFER_SIZE) free(buf);
+      buf = tmp;
+      size *= 2;
+    }
+    if (ch == '\\') {
+      ch = sexp_read_char(ctx, in);
+      switch (ch) {
+      case 'n':
+        buf[i++] = '\n';
+        break;
+      case 't':
+        buf[i++] = '\t';
+        break;
+      case 'u':
+        utfchar = decode_useq(ctx, in);
+        if (0xd800 <= utfchar && utfchar <= 0xdbff) {
+          ch = sexp_read_char(ctx, in);
+          if (ch == '\\') {
+            ch = sexp_read_char(ctx, in);
+            if (ch == 'u') {
+              /* high surrogate followed by another unicode escape */
+              utfchar2 = decode_useq(ctx, in);
+              if (0xdc00 <= utfchar2 && utfchar2 <= 0xdfff) {
+                /* merge low surrogate (otherwise high is left unpaired) */
+                utfchar = 0x10000 + (((utfchar - 0xd800) << 10) | (utfchar2 - 0xdc00));
+              } else {
+                return sexp_json_read_exception(ctx, self, "invalid \\u sequence", in, SEXP_NULL);
+              }
+            } else {
+              sexp_push_char(ctx, ch, in);
+              sexp_push_char(ctx, '\\', in);
+            }
+          } else {
+            sexp_push_char(ctx, ch, in);
+          }
+        }
+        if (utfchar < 0) {
+          return sexp_json_read_exception(ctx, self, "invalid \\u sequence", in, SEXP_NULL);
+        } else {
+          len = sexp_utf8_char_byte_count(utfchar);
+          sexp_utf8_encode_char((unsigned char*)buf + i, len, utfchar);
+          i += len;
+        }
+        break;
+      default:
+        buf[i++] = ch;
+        break;
+      }
+    } else {
+      buf[i++] = ch;
+    }
+  }
+  if (!sexp_exceptionp(res)) {
+    buf[i] = '\0';
+    res = sexp_c_string(ctx, buf, i);
+    if (sexp_stringp(res)) sexp_immutablep(res) = 1;
+  }
+  if (size != INIT_STRING_BUFFER_SIZE) free(buf);
+  return res;
+}
+
+sexp json_read_array (sexp ctx, sexp self, sexp in) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  int comma = 1, ch;
+  res = SEXP_NULL;
+  while (1) {
+    ch = sexp_read_char(ctx, in);
+    if (ch == EOF) {
+      res = sexp_json_read_exception(ctx, self, "unterminated array in json", in, SEXP_NULL);
+      break;
+    } else if (ch == ']') {
+      if (comma && res != SEXP_NULL) {
+        res = sexp_json_read_exception(ctx, self, "missing value after comma in json", in, SEXP_NULL);
+      } else {
+        res = sexp_nreverse(ctx, res);
+        res = sexp_list_to_vector(ctx, res);
+      }
+      break;
+    } else if (ch == ',' && comma) {
+      res = sexp_json_read_exception(ctx, self, "unexpected comma in json array", in, SEXP_NULL);
+      break;
+    } else if (ch == ',') {
+      comma = 1;
+    } else if (!isspace(ch)) {
+      if (comma) {
+        sexp_push_char(ctx, ch, in);
+        tmp = json_read(ctx, self, in);
+        if (sexp_exceptionp(tmp)) {
+          res = tmp;
+          break;
+        }
+        res = sexp_cons(ctx, tmp, res);
+        comma = 0;
+      } else {
+        res = sexp_json_read_exception(ctx, self, "unexpected value in json array", in, SEXP_NULL);
+        break;
+      }
+    }
+  }
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp json_read_object (sexp ctx, sexp self, sexp in) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  int comma = 1, ch;
+  res = SEXP_NULL;
+  while (1) {
+    ch = sexp_read_char(ctx, in);
+    if (ch == EOF) {
+      res = sexp_json_read_exception(ctx, self, "unterminated object in json", in, SEXP_NULL);
+      break;
+    } else if (ch == '}') {
+      if (comma && res != SEXP_NULL) {
+        res = sexp_json_read_exception(ctx, self, "missing value after comma in json object", in, SEXP_NULL);
+      } else {
+        res = sexp_nreverse(ctx, res);
+      }
+      break;
+    } else if (ch == ',' && comma) {
+      res = sexp_json_read_exception(ctx, self, "unexpected comma in json object", in, SEXP_NULL);
+      break;
+    } else if (ch == ',') {
+      comma = 1;
+    } else if (!isspace(ch)) {
+      if (comma) {
+        sexp_push_char(ctx, ch, in);
+        tmp = json_read(ctx, self, in);
+        if (sexp_exceptionp(tmp)) {
+          res = tmp;
+          break;
+        } else if (sexp_stringp(tmp)) {
+          tmp = sexp_string_to_symbol(ctx, tmp);
+        }
+        tmp = sexp_cons(ctx, tmp, SEXP_VOID);
+        for (ch = sexp_read_char(ctx, in); isspace(ch); ch = sexp_read_char(ctx, in))
+          ;
+        if (ch != ':') {
+          res = sexp_json_read_exception(ctx, self, "missing colon in json object", in, sexp_make_character(ch));
+          break;
+        }
+        sexp_cdr(tmp) = json_read(ctx, self, in);
+        if (sexp_exceptionp(sexp_cdr(tmp))) {
+          res = sexp_cdr(tmp);
+          break;
+        }
+        res = sexp_cons(ctx, tmp, res);
+        comma = 0;
+      } else {
+        res = sexp_json_read_exception(ctx, self, "unexpected value in json object", in, SEXP_NULL);
+        break;
+      }
+    }
+  }
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp json_read (sexp ctx, sexp self, sexp in) {
+  sexp res;
+  int ch = ' ';
+  while (isspace(ch))
+    ch = sexp_read_char(ctx, in);
+  switch (ch) {
+  case '{':
+    res = json_read_object(ctx, self, in);
+    break;
+  case '[':
+    res = json_read_array(ctx, self, in);
+    break;
+  case '"':
+    res = json_read_string(ctx, self, in);
+    break;
+  case '-': case '+':
+  case '0': case '1': case '2': case '3': case '4':
+  case '5': case '6': case '7': case '8': case '9':
+    sexp_push_char(ctx, ch, in);
+    res = json_read_number(ctx, self, in);
+    break;
+  case 'n': case 'N':
+    res = json_read_literal(ctx, self, in, "null", sexp_intern(ctx, "null", -1));
+    break;
+  case 't': case 'T':
+    res = json_read_literal(ctx, self, in, "true", SEXP_TRUE);
+    break;
+  case 'f': case 'F':
+    res = json_read_literal(ctx, self, in, "false", SEXP_FALSE);
+    break;
+  case '}':
+    res = sexp_json_read_exception(ctx, self, "unexpected closing brace in json", in, SEXP_NULL);
+    break;
+  case ']':
+    res = sexp_json_read_exception(ctx, self, "unexpected closing bracket in json", in, SEXP_NULL);
+    break;
+  default:
+    res = sexp_json_read_exception(ctx, self, "unexpected character in json", in, sexp_make_character(ch));
+    break;
+  }
+  return res;
+}
+
+sexp sexp_json_read (sexp ctx, sexp self, sexp_sint_t n, sexp in) {
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
+  return json_read(ctx, self, in);
+}
+
+
+sexp json_write (sexp ctx, sexp self, sexp obj, sexp out);
+
+#define FLONUM_SIGNIFICANT_DIGITS 10
+#define FLONUM_EXP_MAX_DIGITS 3
+sexp json_write_flonum(sexp ctx, sexp self, const sexp obj, sexp out) {
+  if (sexp_infp(obj) || sexp_nanp(obj)) {
+    return sexp_json_write_exception(ctx, self, "unable to encode number", obj);
+  }
+  /* Extra space for signs (x2), dot, E and \0 */
+  char cout[FLONUM_SIGNIFICANT_DIGITS + FLONUM_EXP_MAX_DIGITS + 5];
+  snprintf(cout, sizeof(cout), "%.*G", FLONUM_SIGNIFICANT_DIGITS, sexp_flonum_value(obj));
+  sexp_write_string(ctx, cout, out);
+  return SEXP_VOID;
+}
+
+
+sexp json_write_string(sexp ctx, sexp self, const sexp obj, sexp out) {
+  char cout[32];  /* oversized to avoid snprintf warnings */
+  unsigned long ch, chh, chl;
+  sexp i, end = sexp_make_string_cursor(sexp_string_size(obj));
+
+  sexp_write_char(ctx, '"', out);
+  for (i = sexp_make_string_cursor(0); i < end;
+       i = sexp_string_cursor_next(obj, i)) {
+    ch = sexp_unbox_character(sexp_string_cursor_ref(ctx, obj, i));
+    if (ch < 0x7F) {
+      switch (ch) {
+        case '\\':
+          sexp_write_string(ctx, "\\\\", out);
+          break;
+        case '\b':
+          sexp_write_string(ctx, "\\b", out);
+          break;
+        case '\f':
+          sexp_write_string(ctx, "\\f", out);
+          break;
+        case '\n':
+          sexp_write_string(ctx, "\\n", out);
+          break;
+        case '\r':
+          sexp_write_string(ctx, "\\r", out);
+          break;
+        case '\t':
+          sexp_write_string(ctx, "\\t", out);
+          break;
+        default:
+          sexp_write_char(ctx, ch, out);
+          break;
+      }
+    } else if (ch <= 0xFFFF) {
+      snprintf(cout, sizeof(cout), "\\u%04lX", ch);
+      sexp_write_string(ctx, cout, out);
+    } else {
+      // Surrogate pair
+      chh = (0xD800 - (0x10000 >> 10) + ((ch) >> 10));
+      chl = (0xDC00 + ((ch) & 0x3FF));
+      if (chh > 0xFFFF || chl > 0xFFFF) {
+        return sexp_json_write_exception(ctx, self, "unable to encode string", obj);
+      }
+      snprintf(cout, sizeof(cout), "\\u%04lX\\u%04lX", chh, chl);
+      sexp_write_string(ctx, cout, out);
+    }
+  }
+  sexp_write_char(ctx, '"', out);
+
+  return SEXP_VOID;
+}
+
+sexp json_write_array(sexp ctx, sexp self, const sexp obj, sexp out) {
+  sexp tmp;
+  int len = sexp_vector_length(obj), i;
+  sexp_write_string(ctx, "[", out);
+  for (i = 0; i < len; ++i) {
+    tmp = json_write(ctx, self, sexp_vector_ref(obj, sexp_make_fixnum(i)), out);
+    if (sexp_exceptionp(tmp)) {
+      return tmp;
+    }
+    if (i < len - 1) {
+      sexp_write_char(ctx, ',', out);
+    }
+  }
+  sexp_write_string(ctx, "]", out);
+  return SEXP_VOID;
+}
+
+sexp json_write_object(sexp ctx, sexp self, const sexp obj, sexp out) {
+  sexp ls, cur, key, val;
+  sexp_gc_var2(tmp, res);
+  if (sexp_length(ctx, obj) == SEXP_FALSE)
+     sexp_json_write_exception(ctx, self, "unable to encode circular list", obj);
+  sexp_gc_preserve2(ctx, tmp, res);
+  res = SEXP_VOID;
+  sexp_write_char(ctx, '{', out);
+  for (ls = obj; sexp_pairp(ls); ls = sexp_cdr(ls)) {
+    if (ls != obj)
+      sexp_write_char(ctx, ',', out);
+    cur = sexp_car(ls);
+    if (!sexp_pairp(cur)) {
+      res = sexp_json_write_exception(ctx, self, "unable to encode key-value pair: not a pair", obj);
+      break;
+    }
+    key = sexp_car(cur);
+    if (!sexp_symbolp(key)) {
+      res = sexp_json_write_exception(ctx, self, "unable to encode key: not a symbol", key);
+      break;
+    }
+    tmp = sexp_symbol_to_string(ctx, key);
+    tmp = json_write(ctx, self, tmp, out);
+    if (sexp_exceptionp(tmp)) {
+      res = tmp;
+      break;
+    }
+    sexp_write_char(ctx, ':', out);
+    val = sexp_cdr(cur);
+    tmp = json_write(ctx, self, val, out);
+    if (sexp_exceptionp(tmp)) {
+      res = tmp;
+      break;
+    }
+  }
+  sexp_write_char(ctx, '}', out);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp json_write (sexp ctx, sexp self, const sexp obj, sexp out) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = SEXP_VOID;
+  if (sexp_symbolp(obj)) {
+    res = sexp_write(ctx, obj, out);
+  } else if (sexp_stringp(obj)) {
+    res = json_write_string(ctx, self, obj, out);
+  } else if (sexp_listp(ctx, obj) == SEXP_TRUE) {
+    res = json_write_object(ctx, self, obj, out);
+  } else if (sexp_vectorp(obj)) {
+    res = json_write_array(ctx, self, obj, out);
+  } else if (sexp_fixnump(obj)) {
+    res = sexp_write(ctx, obj, out);
+  } else if (sexp_flonump(obj)) {
+    res = json_write_flonum(ctx, self, obj, out);
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(obj)) {
+    res = sexp_make_flonum(ctx, sexp_bignum_to_double(obj));
+    res = json_write_flonum(ctx, self, res, out);
+#endif
+  } else if (obj == SEXP_FALSE) {
+    sexp_write_string(ctx, "false", out);
+  } else if (obj == SEXP_TRUE) {
+    sexp_write_string(ctx, "true", out);
+  } else if (obj == SEXP_NULL) {
+    sexp_write_string(ctx, "null", out);
+  } else if (sexp_pairp(obj)) {
+    res = sexp_json_write_exception(ctx, self, "unable to encode elemente: key-value pair out of object", obj);
+  } else {
+    res = sexp_json_write_exception(ctx, self, "unable to encode element", obj);
+  }
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_json_write (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out) {
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
+  return json_write(ctx, self, obj, out);
+}
+
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_foreign(ctx, env, "json-read", 1, sexp_json_read);
+  sexp_define_foreign(ctx, env, "json-write", 2, sexp_json_write);
+  return SEXP_VOID;
+}

lib/chibi/json.scm

@@ -0,0 +1,149 @@
+
+;;> A library for reading and writing data in JSON format (RFC 8259).
+
+;;> \procedure{(json-read [in])}
+;;> Reads a JSON expression from port \var{in}.  Objects are
+;;> represented as alists with symbol keys, arrays as Scheme vectors,
+;;> null as the symbol \scheme{'null}, and strings, numbers and
+;;> booleans as the corresponding Scheme types.
+
+;;> \procedure{(string->json str)}
+;;> Returns the JSON representation of \var{str} as from \scheme{json-read}.
+;;>
+;;> \example{
+;;>   (string->json "{\\"mean\\": 2.2, \\"quartiles\\": [1, 2, 3, 4]}")
+;;> }
+(define (string->json str)
+  (let* ((in (open-input-string str))
+         (res (json-read in)))
+    (close-input-port in)
+    res))
+
+;;> \procedure{(json-write json [out])}
+;;> Writes a JSON representation of \var{obj} to port \var{out}, where
+;;> \var{obj} should follow the same mappings as in \var{json-read}.
+
+;;> \procedure{(json->string json)}
+;;> Returns the string representation of \var{json} as from \scheme{json-write}.
+(define (json->string json)
+  (let ((out (open-output-string)))
+    (json-write json out)
+    (get-output-string out)))
+
+(define (json-field-mapper rtd name spec strict?)
+  (if (symbol? spec)
+      (rtd-mutator rtd spec)
+      (let ((setter (rtd-mutator rtd name))
+            (mapper (make-json-mapper spec strict?)))
+        (lambda (rec val)
+          (setter rec (mapper val))))))
+
+(define (make-json-mapper spec . o)
+  (let ((strict? (and (pair? o) (car o))))
+    (cond
+     ((vector? spec)
+      (if (= 1 (vector-length spec))
+          (let ((elt-spec (make-json-mapper (vector-ref spec 0) strict?)))
+            (lambda (x)
+              (if (vector? x)
+                  (vector-map elt-spec x)
+                  (error "expected json array" x))))
+          (lambda (x)
+            (if (vector? x) x (error "expected json array" x)))))
+     ((procedure? spec)
+      (lambda (x)
+        (if (spec x) x (error "json check failed" spec x))))
+     ((rtd? spec)
+      (make-json-mapper
+       (cons spec (map (lambda (f) (cons f f))
+                       (vector->list (rtd-all-field-names spec))))
+       strict?))
+     ((pair? spec)
+      (if (rtd? (car spec))
+          (let* ((rtd (car spec))
+                 (make (make-constructor (type-name rtd) rtd))
+                 (fields
+                  (map (lambda (f)
+                         (cons (car f)
+                               (json-field-mapper rtd (car f) (cdr f) strict?)))
+                       (cdr spec))))
+            (lambda (x)
+              (if (not (or (pair? x) (null? x)))
+                  (error "expected json object" x)
+                  (let ((res (make)))
+                    (for-each
+                     (lambda (y)
+                       (cond
+                        ((and (pair? y) (assq (car y) fields))
+                         => (lambda (f) ((cdr f) res (cdr y))))
+                        (strict?
+                         (error "unknown field" (if (pair? y) (car y) y)))
+                        (else
+                         )))
+                     x)
+                    res))))
+          (error "expected rtd in object spec" spec)))
+     (else
+      (error "unknown json reader spec" spec)))))
+
+;;> Returns a procedure of one argument, an input port, which reads a
+;;> JSON object according to the specification \var{spec}, which can
+;;> be one of:
+;;>
+;;> \itemlist[
+;;>   \item{a record type: reads a json object with field names
+;;>     corresponding to the record names}
+;;>   \item{a predicate: reads an arbitrary json object, and returns
+;;>     that object if the predicate succeeds, or an error otherwise}
+;;>   \item{a vector of one element: reads a json array of objects as
+;;>     described by the vector element}
+;;>   \item{a list: the car should be a record type, and the cdr
+;;>     an alist of (field-name . spec).  The spec can be a symbol,
+;;>     in which case it is the record field name (allowing aliasing),
+;;>     otherwise it is a normal spec to read and set the corresponding
+;;>     field}
+;;> ]
+;;>
+;;> If \var{strict?} is specified and true, raises an error if any
+;;> unknown field names are specified in an object.
+;;>
+;;> Examples:
+;;>
+;;> \example{
+;;> (begin
+;;>  (define-record-type Employee
+;;>    (make-employee name id title department)
+;;>    employee?
+;;>    (name employee-name)
+;;>    (id employee-id)
+;;>    (title employee-title)
+;;>    (department employee-department))
+;;>  (define-record-type Team
+;;>    (make-team name lead devs)
+;;>    team?
+;;>    (name team-name)
+;;>    (lead team-lead)
+;;>    (devs team-devs))
+;;>  (define read-team
+;;>    (make-json-reader
+;;>     `(,Team
+;;>       (lead . ,Employee)
+;;>       (name . ,string?)
+;;>       (devs . #(,Employee)))))
+;;>  (define team
+;;>   (read-team
+;;>    (open-input-string
+;;>     "{\\"name\\": \\"A-Team\\",
+;;>       \\"lead\\": {\\"name\\": \\"Hannibal\\", \\"id\\": 321},
+;;>       \\"devs\\": [{\\"name\\": \\"B.A.\\", \\"id\\": 7},
+;;>                  {\\"name\\": \\"Murdock\\", \\"id\\": 13}]}")))
+;;>  (cons (team-name team)
+;;>        (map employee-name
+;;>             (cons (team-lead team) (vector->list (team-devs team))))))
+;;> }
+(define (make-json-reader spec . o)
+  (let* ((strict? (and (pair? o) (car o)))
+         (proc (make-json-mapper spec strict?)))
+    ;; TODO: update this to read directly without the intermediate
+    ;; representation
+    (lambda (in) (proc (json-read in)))))

lib/chibi/json.sld

@@ -0,0 +1,10 @@
+
+(define-library (chibi json)
+  (import (scheme base)
+          (except (srfi 99 records) define-record-type)
+          (only (chibi ast) type-name)
+          (only (chibi) make-constructor))
+  (export string->json json->string json-read json-write
+          make-json-reader)
+  (include-shared "json")
+  (include "json.scm"))

lib/chibi/log-test.sld

@@ -16,22 +16,23 @@
       (syntax-rules ()
         ((log->string/no-dates expr ...)
          (string-join
-          (map (lambda (line) (substring line 20))
+          (map (lambda (line)
+                 (if (string-null? line) line (substring line 20)))
                (string-split (log->string expr ...) "\n"))
           "\n"))))
     (define (run-tests)
-      (test-begin "(chibi log)")
+      (test-begin "logging")
-      (test "D four: 4"
+      (test "D four: 4\n"
           (log->string/no-dates
            (log-debug "four: " (+ 2 2))))
-      (test "I pi: 3.14"
+      (test "I pi: 3.14\n"
           (log->string/no-dates
            (log-info "pi: " (with ((precision 2)) (acos -1)))))
       (test-assert
         (string-prefix? "E "
                         (log->string/no-dates
                          (with-logged-errors (/ 1 0)))))
-      (test "W warn\nE error"
+      (test "W warn\nE error\n"
           (log->string/no-dates
            (with-log-level
             'warn