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

@@ -0,0 +1,86 @@
+# Object files
+*.o
+*.bc
+*.ko
+*.obj
+*.elf
+
+# Precompiled Headers
+*.gch
+*.pch
+
+# Libraries
+*.lib
+*.a
+*.la
+*.lo
+
+# Shared objects (inc. Windows DLLs)
+*.dll
+*.dll.*
+*.so
+*.so.*
+*.dylib
+
+# Executables
+*.exe
+*.out
+*.app
+*.i*86
+*.x86_64
+*.hex
+
+# Debug files
+*.dSYM/
+
+# Snow Meta files
+lib/.*.meta
+
+# Generated files
+chibi-scheme
+chibi-scheme-emscripten
+chibi-scheme.pc
+include/chibi/install.h
+lib/chibi/emscripten.c
+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
+tests/snow/repo*/repo.scm
+tests/snow/tmp-root
+tmp
+/lib/chibi/crypto/crypto.c
+/chibi-scheme-ulimit
+/clibs.c
+
+js/chibi.*
+
+build-lib/chibi/char-set/derived.scm
+build-lib/chibi/char-set/width.scm

.hgignore

@@ -4,6 +4,8 @@ syntax: glob
 *.s
 *.o
 *.so
+*.so.*
+*.pc
 *.sch
 *.sps
 *.txt
@@ -35,6 +37,9 @@ lib/chibi/process.c
 lib/chibi/system.c
 lib/chibi/time.c
 lib/chibi/stty.c
+lib/chibi/emscripten.c
 doc/*.html
 doc/lib/chibi/*.html
 misc/*
+tests/ffi/*.c
+tests/ffi/*.stub

.travis.yml

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

AUTHORS

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

CMakeLists.txt

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

CONTRIBUTING.md

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

COPYING

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

Makefile

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

Makefile.detect

@@ -9,6 +9,7 @@ PLATFORM=macosx
 else
 ifeq ($(shell uname),FreeBSD)
 PLATFORM=bsd
+LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
 else
 ifeq ($(shell uname),NetBSD)
 PLATFORM=bsd
@@ -20,7 +21,7 @@ ifeq ($(shell uname),DragonFly)
 PLATFORM=bsd
 else
 ifeq ($(shell uname -o),Msys)
-PLATFORM=mingw
+PLATFORM=windows
 SOLIBDIR = $(BINDIR)
 DIFFOPTS = -b
 else
@@ -29,9 +30,15 @@ PLATFORM=cygwin
 SOLIBDIR = $(BINDIR)
 DIFFOPTS = -b
 else
+ifeq ($(shell uname -o),Android)
+PLATFORM=android
+else
 ifeq ($(shell uname -o),GNU/Linux)
 PLATFORM=linux
 else
+ifeq ($(shell uname),SunOS)
+PLATFORM=solaris
+else
 PLATFORM=unix
 endif
 endif
@@ -41,49 +48,86 @@ endif
 endif
 endif
 endif
+endif
+endif
+endif
+
+ifndef ARCH
+ARCH = $(shell uname -m)
+endif
 
 ########################################################################
 # Set default variables for the platform.
 
 LIBDL = -ldl
+SO_VERSIONED_SUFFIX = $(SO).$(SOVERSION)
+SO_MAJOR_VERSIONED_SUFFIX = $(SO).$(SOVERSION_MAJOR)
+STATIC_LDFLAGS = -lm -ldl -lutil
 
 ifeq ($(PLATFORM),macosx)
 SO  = .dylib
+SO_VERSIONED_SUFFIX = .$(SOVERSION)$(SO)
+SO_MAJOR_VERSIONED_SUFFIX = .$(SOVERSION_MAJOR)$(SO)
 EXE =
-CLIBFLAGS = -dynamiclib
-STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0
+CLIBFLAGS =
+CLINKFLAGS = -dynamiclib
+STATICFLAGS = -DSEXP_USE_DL=0  # -static-libgcc
+LIBCHIBI_FLAGS = -install_name $(DESTDIR)$(SOLIBDIR)/libchibi-scheme.$(SOVERSION).dylib
 else
 ifeq ($(PLATFORM),bsd)
 SO  = .so
 EXE =
-CLIBFLAGS = -fPIC -shared
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
 LIBDL = 
+RLDFLAGS=-Wl,-R$(LIBDIR)
 else
-ifeq ($(PLATFORM),mingw)
+ifeq ($(PLATFORM),solaris)
+SO = .so
+EXE =
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
+LIBDL = -ldl
+RLDFLAGS=-Wl,-R$(LIBDIR)
+else
+ifeq ($(PLATFORM),windows)
+SO  = .dll
+EXE = .exe
+CC ?= gcc
+CLIBFLAGS =
+CLINKFLAGS = -shared
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DSEXP_USE_GREEN_THREADS=0 -DSEXP_USE_GC_FILE_DESCRIPTORS=0 -DBUILDING_DLL
+LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATICFLAGS =
+STATIC_LDFLAGS = -lm -ldl
+LIBDL = -lws2_32
+else
+ifeq ($(PLATFORM),msys)
 SO  = .dll
 EXE = .exe
 CC = gcc
-CLIBFLAGS = -shared
-CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
-LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
-STATICFLAGS = -DSEXP_USE_DL=0
-LIBDL = 
+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
 EXE = .exe
 CC = gcc
-CLIBFLAGS = -shared
+CLIBFLAGS =
+CLINKFLAGS = -shared
 CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
-LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
+LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATIC_LDFLAGS = -lm -ldl
 else
 SO  = .so
 EXE =
-CLIBFLAGS = -fPIC -shared
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
 STATICFLAGS = -static -DSEXP_USE_DL=0
-ifeq ($(PLATFORM),BSD)
-LIBDL=
-RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
+LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
 endif
 endif
 endif
@@ -91,18 +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
 
 ########################################################################
-# Check for NTP (who needs autoconf?)
+# 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.
 
-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)
+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 "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 "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)
+XCPPFLAGS += -DSEXP_USE_INTTYPES
 endif

Makefile.libs

@@ -9,33 +9,56 @@
 # install configuration
 
 CC        ?= cc
+AR        ?= ar
 CD        ?= cd
 RM        ?= rm -f
 LS        ?= ls
+CP        ?= cp
+LN        ?= ln -sf
 INSTALL   ?= install
+INSTALL_EXE	?=	$(INSTALL)
 MKDIR     ?= $(INSTALL) -d
 RMDIR     ?= rmdir
 TAR       ?= tar
 DIFF      ?= diff
+GIT       ?= git
 GREP      ?= grep
 FIND      ?= find
 SYMLINK   ?= ln -s
+LDCONFIG  ?= ldconfig
 
-PREFIX    ?= /usr/local
-BINDIR    ?= $(PREFIX)/bin
-LIBDIR    ?= $(PREFIX)/lib
-SOLIBDIR  ?= $(PREFIX)/lib
-INCDIR    ?= $(PREFIX)/include/chibi
-MODDIR    ?= $(PREFIX)/share/chibi
-BINMODDIR ?= $(PREFIX)/lib/chibi
-MANDIR    ?= $(PREFIX)/share/man/man1
+# gnu coding standards
+prefix      ?= /usr/local
+PREFIX      ?= $(prefix)
+exec_prefix ?= $(PREFIX)
+bindir      ?= $(exec_prefix)/bin
+libdir      ?= $(exec_prefix)/lib
+includedir  ?= $(PREFIX)/include
+datarootdir ?= $(PREFIX)/share
+datadir     ?= $(datarootdir)
+mandir      ?= $(datarootdir)/man
+man1dir     ?= $(mandir)/man1
 
+# hysterical raisins
+BINDIR      ?= $(bindir)
+LIBDIR      ?= $(libdir)
+SOLIBDIR    ?= $(libdir)
+INCDIR      ?= $(includedir)/chibi
+MODDIR      ?= $(datadir)/chibi
+BINMODDIR   ?= $(SOLIBDIR)/chibi
+PKGCONFDIR  ?= $(SOLIBDIR)/pkgconfig
+MANDIR      ?= $(man1dir)
+
+# allow snow to be configured separately
+SNOWPREFIX    ?= /usr/local
+SNOWLIBDIR    ?= $(SNOWPREFIX)/lib
+SNOWSOLIBDIR  ?= $(SNOWLIBDIR)
+SNOWMODDIR    ?= $(SNOWPREFIX)/share/snow
+SNOWBINMODDIR ?= $(SNOWSOLIBDIR)/snow
+
+# for packaging tools
 DESTDIR       ?=
 
-CHIBI     ?= chibi-scheme$(EXE)
-CHIBI_FFI ?= chibi-ffi
-CHIBI_DOC ?= chibi-doc
-
 ########################################################################
 # System configuration - if not using GNU make, set PLATFORM and the
 # flags from Makefile.detect (at least SO, EXE, CLIBFLAGS) as necessary.
@@ -44,19 +67,22 @@ 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/%$(SO): lib/%.c $(INCLUDES)
-	$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme
+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. $(RLDFLAGS) $(XLIBS) -lchibi-scheme
 
 doc-libs: $(HTML_LIBS)
 
-doc/lib/%.html: lib/%.sld
+doc/lib/%.html: lib/%.sld $(CHIBI_DOC_DEPENDENCIES)
 	$(MKDIR) $(dir $@)
-	$(CHIBI_DOC) $(subst /,.,$*) > $@
+	$(CHIBI_DOC) --html $(subst /,.,$*) > $@
 
 clean-libs:
 	$(RM) $(COMPILED_LIBS)

README

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

README-win32.md

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

README.md

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

RELEASE

@@ -1 +1 @@
-carbon
+sodium

TODO

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

VERSION

@@ -1 +1 @@
-0.6.1
+0.11.0

appveyor.yml

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

benchmarks/gabriel/chibi-prelude.scm

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

benchmarks/gabriel/difftimes.sh

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

benchmarks/gabriel/input.txt

@@ -0,0 +1 @@
+1

benchmarks/gabriel/ray.scm

@@ -0,0 +1,201 @@
+;;; RAY -- Ray-trace a simple scene with spheres, generating a ".pgm" file.
+;;; Translated to Scheme from Paul Graham's book ANSI Common Lisp, Example 9.8
+
+(import (scheme base)
+        (scheme inexact)
+        (scheme file)
+        (scheme read)
+        (scheme write)
+        (scheme time))
+
+(define (make-point x y z)
+  (vector x y z))
+
+(define (point-x p) (vector-ref p 0))
+(define (point-y p) (vector-ref p 1))
+(define (point-z p) (vector-ref p 2))
+
+(define (sq x) (* x x))
+
+(define (mag x y z)
+  (sqrt (+ (sq x) (sq y) (sq z))))
+
+(define (unit-vector x y z)
+  (let ((d (mag x y z)))
+    (make-point (/ x d) (/ y d) (/ z d))))
+
+(define (distance p1 p2)
+  (mag (- (point-x p1) (point-x p2))
+       (- (point-y p1) (point-y p2))
+       (- (point-z p1) (point-z p2))))
+
+(define (minroot a b c)
+  (if (zero? a)
+      (/ (- c) b)
+      (let ((disc (- (sq b) (* 4.0 a c))))
+        (if (negative? disc)
+            #f
+            (let ((discrt (sqrt disc))
+                  (minus-b (- b))
+                  (two-a (* 2.0 a)))
+              (min (/ (+ minus-b discrt) two-a)
+                   (/ (- minus-b discrt) two-a)))))))
+
+(define *world* '())
+
+(define eye (make-point 0.0 0.0 200.0))
+
+(define (tracer pathname res)
+  (if (file-exists? pathname)
+      (delete-file pathname))
+  (call-with-output-file
+   pathname
+   (lambda (p)
+     (let ((extent (* res 100)))
+       (display "P2 " p)
+       (write extent p)
+       (display " " p)
+       (write extent p)
+       (display " 255" p)
+       (newline p)
+       (do ((y 0 (+ y 1)))
+           ((= y extent))
+         (do ((x 0 (+ x 1)))
+             ((= x extent))
+           (write (color-at
+                   (+ -50.0
+                      (/ (inexact x) (inexact res)))
+                   (+ -50.0
+                      (/ (inexact y) (inexact res))))
+                  p)
+           (newline p)))))))
+
+(define (color-at x y)
+  (let ((ray (unit-vector (- x (point-x eye))
+                          (- y (point-y eye))
+                          (- (point-z eye)))))
+    (exact (round (* (sendray eye ray) 255.0)))))
+
+
+
+(define (sendray pt ray)
+  (let* ((x (first-hit pt ray))
+         (s (vector-ref x 0))
+         (int (vector-ref x 1)))
+    (if s
+        (* (lambert s int ray)
+           (surface-color s))
+        0.0)))
+
+(define (first-hit pt ray)
+  (let loop ((lst *world*) (surface #f) (hit #f) (dist 1e308))
+    (if (null? lst)
+        (vector surface hit)
+        (let ((s (car lst)))
+          (let ((h (intersect s pt ray)))
+            (if h
+                (let ((d (distance h pt)))
+                  (if (< d dist)
+                      (loop (cdr lst) s h d)
+                      (loop (cdr lst) surface hit dist)))
+                (loop (cdr lst) surface hit dist)))))))
+
+(define (lambert s int ray)
+  (let ((n (normal s int)))
+    (max 0.0
+         (+ (* (point-x ray) (point-x n))
+            (* (point-y ray) (point-y n))
+            (* (point-z ray) (point-z n))))))
+
+(define (make-sphere color radius center)
+  (vector color radius center))
+
+(define (sphere-color s) (vector-ref s 0))
+(define (sphere-radius s) (vector-ref s 1))
+(define (sphere-center s) (vector-ref s 2))
+
+(define (defsphere x y z r c)
+  (let ((s (make-sphere c r (make-point x y z))))
+    (set! *world* (cons s *world*))
+    s))
+
+(define (surface-color s)
+  (sphere-color s))
+
+(define (intersect s pt ray)
+  (sphere-intersect s pt ray))
+
+(define (sphere-intersect s pt ray)
+  (let* ((xr (point-x ray))
+         (yr (point-y ray))
+         (zr (point-z ray))
+         (c (sphere-center s))
+         (n (minroot
+             (+ (sq xr) (sq yr) (sq zr))
+             (* 2.0
+                (+ (* (- (point-x pt) (point-x c)) xr)
+                   (* (- (point-y pt) (point-y c)) yr)
+                   (* (- (point-z pt) (point-z c)) zr)))
+             (+ (sq (- (point-x pt) (point-x c)))
+                (sq (- (point-y pt) (point-y c)))
+                (sq (- (point-z pt) (point-z c)))
+                (- (sq (sphere-radius s)))))))
+    (if n
+        (make-point (+ (point-x pt) (* n xr))
+                    (+ (point-y pt) (* n yr))
+                    (+ (point-z pt) (* n zr)))
+        #f)))
+
+(define (normal s pt)
+  (sphere-normal s pt))
+
+(define (sphere-normal s pt)
+  (let ((c (sphere-center s)))
+    (unit-vector (- (point-x c) (point-x pt))
+                 (- (point-y c) (point-y pt))
+                 (- (point-z c) (point-z pt)))))
+
+(define (ray-test res output-file)
+  (set! *world* '())
+  (defsphere 0.0 -300.0 -1200.0 200.0 0.8)
+  (defsphere -80.0 -150.0 -1200.0 200.0 0.7)
+  (defsphere 70.0 -100.0 -1200.0 200.0 0.9)
+  (do ((x -2 (+ x 1)))
+      ((> x 2))
+    (do ((z 2 (+ z 1)))
+        ((> z 7))
+      (defsphere
+        (* (inexact x) 200.0)
+        300.0
+        (* (inexact z) -400.0)
+        40.0
+        0.75)))
+  (tracer output-file res))
+
+(define (run input output)
+  (ray-test input output)
+  'ok)
+
+(define (hide count input)
+  input)
+
+(define (run-r7rs-benchmark name count thunk verify?)
+  (do ((i 0 (+ i 1))
+       (res #f (thunk)))
+      ((= i count)
+       (if (not (verify? res))
+           (error "bad output" res)))))
+
+(define (main)
+  (let* ((count (read))
+         (input1 (read))
+         (input2 (read))
+         (output (read))
+         (s2 (number->string count))
+         (s1 (number->string input1))
+         (name "ray"))
+    (run-r7rs-benchmark
+     (string-append name ":" s2)
+     count
+     (lambda () (run (hide count input1) (hide count input2)))
+     (lambda (result) (equal? result output)))))

benchmarks/gabriel/run.sh

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

build-lib/chibi/char-set/compute.scm

@@ -1,3 +1,5 @@
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain.  All warranties are disclaimed.
 
 (define char-set:letter+digit
   (immutable-char-set (char-set-union char-set:letter char-set:digit)))

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

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

chibi-scheme.pc.in

@@ -0,0 +1,7 @@
+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}

chibi-scheme.vcproj

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

configure

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

contrib/bash_completion

@@ -26,6 +26,9 @@ _chibi-scheme() {
     -x*)
       COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-x!')" -- "$cur") )
       return 0;;
+    -R*)
+      COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-R!')" -- "$cur") )
+      return 0;;
     -l*)
       compopt -o nospace
       _filedir
@@ -42,7 +45,7 @@ _chibi-scheme() {
       COMPREPLY=( $( compgen -W "$(echo $sizes | tr ' ' '\n' | sed 's!^!-h!')" -- "${cur}" ) )
       return 0;;
     -)
-      COMPREPLY=( $( compgen -W '-d -e -f -h -i -l -m -p -q -x -A -I -V' \
+      COMPREPLY=( $( compgen -W '-d -e -f -h -i -l -m -p -q -x -A -I -R -V' \
         -- "$cur") )
       return 0;;
     -*)

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

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

contrib/chibi-genstatic-helper.cmake

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

contrib/chibi-scheme-config.cmake

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

contrib/chibi-scheme.pc.cmake.in

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

contrib/scheme-keywords.el

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

data/.gitignore

@@ -0,0 +1,2 @@
+# downloaded unicode standard files
+*.txt

doc/chibi-doc.1

@@ -6,6 +6,7 @@ chibi-doc \- generate docs from Scheme scribble syntax
 
 .SH SYNOPSIS
 .B chibi-doc
+[-hst]
 [
 .I file
 ]
@@ -13,6 +14,9 @@ chibi-doc \- generate docs from Scheme scribble syntax
 
 .B chibi-doc
 .I dotted-name.of.module
+[
+.I identifier
+]
 .BR
 .SP 0.4
 
@@ -29,6 +33,17 @@ comments are any line beginning with the characters
 
 The scribble syntax is described in the manual.
 
+.SH OPTIONS
+.TP 5
+.BI -h
+Outputs in HTML format (the default).
+.TP
+.BI -s
+Outputs in SXML format.
+.TP
+.BI -t
+Outputs in text format (the default for describing a single variable).
+
 .SH AUTHORS
 .PP
 Alex Shinn (alexshinn @ gmail . com)
@@ -37,4 +52,4 @@ Alex Shinn (alexshinn @ gmail . com)
 .PP
 The chibi-scheme home-page:
 .BR
-http://code.google.com/p/chibi-scheme/
+https://github.com/ashinn/chibi-scheme/

doc/chibi-ffi.1

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

doc/chibi-scheme.1

@@ -6,13 +6,16 @@ chibi-scheme \- a tiny Scheme interpreter
 
 .SH SYNOPSIS
 .B chibi-scheme
-[-qrfV]
+[-qQrRfTV]
 [-I
 .I path
 ]
 [-A
 .I path
 ]
+[-D
+.I feature
+]
 [-m
 .I module
 ]
@@ -28,6 +31,9 @@ chibi-scheme \- a tiny Scheme interpreter
 [-p
 .I expr
 ]
+[-t
+.I module.id
+]
 [-d
 .I image-file
 ]
@@ -69,29 +75,85 @@ program.  Signals aren't caught either - to enable handling keyboard
 interrupts you can use the (chibi process) module.  For a more
 sophisticated REPL with readline support, signal handling, module
 management and smarter read/write you may want to use the (chibi repl)
-module.  For example,
-.I chibi-scheme -mchibi.repl -e'(repl)'
+module.  This can be launched automatically with:
+.I chibi-scheme -R
+\[char46]
 
-The default language is an extended subset of the draft R7RS
-(scheme base) module.  To get exactly the base module, use
-.I chibi-scheme -xscheme.base
+For convenience the default language is the
+(scheme small) module, which includes every library in the R7RS
+small standard, and transitively some other dependencies.  All of this
+together is actually quite large, so for a more minimal startup
+language you'll want to use the
+.I -x module
+option described below.
+To get a mostly R5RS-compatible language, use
+.I chibi-scheme -xscheme.r5rs
+or to get just the core language used for bootstrapping, use
+.I chibi-scheme -xchibi
+or its shortcut
+.I chibi-scheme -q
+\[char46]
 
 .SH OPTIONS
+
+Space is optional between options and their arguments.  Options
+without arguments may not be chained together.
+
+To reduce the need for shell escapes, options with module arguments
+(
+.I -m
+,
+.I -x
+and
+.I -R
+) are written in a dot notation, so that the module
+.I (foo bar)
+is written as
+.I foo.bar
+\[char46]
+
 .TP 5
 .BI -V
 Prints the version information and exits.
 .TP
 .BI -q
-Don't load the initialization file.  The resulting
-environment will only contain the core syntactic forms
-and primitives coded in C.
+"Quick" load, shortcut for
+.I chibi-scheme -xchibi
+This is a slightly different language from (scheme base),
+which may load faster, and is guaranteed not to load any
+additional shared libraries.
 .TP
-.BI -r
+.BI -Q
+Extra "quick" load, shortcut for
+.I chibi-scheme -xchibi.primitive
+The resulting environment will only contain the core syntactic
+forms and primitives coded in C.  This is very fast and guaranteed
+not to load any external files, but is also very limited.
+.TP
+.BI -r [main]
 Run the "main" procedure when the script finishes loading as in SRFI-22.
 .TP
+.BI -R [module]
+Loads the given module and runs the "main" procedure it defines (which
+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 defaults to chibi.repl.  Thus
+.I chibi-scheme -R
+is the recommended means to obtain the advanced REPL.
+.TP
+.BI -s
+Strict mode, escalating warnings to fatal errors.
+.TP
 .BI -f
 Change the reader to case-fold symbols as in R5RS.
 .TP
+.BI -T
+Disables tail-call optimization.  This can be useful for
+debugging in some cases, but also makes it very likely to
+overflow the stack.
+.TP
 .BI -h size[/max_size]
 Specifies the initial size of the heap, in bytes,
 optionally followed by the maximum size the heap can
@@ -113,6 +175,12 @@ Appends
 .I path
 to the load path list.  
 .TP
+.BI -D feature
+Adds
+.I feature
+to the feature list, useful for cond-expanding different
+library code.  
+.TP
 .BI -m module
 .TP
 .BI -x module
@@ -120,11 +188,7 @@ Imports
 .I module
 as though "(import
 .I module
-)" were evaluated.  However, to reduce the need for shell
-escapes, modules are written in a dot notation, so that the module
-.I (foo bar)
-is written as
-.I foo.bar
+)" were evaluated.
 If the
 .BI -x
 version is used, then
@@ -145,6 +209,12 @@ Evaluates the Scheme expression
 .I expr
 then prints the result to stdout.
 .TP
+.BI -t module.id
+Enables tracing for the given identifier
+.I id
+in the module
+.I module.
+.TP
 .BI -d image-file
 Dumps the current Scheme heap to
 .I image-file
@@ -155,13 +225,35 @@ 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
-.TQ
 A colon separated list of directories to search for module
-files, inserted before the system default load paths.
+files, inserted before the system default load paths.  chibi-scheme
+searches for modules in directories in the following order:
+
+.TP
+          directories included with the -I path option
+.TP
+          directories included from CHIBI_MODULE_PATH
+.TP
+          system directories 
+.TP
+          directories included with -A path option
+
+If CHIBI_MODULE_PATH is unset, the directories "./lib", and "." are
+searched in order. Set to empty to only consider -I, system
+directories and -A.
+
+.TP
+.B CHIBI_IGNORE_SYSTEM_PATH
+If set to anything but "0", system directories (as listed above) are
+not included in the search paths.
 
 .SH AUTHORS
 .PP
@@ -169,9 +261,9 @@ Alex Shinn (alexshinn @ gmail . com)
 
 .SH SEE ALSO
 .PP
-More detailed information can be found in the README file
-included in the distribution.
+More detailed information can be found in the manual included in
+doc/chibi.scrbl included in the distribution.
 
 The chibi-scheme home-page:
 .br
-http://code.google.com/p/chibi-scheme/
+https://github.com/ashinn/chibi-scheme/

examples/echo-server-inet6.scm

@@ -0,0 +1,29 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (scheme write) (chibi net) (chibi net server))
+
+;; Copy each input line to output.
+(define (echo-handler in out sock addr)
+  (let ((line (read-line in)))
+    (cond
+     ((not (or (eof-object? line) (equal? line "")))
+      ;; log the request to stdout
+      (display "read: ") (write line)
+      (display " from ")
+      (display (sockaddr-name (address-info-address addr)))
+      (display " port ") (write (sockaddr-port (address-info-address addr)))
+      (newline)
+      ;; write and flush the response
+      (display line out)
+      (newline out)
+      (flush-output-port out)
+      (echo-handler in out sock addr)))))
+
+(define (get-inet6-address-info host service)
+  (let ((hints (make-address-info address-family/inet6
+                                  socket-type/stream
+                                  ip-proto/tcp)))
+    (get-address-info host service hints)))
+
+;; Start the server on local ipv6 addresses on port 5556.
+(run-net-server (get-inet6-address-info #f 5556) echo-handler)

examples/echo-server-udp.scm

@@ -0,0 +1,22 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (chibi net))
+
+(define (get-udp-address-info host service)
+  (let ((hints (make-address-info address-family/inet
+                                  socket-type/datagram
+                                  ip-proto/udp)))
+    (get-address-info host service hints)))
+
+;; create and bind a udp socket
+(let* ((addr (get-udp-address-info #f 5556))
+       (sock (socket (address-info-family addr)
+                     (address-info-socket-type addr)
+                     (address-info-protocol addr))))
+  (bind sock (address-info-address addr) (address-info-address-length addr))
+  ;; for every packet we receive, just send it back
+  (let lp ()
+    (cond
+     ((receive sock 512 0 addr)
+      => (lambda (bv) (send sock bv 0 addr))))
+    (lp)))

examples/echo-server.scm

@@ -1,20 +1,26 @@
+#!/usr/bin/env chibi-scheme
 
-;; Simple R7RS echo server, using (srfi 18) threads and the
-;; run-net-server utility from (chibi net server).
+;; Simple R7RS echo server, using the run-net-server utility from
+;; (chibi net server).
 
-(import (scheme base) (scheme write) (srfi 18) (chibi net server))
+(import (scheme base) (scheme write) (chibi net) (chibi net server))
 
 ;; Copy each input line to output.
 (define (echo-handler in out sock addr)
   (let ((line (read-line in)))
     (cond
      ((not (or (eof-object? line) (equal? line "")))
-      (display "read: ") (write line) (newline)
+      ;; log the request to stdout
+      (display "read: ") (write line)
+      (display " from ")
+      (display (sockaddr-name (address-info-address addr)))
+      (display ":") (write (sockaddr-port (address-info-address addr)))
+      (newline)
+      ;; write and flush the response
       (display line out)
       (newline out)
       (flush-output-port out)
-      (thread-yield!)
       (echo-handler in out sock addr)))))
 
-;; Start the server on localhost:5556 dispatching clients to echo-handler.
+;; Start the server on *:5556 dispatching clients to echo-handler.
 (run-net-server 5556 echo-handler)

examples/hello.scm

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

examples/repl-server.scm

@@ -0,0 +1,26 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (scheme read) (scheme write) (scheme eval)
+        (chibi net) (chibi net server))
+
+(define (repl-handler in out sock addr)
+  (let ((env (environment '(scheme base)
+                          '(only (chibi) import))))
+    (let lp ()
+      (let ((expr (read in)))
+        (cond
+         ((not (eof-object? expr))
+          (let ((result (guard (exn (else
+                                     (display "ERROR: " out)
+                                     (write exn out)
+                                     (newline out)
+                                     (if #f #f)))
+                          (eval expr env))))
+            (cond
+             ((not (eq? result (if #f #f)))
+              (write result out)
+              (newline out)))
+            (flush-output-port out)
+            (lp))))))))
+
+(run-net-server 5556 repl-handler)

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

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

gc_heap.c

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

include/chibi/bignum.h

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

include/chibi/eval.h

@@ -1,5 +1,5 @@
 /*  eval.h -- headers for eval library                        */
-/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #ifndef SEXP_EVAL_H
@@ -15,7 +15,7 @@ extern "C" {
 
 #define sexp_init_file "init-"
 #define sexp_init_file_suffix ".scm"
-#define sexp_meta_file "meta.scm"
+#define sexp_meta_file "meta-7.scm"
 #define sexp_leap_seconds_file "leap.txt"
 
 enum sexp_core_form_names {
@@ -46,19 +46,18 @@ 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
 
 /**************************** prototypes ******************************/
 
-SEXP_API void sexp_warn (sexp ctx, char *msg, sexp x);
+SEXP_API void sexp_warn (sexp ctx, const char *msg, sexp x);
 SEXP_API void sexp_scheme_init (void);
 SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size);
 SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
 SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj);
+SEXP_API sexp sexp_maybe_wrap_error (sexp ctx, sexp obj);
 SEXP_API sexp sexp_analyze (sexp context, sexp x);
 SEXP_API sexp sexp_simplify (sexp ctx, sexp self, sexp_sint_t n, sexp ast);
 SEXP_API sexp sexp_make_lambda (sexp ctx, sexp params);
@@ -75,28 +74,33 @@ SEXP_API void sexp_bless_bytecode (sexp ctx, sexp bc);
 #endif
 SEXP_API sexp sexp_complete_bytecode (sexp ctx);
 SEXP_API void sexp_shrink_bcode (sexp ctx, sexp_uint_t i);
-SEXP_API void sexp_expand_bcode (sexp ctx, sexp_uint_t size);
+SEXP_API void sexp_expand_bcode (sexp ctx, sexp_sint_t size);
 SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
 SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
-SEXP_API int sexp_param_index (sexp lambda, sexp name);
+SEXP_API int sexp_param_index (sexp ctx, sexp lambda, sexp name);
 SEXP_API sexp sexp_compile_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
+SEXP_API sexp sexp_generate_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
 SEXP_API sexp sexp_eval_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
 SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env);
 SEXP_API sexp sexp_load_op (sexp context, sexp self, sexp_sint_t n, sexp expr, sexp env);
 SEXP_API sexp sexp_exception_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn);
 SEXP_API sexp sexp_make_env_op (sexp context, sexp self, sexp_sint_t n);
 SEXP_API sexp sexp_make_null_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
-SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version);
+SEXP_API sexp sexp_env_cell_define (sexp ctx, sexp env, sexp name, sexp value, sexp* varenv);
+SEXP_API sexp sexp_make_primitive_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
 SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
 SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value);
 SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close);
 SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
+SEXP_API char* sexp_find_module_file_raw (sexp ctx, const char *file);
 SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file);
 SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
+SEXP_API sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file);
 SEXP_API sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env);
 SEXP_API sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp);
 SEXP_API sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env);
 SEXP_API sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n);
 SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value);
 SEXP_API sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp);
@@ -111,27 +115,37 @@ SEXP_API sexp sexp_open_output_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp
 SEXP_API sexp sexp_open_binary_input_file(sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_open_binary_output_file(sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line);
 SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
-SEXP_API sexp sexp_env_cell (sexp env, sexp sym, int localp);
-SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
+SEXP_API sexp sexp_env_cell (sexp ctx, sexp env, sexp sym, int localp);
+SEXP_API sexp sexp_env_ref (sexp ctx, sexp env, sexp sym, sexp dflt);
+SEXP_API sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp env);
 SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
+#if SEXP_USE_RENAME_BINDINGS
+SEXP_API sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value);
+#endif
 SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res);
 SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
 SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
 SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
-SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
 SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
+#if SEXP_USE_AUTO_FORCE
+SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
+#endif
 #if SEXP_USE_UTF8_STRINGS
 SEXP_API sexp sexp_read_utf8_char (sexp ctx, sexp port, int i);
+SEXP_API void sexp_push_utf8_char (sexp ctx, int i, sexp port);
 SEXP_API void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch);
 SEXP_API sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i);
 SEXP_API sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch);
 #endif
 #if SEXP_USE_GREEN_THREADS
 SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val);
+#endif
 SEXP_API sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n);
 SEXP_API sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp val);
-#endif
 SEXP_API sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp ci);
 #if SEXP_USE_RATIOS
 SEXP_API sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
@@ -156,28 +170,33 @@ SEXP_API sexp sexp_asin(sexp ctx, sexp self, sexp_sint_t n, sexp z);
 SEXP_API sexp sexp_acos(sexp ctx, sexp self, sexp_sint_t n, sexp z);
 SEXP_API sexp sexp_atan(sexp ctx, sexp self, sexp_sint_t n, sexp z);
 SEXP_API sexp sexp_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_exact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_inexact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
 SEXP_API sexp sexp_round(sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_trunc(sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_floor(sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_ceiling(sexp ctx, sexp self, sexp_sint_t n, sexp x);
 #endif
 SEXP_API sexp sexp_expt_op(sexp ctx, sexp self, sexp_sint_t n, sexp z1, sexp z2);
+SEXP_API sexp sexp_exact_to_inexact(sexp ctx, sexp self, sexp_sint_t n, sexp i);
+SEXP_API sexp sexp_inexact_to_exact(sexp ctx, sexp self, sexp_sint_t n, sexp x);
 
 #if SEXP_USE_NATIVE_X86
 SEXP_API sexp sexp_write_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp ch, sexp out);
 SEXP_API sexp sexp_newline_op(sexp ctx, sexp self, sexp_sint_t n, sexp out);
 SEXP_API sexp sexp_read_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
 SEXP_API sexp sexp_peek_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
-SEXP_API sexp sexp_exact_to_inexact(sexp ctx, sexp self, sexp_sint_t n, sexp i);
-SEXP_API sexp sexp_inexact_to_exact(sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
 SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
 #endif
 
-#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL)
-#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d)
+SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name, int num_args, const char *fname, sexp_proc1 f, const char *param);
 
-SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param);
+#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p)
+#define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p)
+#define sexp_define_foreign_proc(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_NONE,(const char*)#f,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_proc_rest(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_VARIADIC,(const char*)#f,(sexp_proc1)f,NULL)
 
 #define sexp_env_key(x) sexp_car(x)
 #define sexp_env_value(x) sexp_cdr(x)
@@ -219,6 +238,9 @@ SEXP_API sexp sexp_9p_req_fid (sexp ctx, sexp self, sexp_sint_t n, sexp req);
 SEXP_API sexp sexp_9p_req_newfid (sexp ctx, sexp self, sexp_sint_t n, sexp req);
 SEXP_API sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sexp err);
 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
@@ -232,7 +254,8 @@ SEXP_API int sexp_rest_unused_p (sexp lambda);
 #define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx, NULL, 4, f, n, b, v)
 #define sexp_make_env(ctx) sexp_make_env_op(ctx, NULL, 0)
 #define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx, NULL, 0, v)
-#define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx, NULL, 0)
+#define sexp_make_primitive_env(ctx, v) sexp_make_primitive_env_op(ctx, NULL, 1, v)
+#define sexp_make_standard_env(ctx, v) sexp_make_standard_env_op(ctx, NULL, 1, v)
 #define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx, NULL, 1, d, a)
 #define sexp_eval(ctx, x, e) sexp_eval_op(ctx, NULL, 2, x, e)
 #define sexp_load(ctx, f, e) sexp_load_op(ctx, NULL, 2, f, e)

include/chibi/features.h

@@ -1,5 +1,5 @@
 /*  features.h -- general feature configuration               */
-/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2021 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 /* uncomment this to disable most features */
@@ -23,16 +23,27 @@
 /*   sexp_init_library(ctx, env) function provided. */
 /* #define SEXP_USE_DL 0 */
 
-/* uncomment this to statically compile all C libs */
-/*   If set, this will statically include the clibs.c file */
-/*   into the standard environment, so that you can have */
-/*   access to a predefined set of C libraries without */
-/*   needing dynamic loading.  The clibs.c file is generated */
-/*   automatically by searching the lib directory for */
-/*   modules with include-shared, but can be hand-tailored */
-/*   to your needs. */
+/* uncomment this to support statically compiled C libs */
+/*   Unless SEXP_USE_STATIC_LIBS_EMPTY is set (see below), this */
+/*   will statically include the clibs.c file into the standard */
+/*   environment, so that you can have access to a predefined set */
+/*   of C libraries without needing dynamic loading.  The clibs.c */
+/*   file is generated automatically by searching the lib directory */
+/*   for modules with include-shared, but can be hand-tailored to */
+/*   your needs.  You can also register your own C libraries using */
+/*   sexp_add_static_libraries (see below). */
 /* #define SEXP_USE_STATIC_LIBS 1 */
 
+/* uncomment this to enable user exported C libs */
+/*   You can register your own C libraries using */
+/*   sexp_add_static_libraries.  Each entry in the supplied table, */
+/*   is a name/entry point pair.  These work as if they were */
+/*   dynamically loaded libraries, so naming follows the same */
+/*   conventions.  An entry {"foo", init_foo} will register a */
+/*   library that can be loaded with (load "foo"), or */
+/*   (include-shared "foo"), both of which will call init_foo. */
+/* #define SEXP_USE_STATIC_LIBS_EMPTY 1 */
+
 /* uncomment this to disable detailed source info for debugging */
 /*   By default Chibi will associate source info with every */
 /*   bytecode offset.  By disabling this only lambda-level source */
@@ -64,9 +75,21 @@
 /*   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 */
 
+/* uncomment this to enable heap regions for fixed-size chunks */
+/* #define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 1 */
+
 /* uncomment this to just malloc manually instead of any GC */
 /*   Mostly for debugging purposes, this is the no GC option. */
 /*   You can use just the read/write API and */
@@ -81,18 +104,30 @@
 /*   go away and you're not working on your own C extension. */
 /* #define SEXP_USE_CONSERVATIVE_GC 1 */
 
+/* uncomment this to disable automatic running of finalizers */
+/*   You will need to close ports and file descriptors manually */
+/*   (as you should anyway) and some C extensions may break. */
+/* #define SEXP_USE_FINALIZERS 0 */
+
 /* uncomment this to add additional native checks to only mark objects in the heap */
 /* #define SEXP_USE_SAFE_GC_MARK 1 */
 
 /* uncomment this to track what C source line each object is allocated from */
 /* #define SEXP_USE_TRACK_ALLOC_SOURCE 1 */
 
+/* uncomment this to take a short backtrace of where each object is */
+/* allocated from */
+/* #define SEXP_USE_TRACK_ALLOC_BACKTRACE 1 */
+
 /* uncomment this to add additional native gc checks to verify a magic header */
 /* #define SEXP_USE_HEADER_MAGIC 1 */
 
 /* uncomment this to add very verbose debugging stats to the native GC */
 /* #define SEXP_USE_DEBUG_GC 1 */
 
+/* uncomment this to add instrumentation to the native GC */
+/* #define SEXP_USE_TIME_GC 1 */
+
 /* uncomment this to enable "safe" field accessors for primitive types */
 /*   The sexp union type fields are abstracted away with macros of the */
 /*   form sexp_<type>_<field>(<obj>), however these are just convenience */
@@ -108,6 +143,10 @@
 /*   may be very slow and using CFLAGS=-O0 is recommended. */
 /* #define SEXP_USE_SAFE_ACCESSORS 1 */
 
+/* uncomment to install a default signal handler in main() for segfaults */
+/*   This will print a helpful backtrace. */
+/* #define SEXP_USE_PRINT_BACKTRACE_ON_SEGFAULT 1 */
+
 /* uncomment this to make the heap common to all contexts */
 /*   By default separate contexts can have separate heaps, */
 /*   and are thus thread-safe and independant. */
@@ -149,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 */
@@ -176,6 +231,11 @@
 /* uncomment this to disable extended char names as defined in R7RS */
 /* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */
 
+/* uncomment this to disable R7RS #<n>= and #<n># reader labels in source */
+/*   The (scheme read) and (scheme write) libraries always support */
+/*   this regardless. */
+/* #define SEXP_USE_READER_LABELS 0 */
+
 /* uncomment this to disable UTF-8 string support */
 /*   The default settings store strings in memory as UTF-8, */
 /*   and assumes strings passed to/from the C FFI are UTF-8.  */
@@ -186,10 +246,32 @@
 /*   Making them immutable allows for packed UTF-8 strings. */
 /* #define SEXP_USE_MUTABLE_STRINGS 0 */
 
-/* uncomment this to base string ports on C streams */
-/*   This historic option enables string and custom ports backed */
-/*   by FILE* objects using memstreams and funopen/fopencookie. */
-/* #define SEXP_USE_STRING_STREAMS 1 */
+/* uncomment this to enable precomputed index->cursor tables for strings */
+/*   This makes string-ref faster at the expensive of making string */
+/*   construction (including string-append and I/O) slower. */
+/*   You can configure with SEXP_STRING_INDEX_TABLE_CHUNK_SIZE below, */
+/*   the default is caching every 64th index (<=12.5% string overhead). */
+/*   With a minimum of 1 you'd have up to 8x string overhead, and */
+/*   string-ref would still be slightly slower than string-cursors, */
+/*   and string-append would be marginally slower as well.          */
+/*                                                                  */
+/*   In practice, the overhead of iterating over a string with      */
+/*   string-ref isn't noticeable until about 10k chars.  Times      */
+/*   for iteration using the different approaches:                  */
+/*                                                                  */
+/*   impl\len               1000   10000  100000  1000000           */
+/*   string-ref (utf8)         1      97    9622        x           */
+/*   string-ref (fast)         0       2      19      216           */
+/*   cursor-ref (srfi 130)     0       4      18      150           */
+/*   text-ref (srfi 135)       2      27     211     2006           */
+/*                                                                  */
+/* #define SEXP_USE_STRING_INDEX_TABLE 1 */
+
+/* uncomment this to cache a string cursor for string-ref calls */
+/*   The default is not to use a cache. The goal of caching is to   */
+/*   soften the performance impact of repeated O(n) string-ref      */
+/*   operations on the same string. */
+/* #define SEXP_USE_STRING_REF_CACHE 1 */
 
 /* uncomment this to disable automatic closing of ports */
 /*   If enabled, the underlying FILE* for file ports will be */
@@ -197,11 +279,10 @@
 /*   apply to stdin/stdout/stderr. */
 /* #define SEXP_USE_AUTOCLOSE_PORTS 0 */
 
-/* uncomment this to use the normal 1970 unix epoch */
-/*   By default chibi uses an datetime epoch starting at */
-/*   2010/01/01 00:00:00 in order to be able to represent */
-/*   more common times as fixnums. */
-/* #define SEXP_USE_2010_EPOCH 0 */
+/* uncomment this to use a 2010/01/01 epoch */
+/*   By default chibi uses the normal 1970 unix epoch in accordance */
+/*   with R7RS, but this can represent more times as fixnums. */
+/* #define SEXP_USE_2010_EPOCH 1 */
 
 /* uncomment this to disable stack overflow checks */
 /*   By default stacks are fairly small, so it's good to leave */
@@ -220,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 */
@@ -246,17 +327,39 @@
 #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
 #endif
 
+#ifndef SEXP_MAX_ANALYZE_DEPTH
+#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)
+#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
@@ -272,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
@@ -280,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
@@ -300,6 +458,10 @@
 #define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES
 #endif
 
+#ifndef sexp_default_user_module_path
+#define sexp_default_user_module_path "./lib:."
+#endif
+
 #ifndef SEXP_USE_TYPE_DEFS
 #define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES
 #endif
@@ -309,15 +471,28 @@
 #endif
 
 #ifndef SEXP_USE_DL
-#if defined(PLAN9) || defined(_WIN32)
+#if defined(PLAN9)
 #define SEXP_USE_DL 0
 #else
 #define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
 #endif
 #endif
 
+#ifndef SEXP_USE_STATIC_LIBS_EMPTY
+#define SEXP_USE_STATIC_LIBS_EMPTY 0
+#endif
+
 #ifndef SEXP_USE_STATIC_LIBS
-#define SEXP_USE_STATIC_LIBS 0
+#define SEXP_USE_STATIC_LIBS SEXP_USE_STATIC_LIBS_EMPTY
+#endif
+
+/* don't include clibs.c - include separately or link */
+#ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
+#if defined(PLAN9) || SEXP_USE_STATIC_LIBS_EMPTY
+#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 0
+#else
+#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 1
+#endif
 #endif
 
 #ifndef SEXP_USE_FULL_SOURCE_INFO
@@ -332,9 +507,21 @@
 #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
+#endif
 
 #ifndef SEXP_USE_MALLOC
 #define SEXP_USE_MALLOC 0
@@ -352,6 +539,14 @@
 #define SEXP_USE_DEBUG_GC 0
 #endif
 
+#ifndef SEXP_USE_TIME_GC
+#if SEXP_USE_DEBUG_GC > 0 || defined(__linux) || SEXP_BSD
+#define SEXP_USE_TIME_GC 1
+#else
+#define SEXP_USE_TIME_GC 0
+#endif
+#endif
+
 #ifndef SEXP_USE_SAFE_GC_MARK
 #define SEXP_USE_SAFE_GC_MARK SEXP_USE_DEBUG_GC > 1
 #endif
@@ -360,14 +555,42 @@
 #define SEXP_USE_CONSERVATIVE_GC 0
 #endif
 
+#ifndef SEXP_USE_FINALIZERS
+#define SEXP_USE_FINALIZERS 1
+#endif
+
 #ifndef SEXP_USE_TRACK_ALLOC_SOURCE
 #define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
 #endif
 
+#ifndef SEXP_USE_TRACK_ALLOC_BACKTRACE
+#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
+
 #ifndef SEXP_USE_HEADER_MAGIC
 #define SEXP_USE_HEADER_MAGIC 0
 #endif
 
+#ifndef SEXP_GC_PAD
+#define SEXP_GC_PAD 0
+#endif
+
 #ifndef SEXP_USE_SAFE_ACCESSORS
 #define SEXP_USE_SAFE_ACCESSORS 0
 #endif
@@ -393,18 +616,26 @@
 #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
 #define SEXP_USE_RENAME_BINDINGS 1
 #else
 #ifndef SEXP_USE_RENAME_BINDINGS
-#define SEXP_USE_RENAME_BINDINGS 0
+#define SEXP_USE_RENAME_BINDINGS 1
 #endif
 #endif
 
-#if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
+#ifndef SEXP_USE_SPLICING_LET_SYNTAX
+#define SEXP_USE_SPLICING_LET_SYNTAX 0
+#endif
+
+#ifndef SEXP_USE_FLAT_SYNTACTIC_CLOSURES
+#define SEXP_USE_FLAT_SYNTACTIC_CLOSURES 0
+#endif
+
+#ifndef SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
 #define SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS 0
 #endif
 
@@ -459,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
@@ -475,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
@@ -536,6 +783,10 @@
 #define SEXP_USE_EXTENDED_CHAR_NAMES ! SEXP_USE_NO_FEATURES
 #endif
 
+#ifndef SEXP_USE_READER_LABELS
+#define SEXP_USE_READER_LABELS ! SEXP_USE_NO_FEATURES
+#endif
+
 #ifndef SEXP_USE_UTF8_STRINGS
 #define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES
 #endif
@@ -551,8 +802,20 @@
 #define SEXP_USE_PACKED_STRINGS 1
 #endif
 
-#ifndef SEXP_USE_STRING_STREAMS
-#define SEXP_USE_STRING_STREAMS 0
+#if SEXP_USE_PACKED_STRINGS
+#define SEXP_USE_STRING_INDEX_TABLE 0
+#endif
+#ifndef SEXP_USE_STRING_INDEX_TABLE
+#define SEXP_USE_STRING_INDEX_TABLE 0
+#endif
+
+/* for every chunk_size indexes store the precomputed offset */
+#ifndef SEXP_STRING_INDEX_TABLE_CHUNK_SIZE
+#define SEXP_STRING_INDEX_TABLE_CHUNK_SIZE 64
+#endif
+
+#ifndef SEXP_USE_DISJOINT_STRING_CURSORS
+#define SEXP_USE_DISJOINT_STRING_CURSORS SEXP_USE_UTF8_STRINGS
 #endif
 
 #ifndef SEXP_USE_AUTOCLOSE_PORTS
@@ -560,7 +823,11 @@
 #endif
 
 #ifndef SEXP_USE_GC_FILE_DESCRIPTORS
-#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM && !defined(PLAN9))
+#ifdef PLAN9
+#define SEXP_USE_GC_FILE_DESCRIPTORS 0
+#else
+#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM)
+#endif
 #endif
 
 #ifndef SEXP_USE_BIDIRECTIONAL_PORTS
@@ -576,7 +843,7 @@
 #endif
 
 #ifndef SEXP_USE_2010_EPOCH
-#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES
+#define SEXP_USE_2010_EPOCH 0
 #endif
 
 #ifndef SEXP_EPOCH_OFFSET
@@ -613,12 +880,33 @@
 #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
+
 #ifndef SEXP_DEFAULT_EQUAL_BOUND
-#define SEXP_DEFAULT_EQUAL_BOUND 100000
+#define SEXP_DEFAULT_EQUAL_BOUND 100000000
+#endif
+
+#ifndef SEXP_DEFAULT_WRITE_BOUND
+#define SEXP_DEFAULT_WRITE_BOUND 10000
+#endif
+
+#ifndef SEXP_STRIP_SYNCLOS_BOUND
+#define SEXP_STRIP_SYNCLOS_BOUND 10000
+#endif
+
+#ifndef SEXP_POLL_SLEEP_TIME
+#define SEXP_POLL_SLEEP_TIME 5000
+#define SEXP_POLL_SLEEP_TIME_MS 5
 #endif
 
 #ifndef SEXP_USE_IMAGE_LOADING
-#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
+#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && SEXP_64_BIT && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
 #endif
 
 #ifndef SEXP_USE_UNSAFE_PUSH
@@ -629,6 +917,15 @@
 #define SEXP_USE_MAIN_HELP ! SEXP_USE_NO_FEATURES
 #endif
 
+#ifndef SEXP_USE_MAIN_ERROR_ADVISE
+#define SEXP_USE_MAIN_ERROR_ADVISE ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_SEND_FILE
+#define SEXP_USE_SEND_FILE 0
+/* #define SEXP_USE_SEND_FILE (__linux || SEXP_BSD) */
+#endif
+
 #if SEXP_USE_NATIVE_X86
 #undef SEXP_USE_BOEHM
 #define SEXP_USE_BOEHM 1
@@ -647,13 +944,17 @@
 #endif
 
 #ifndef SEXP_USE_ALIGNED_BYTECODE
-#if defined(__arm__)
+#if defined(__arm__) || defined(__sparc__) || defined(__sparc64__) || defined(__mips__) || defined(__mips64__)
 #define SEXP_USE_ALIGNED_BYTECODE 1
 #else
 #define SEXP_USE_ALIGNED_BYTECODE 0
 #endif
 #endif
 
+#ifndef SEXP_USE_SIGNED_SHIFTS
+#define SEXP_USE_SIGNED_SHIFTS 0
+#endif
+
 #ifdef PLAN9
 #define strcasecmp cistrcmp
 #define strncasecmp cistrncmp
@@ -663,6 +964,17 @@
 #define isinf(x) (isInf(x,1) || isInf(x,-1))
 #define isnan(x) isNaN(x)
 #elif defined(_WIN32)
+#define SHUT_RD 0 /* SD_RECEIVE */
+#define SHUT_WR 1 /* SD_SEND */
+#define SHUT_RDWR 2 /* SD_BOTH */
+#ifdef _MSC_VER
+#define _CRT_SECURE_NO_WARNINGS 1
+#define _CRT_NONSTDC_NO_DEPRECATE 1
+#define _USE_MATH_DEFINES /* For M_LN10 */
+#define strcasecmp _stricmp
+#define strncasecmp _strnicmp
+#pragma warning(disable:4146) /* unary minus operator to unsigned type */
+#if _MSC_VER < 1900
 #define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val)
 #define strcasecmp lstrcmpi
 #define strncasecmp(s1, s2, n) lstrcmpi(s1, s2)
@@ -671,6 +983,10 @@
 #define isnan(x) (x!=x)
 #define isinf(x) (x > DBL_MAX || x < -DBL_MAX)
 #endif
+#elif !defined(__MINGW32__)
+#error Unknown Win32 compiler!
+#endif
+#endif
 
 #ifdef _WIN32
 #define sexp_pos_infinity (DBL_MAX*DBL_MAX)
@@ -686,14 +1002,18 @@
 #define sexp_nan (0.0/0.0)
 #endif
 
-#ifdef __MINGW32__
+#ifdef _WIN32
+#ifdef SEXP_STATIC_LIBRARY
+#define SEXP_API    extern
+#else
 #ifdef BUILDING_DLL
 #define SEXP_API    __declspec(dllexport)
 #else
 #define SEXP_API    __declspec(dllimport)
 #endif
+#endif
 #else
-#define SEXP_API
+#define SEXP_API    extern
 #endif
 
 /************************************************************************/

include/chibi/gc_heap.h

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

include/chibi/install.h.in

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

include/chibi/sexp-huff.h

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

include/chibi/sexp-hufftabdefs.h

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

include/chibi/sexp-hufftabs.h

@@ -0,0 +1,92 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+char _huff_tab21[] = {
+  '\x01',  '\x00',  '\x03',  '\x00',  '\x02',  '\x00',  '\x04',  '\x00',
+};
+
+char _huff_tab19[] = {
+  '\x01',     'j',  '\x01',  '\x00',
+};
+
+char _huff_tab20[] = {
+  '\x05',  '\x09',  '\x07',  '\x0b',  '\x06',  '\x0a',  '\x08',  '\x0c',
+};
+
+char _huff_tab18[] = {
+     '2',     ':',     '6',     'B',     '4',     '@',     '8',     'D',
+     '3',     ';',     '7',     'C',     '5',     'A',     '9',     'E',
+};
+
+char _huff_tab17[] = {
+  '\x0d',  '\x1d',  '\x15',     '&',  '\x11',     '"',  '\x19',     ',',
+  '\x0f',  '\x1f',  '\x17',     '(',  '\x13',     '$',  '\x1b',     '0',
+  '\x0e',  '\x1e',  '\x16',    '\'',  '\x12',     '#',  '\x1a',     '.',
+  '\x10',  '\x20',  '\x18',     ')',  '\x14',     '%',  '\x1c',     '1',
+};
+
+char _huff_tab16[] = {
+     'V',     '^',     'Z',     '|',     'X',     '`',    '\\',     '~',
+     'W',     '_',     '[',     '}',     'Y',     '{',     ']',  '\x7f',
+};
+
+char _huff_tab15[] = {
+     'F',     'N',     'J',     'R',     'H',     'P',     'L',     'T',
+     'G',     'O',     'K',     'S',     'I',     'Q',     'M',     'U',
+};
+
+char _huff_tab13[] = {
+  '\x00',  '\x00',  '\x00',     '+',  '\x00',  '\x00',  '\x00',     '/',
+};
+
+char _huff_tab14[] = {
+     '*',     'z',
+};
+
+char _huff_tab11[] = {
+  '\x00',     'b',  '\x00',     'x',
+};
+
+char _huff_tab12[] = {
+     '!',     'k',
+};
+
+char _huff_tab9[] = {
+  '\x00',     's',  '\x00',     'l',
+};
+
+char _huff_tab10[] = {
+     'y',     'w',     '<',     'q',
+};
+
+char _huff_tab8[] = {
+     'p',     '?',     'g',     'u',
+};
+
+char _huff_tab7[] = {
+     'f',     '>',     '=',     'v',
+};
+
+char _huff_tab5[] = {
+  '\x00',     'o',  '\x00',     'd',
+};
+
+char _huff_tab6[] = {
+     'h',     'm',
+};
+
+char _huff_tab4[] = {
+     'c',     'i',
+};
+
+char _huff_tab3[] = {
+     'n',     '-',
+};
+
+char _huff_tab1[] = {
+  '\x00',  '\x00',  '\x00',     'r',  '\x00',  '\x00',  '\x00',     'a',
+};
+
+char _huff_tab2[] = {
+     'e',     't',
+};
+

js/exported_functions.json

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

js/index.html

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

js/post.js

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

js/pre.js

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

lib/chibi/accept.c

@@ -13,8 +13,8 @@ sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_
 #if SEXP_USE_GREEN_THREADS
   if (res < 0 && errno == EWOULDBLOCK) {
     f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
-    if (sexp_opcodep(f)) {
-      ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, sexp_make_fixnum(sock));
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), SEXP_FALSE);
       return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
     }
   }
@@ -24,8 +24,57 @@ sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_
   return sexp_make_fileno(ctx, sexp_make_fixnum(res), SEXP_FALSE);
 }
 
-/* If we're listening on a socket from Scheme, we most likely want it */
-/* to be non-blocking. */
+/* likewise sendto and recvfrom should suspend the thread gracefully */
+
+#define sexp_zerop(x) ((x) == SEXP_ZERO || (sexp_flonump(x) && sexp_flonum_value(x) == 0.0))
+
+sexp sexp_sendto (sexp ctx, sexp self, int sock, const void* buffer, size_t len, int flags, struct sockaddr* addr, socklen_t addr_len, sexp timeout) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  ssize_t res;
+  res = sendto(sock, buffer, len, flags, addr, addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK && !sexp_zerop(timeout)) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), timeout);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR);
+    }
+  }
+#endif
+  return sexp_make_fixnum(res);
+}
+
+sexp sexp_recvfrom (sexp ctx, sexp self, int sock, void* buffer, size_t len, int flags, struct sockaddr* addr, socklen_t addr_len, sexp timeout) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  ssize_t res;
+  res = recvfrom(sock, buffer, len, flags, addr, &addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK && !sexp_zerop(timeout)) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), timeout);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR);
+    }
+  }
+#endif
+  return sexp_make_fixnum(res);
+}
+
+/* If we're binding or listening on a socket from Scheme, we most */
+/* likely want it to be non-blocking. */
+
+sexp sexp_bind (sexp ctx, sexp self, int fd, struct sockaddr* addr, socklen_t addr_len) {
+  int res = bind(fd, addr, addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res >= 0)
+    fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK);
+#endif
+  return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
+}
 
 sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
   int fd, res;
@@ -39,3 +88,23 @@ sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
 #endif
   return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
 }
+
+/* Additional utilities. */
+
+sexp sexp_sockaddr_name (sexp ctx, sexp self, struct sockaddr* addr) {
+  char buf[INET6_ADDRSTRLEN];
+  /* struct sockaddr_in *sa = (struct sockaddr_in *)addr; */
+  /* unsigned char *ptr = (unsigned char *)&(sa->sin_addr); */
+  /* 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, 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 ntohs(sa->sin_port);
+}

lib/chibi/app-test.sld

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

lib/chibi/app.scm

@@ -0,0 +1,557 @@
+;; app.scm -- unified option parsing and config
+;; Copyright (c) 2012-2024 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> The high-level interface.  Parses a command-line with optional
+;;> and/or positional arguments, with arbitrarily nested subcommands
+;;> (optionally having their own arguments), and calls the
+;;> corresponding main procedure on the parsed config.
+;;>
+;;> Given an application spec \var{spec}, parses the given
+;;> command-line arguments \var{args} into a config object (from
+;;> \scheme{(chibi config)}), prepended to the existing object
+;;> \var{config} if given.  Then runs the corresponding command (or
+;;> sub-command) procedure from \var{spec} on the following arguments:
+;;>
+;;> \scheme{(<proc> <config> <spec> <positional args> ...)}
+;;>
+;;> The app spec should be a list of the form:
+;;>
+;;> \scheme{(<command> [<doc-string>] <clauses> ...)}
+;;>
+;;> where clauses can be any of:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{(@ <opt-spec>)} - option spec, described below}
+;;> \item{\scheme{(begin: <begin-proc>)} - procedure to run before main}
+;;> \item{\scheme{(end: <end-proc>)} - procedure to run after main}
+;;> \item{\scheme{(types: (<type-name> <parser>) ...)} - additional types that can be used in argument parsing}
+;;> \item{\scheme{(<proc> args ...)} - main procedure (args only for documentation)}
+;;> \item{\scheme{<app-spec>} - a subcommand described by the nested spec}
+;;> \item{\scheme{(or <app-spec> ...)} - an alternate list of subcommands}
+;;> ]
+;;>
+;;> For subcommands the symbolic command name must match, though it is
+;;> ignored for the initial spec (i.e. the application name is not
+;;> checked).  The \scheme{begin} and \scheme{end} procedures can be
+;;> useful for loading and saving state common to all subcommands.
+;;>
+;;> The \scheme{opt-spec} describes command-line options, and is a
+;;> simple list with each opt of the form:
+;;>
+;;> \scheme{(<name> <type> [(<aliases> ...)] [<doc-string>])}
+;;>
+;;> where \scheme{<name>} is a symbol name, \scheme{<aliases>} is an
+;;> optional list of strings (for long options) or characters (for
+;;> short options) to serve as aliases in addition to the exact name.
+;;> \scheme{type} can be any of:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{boolean} - boolean, associated value optional, allowing \scheme{--noname} to indicate \scheme{#false}}
+;;> \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}
+;;> \item{\scheme{symbol} - a symbol}
+;;> \item{\scheme{string} - a string}
+;;> \item{\scheme{sexp} - a sexp parsed with \scheme{read}}
+;;> \item{\scheme{(list <type>)} - a comma-delimited list of types}
+;;> ]
+;;>
+;;> Note that the options specs are composed entirely of objects that
+;;> can be read and written, thus for example optionally loaded from
+;;> files, whereas the app specs include embedded procedure objects so
+;;> are typically written with \scheme{quasiquote}.
+;;>
+;;> 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
+;;>   `(zoo
+;;>     "Zookeeper Application"
+;;>     (@
+;;>      (animals (list symbol) "list of animals to act on (default all)")
+;;>      (lions boolean (#\\l) "also apply the action to lions"))
+;;>     (or
+;;>      (feed "feed the animals" () (,feed animals ...))
+;;>      (wash "wash the animals" (@ (soap boolean)) (,wash animals ...))
+;;>      (help "print help" (,app-help-command))))
+;;>   (command-line)
+;;>   (conf-load (string-append (get-environment-variable "HOME") "/.zoo")))
+;;> }
+;;>
+;;> The second and third arguments here are optional, provided to show
+;;> the common pattern of allowing the same options to be specified
+;;> either in a file and/or on the command-line.  The above app can be
+;;> run as:
+;;>
+;;> Feed all animals, including lions:
+;;> \command{zoo -l feed}
+;;>
+;;> Wash the elephants with soap:
+;;> \command{zoo --animals=elephant wash --soap}
+;;>
+;;> Print help:
+;;> \command{zoo help}
+;;>
+;;> The application procedures themselves are of the form:
+;;>
+;;> \scheme{(proc cfg spec args ...)}
+;;>
+;;> where \var{cfg} is a config object from \scheme{(chibi config)}
+;;> holding the parsed option info, \var{spec} is the original app
+;;> spec, and \var{args} are the remaining non-option command-line
+;;> arguments.
+;;>
+;;> To retrieve the options for the above example you can use:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{(conf-get cfg 'animals)}}
+;;> \item{\scheme{(conf-get cfg 'lions)}}
+;;> \item{\scheme{(conf-get cfg '(command wash soap))}}
+;;> ]
+;;>
+;;> Notice that options for subcommands are nested under the
+;;> \scheme{(command <name>)} prefix, so that you can use the same
+;;> name for different subcommands without conflict.  This also means
+;;> the subcommand options are distinct from the top-level options, so
+;;> when using subcommands users must always write the command line
+;;> as:
+;;>
+;;> \command{app [<general options>] <subcommand> [<sub options>]}
+;;>
+;;> The ~/.zoo file could then hold an sexp of the form:
+;;>
+;;> \schemeblock{
+;;> ((animals (camel elephant rhinocerous))
+;;>  (command
+;;>   (wash
+;;>    (soap #t))))
+;;> }
+
+(define (run-application spec . o)
+  (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 '())
+      => (lambda (v)
+           (let ((proc (vector-ref v 0))
+                 (cfg (vector-ref v 1))
+                 (args (vector-ref v 2))
+                 (init (vector-ref v 3))
+                 (end (vector-ref v 4)))
+             (if init (init cfg))
+             (let ((res (apply proc cfg spec args)))
+               (if end (end cfg))
+               res))))
+     ((null? (cdr args))
+      (app-help spec args)
+      (error "Expected a command"))
+     (else
+      (error "Unknown command" args)))))
+
+;;> Parse a single command-line argument from \var{args} according to
+;;> \var{conf-spec}, and returns a list of two values: the
+;;> \scheme{(name value)} for the option, and a list of remaining
+;;> unparsed args.  \scheme{name} will have the current \var{prefix}
+;;> prepended.  If a parse error or unknown option is found, calls
+;;> \var{fail} with a single string argument describing the error,
+;;> returning that result.
+
+(define (parse-option prefix conf-spec args types fail)
+  (define (parse-value type str)
+    (cond
+     ((not (string? str))
+      (list str #f))
+     ((and (pair? type) (eq? 'list (car type)))
+      (let ((res (map (lambda (x) (parse-value (cadr type) x))
+                      (string-split str #\,))))
+        (list (map car res) (any string? (map cdr res)))))
+     (else
+      (case type
+        ((boolean)
+         (list (not (member str '("#f" "#false" "#F" "#FALSE" "false" "FALSE")))
+               #f))
+        ((number integer real)
+         (let ((n (string->number str)))
+           (cond
+            ((and (eq? type 'integer) (not (integer? n)))
+             (list n "expected an integer"))
+            ((and (eq? type 'real) (not (real? n)))
+             (list n "expected a real number"))
+            (else
+             (list n #f)))))
+        ((symbol)
+         (list (string->symbol str) #f))
+        ((char)
+         (if (not (= 1 (string-length str)))
+             (list #f "expected a single character")
+             (list (string-ref str 0) #f)))
+        ((sexp)
+         (list (guard (exn (else str))
+                 (let* ((in (open-input-string str))
+                        (res (read in)))
+                   (close-input-port in)
+                   res))
+               #f))
+        (else
+         (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)))
+      (cond
+       ((= 1 (length syms))
+        (let lp ((ls conf-spec))
+          (and (pair? ls)
+               (let ((x (car ls)))
+                 (cond
+                  ((eq? sym (car x)) x)
+                  ((and (pair? (cddr x)) (pair? (third x))
+                        (member str (third x)))
+                   x)
+                  ((and (pair? (cddr x)) (pair? (third x))
+                        (member `(not ,str) (third x)))
+                   `(not ,x))
+                  (else (lp (cdr ls))))))))
+       (else
+        (let lp ((ls conf-spec))
+          (and (pair? ls)
+               (let ((x (car ls)))
+                 (cond
+                  ((or (eq? sym (car x))
+                       (and (pair? (cddr x)) (pair? (third x))
+                            (member str (third x))))
+                   (let ((type (cadr x)))
+                     (if (not (and (pair? type) (eq? 'conf (car type))))
+                         (error "option prefix not a subconf" sym)
+                         (lookup-conf-spec (cdr type) (cdr syms) (cdr strs)))))
+                  (else (lp (cdr ls)))))))))))
+  (define (lookup-short-option ch spec)
+    (let lp ((ls spec))
+      (and (pair? ls)
+           (let ((x (car ls)))
+             (cond
+              ((and (pair? (cddr x)) (pair? (third x)) (memv ch (third x)))
+               x)
+              ((and (pair? (cddr x)) (pair? (third x))
+                    (member `(not ,ch) (third x)))
+               `(not ,x))
+              (else (lp (cdr ls))))))))
+  (define (parse-long-option str args fail)
+    (let* ((fail-args (cons (string-append "--" str) args))
+           (str+val (string-split str #\= 2))
+           (str (car str+val))
+           (args (if (pair? (cdr str+val)) (cons (cadr str+val) args) args))
+           (strs (string-split str #\.))
+           (syms (map string->symbol strs))
+           (spec (lookup-conf-spec conf-spec syms strs)))
+      (cond
+       ((not spec)
+        ;; check for 'no' prefix on boolean
+        (if (not (string-prefix? "no" str))
+            (fail prefix conf-spec (car fail-args) fail-args "unknown option")
+            (let ((res (parse-long-option (substring str 2) args (lambda args #f))))
+              (cond
+               ((not res)
+                (fail prefix conf-spec (car fail-args) fail-args
+                      "unknown option"))
+               ((not (boolean? (cdar res)))
+                (error "'no' prefix only valid on boolean options"))
+               (else
+                `((,(caar res) . #f) ,@(cdr res)))))))
+       ((and (pair? spec) (eq? 'not (car spec)))
+        (cons (cons (append prefix (list (car spec))) #f) args))
+       ((and (eq? 'boolean (cadr spec)) (null? (cdr str+val)))
+        (cons (cons (append prefix (list (car spec))) #t) args))
+       ((null? args)
+        (fail prefix conf-spec (car fail-args) fail-args
+              "missing argument to option"))
+       (else
+        (let ((val+err (parse-value (cadr spec) (car args))))
+          (if (cadr val+err)
+              (fail prefix conf-spec (car fail-args) fail-args (cadr val+err))
+              (cons (cons (append prefix (drop-right syms 1) (list (car spec)))
+                          (car val+err))
+                    (cdr args))))))))
+  (define (parse-short-option str args fail)
+    (let* ((ch (string-ref str 0))
+           (x (lookup-short-option ch conf-spec))
+           (fail-args (cons (string-append "-" str) args)))
+      (cond
+       ((not x)
+        (fail prefix conf-spec (car fail-args) fail-args "unknown option"))
+       ((and (pair? x) (eq? 'not (car x)))
+        (cons (cons (append prefix (list (car (cadr x)))) #f)
+              (if (= 1 (string-length str))
+                  args
+                  (cons (string-append "-" (substring str 1)) args))))
+       ((eq? 'boolean (cadr x))
+        (cons (cons (append prefix (list (car x))) #t)
+              (if (= 1 (string-length str))
+                  args
+                  (cons (string-append "-" (substring str 1)) args))))
+       ((> (string-length str) 1)
+        (let ((val+err (parse-value (cadr x) (substring str 1))))
+          (if (cadr val+err)
+              (fail prefix conf-spec (car args) args (cadr val+err))
+              (cons (cons (append prefix (list (car x))) (car val+err))
+                    args))))
+       ((null? args)
+        (fail prefix conf-spec (car fail-args) fail-args
+              "missing argument to option"))
+       (else
+        (cons (cons (append prefix (list (car x))) (car args)) (cdr args))))))
+  (if (eqv? #\- (string-ref (car args) 1))
+      (parse-long-option (substring (car args) 2) (cdr args) fail)
+      (parse-short-option (substring (car args) 1) (cdr args) fail)))
+
+;;> Parse a list of command-line arguments into a config object.
+;;> Returns a list whose head is the resulting config object, and tail
+;;> 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 types fail)
+  (let lp ((args orig-args)
+           (opts (make-conf '() #f (cons 'options orig-args) #f)))
+    (cond
+     ((null? args)
+      (cons opts args))
+     ((or (member (car args) '("" "-" "--"))
+          (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 types fail)))
+        (lp (cdr val+args)
+            (conf-set opts (caar val+args) (cdar val+args))))))))
+
+;;> Parses a list of command-line arguments \var{args} according to
+;;> the application spec \var{opt-spec}.  Returns a vector of five
+;;> elements:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{proc} - procedure to run the application}
+;;> \item{\scheme{config} - a config object containing all parsed options}
+;;> \item{\scheme{args} - a list of remaining unparsed command-line arguments}
+;;> \item{\scheme{init} - an optional procedure to call before \scheme{proc}}
+;;> \item{\scheme{end} - an optional procedure to call after \scheme{proc}}
+;;> ]
+;;>
+;;> The config object is prepended to \var{config}, with option names
+;;> 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 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)
+                    (cond
+                     ((and (string=? reason "unknown option")
+                           (find-nearest-edits opt (all-opt-names spec)))
+                      => (lambda (similar)
+                           (if (pair? similar)
+                               (error reason opt "Did you mean: " similar)
+                               (error reason opt))))
+                     (else
+                      (error reason opt)))))))
+    (cond
+     ((null? spec)
+      (error "no procedure in application spec"))
+     ((or (null? (car spec)) (equal? '(@) (car spec)))
+      (parse-app prefix (cdr spec) opt-spec args config init end types fail))
+     ((pair? (car spec))
+      (case (caar spec)
+        ((@)
+         (let* ((tail (cdar spec))
+                (new-opt-spec
+                 (cond
+                  ((not (pair? tail))
+                   '())
+                  ((or (pair? (cdr tail))
+                       (and (pair? (car tail)) (symbol? (caar tail))))
+                   tail)
+                  (else
+                   (car tail))))
+                (new-fail
+                 (lambda (new-prefix new-spec new-opt new-args reason)
+                   (parse-option (prev-prefix prefix) opt-spec new-args types fail)))
+                (cfg+args (parse-options prefix new-opt-spec args types new-fail))
+                (config (conf-append (car cfg+args) config))
+                (args (cdr cfg+args)))
+           (parse-app prefix (cdr spec) new-opt-spec args config
+                      init end types new-fail)))
+        ((or)
+         (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 types fail))
+        ((end:)
+         (parse-app prefix (cdr spec) opt-spec args config
+                    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 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 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 types fail)))))
+
+(define (print-command-help command out)
+  (cond
+   ((and (pair? command) (symbol? (car command)))
+    (display "  " out)
+    (display (car command) out)
+    (cond
+     ((find (lambda (x) (and (pair? x) (procedure? (car x)))) command)
+      => (lambda (x)
+           (let lp ((args (cdr x)) (opt-depth 0))
+             (cond
+              ((null? args)
+               (display (make-string opt-depth #\]) out))
+              ((pair? (car args))
+               (display " [" out)
+               (display (caar args) out)
+               (lp (cdr args) (+ opt-depth 1)))
+              (else
+               (display " " out)
+               (display (car args) out)
+               (lp (cdr args) opt-depth)))))))
+    (cond
+     ((find string? command)
+      => (lambda (doc-string) (display " - " out) (display doc-string out))))
+    (newline out))))
+
+(define (print-option-help option out)
+  (let* ((str (symbol->string (car option)))
+         (names (if (and (pair? (cdr option)) (pair? (cddr option)))
+                    (car (cddr option))
+                    '()))
+         (pref-str (cond ((find string? names) => values) (else str)))
+         (pref-ch (find char? names))
+         (doc (find string? (cdr option))))
+    ;; TODO: consider aligning these
+    (cond
+     (pref-ch (display "  -" out) (write-char pref-ch out))
+     (else (display "    " out)))
+    (cond
+     (pref-str
+      (display (if pref-ch ", " "  ") out)
+      (display "--" out) (display pref-str out)))
+    (cond (doc (display " - " out) (display doc out)))
+    (newline out)))
+
+(define (print-help name docs commands options . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (display "Usage: " out) (display name out)
+    (if (pair? options) (display " [options]" out))
+    (case (length commands)
+      ((0) (newline out))
+      (else
+       (display " <command>\nCommands:\n" out)
+       (for-each (lambda (c) (print-command-help c out)) commands))
+      ((1) (print-command-help (car commands) out)))
+    (if (pair? options) (display "Options:\n" out))
+    (for-each (lambda (o) (print-option-help o out)) options)))
+
+;;> Print a help summary for the given application spec \var{spec}.
+
+(define (app-help spec args . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (let lp ((ls (cdr spec))
+             (docs #f)
+             (commands '())
+             (options '()))
+      (cond
+       ((null? ls)
+        (print-help (car spec) docs commands options out))
+       ((or (string? (car ls))
+            (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 (cdar ls))))
+       ((and (pair? (car ls)) (symbol? (caar ls)))
+        ;; don't print nested commands
+        (if (pair? commands)
+            (print-help (car spec) docs commands options out)
+            (if (eq? 'or (caar ls))
+                (lp (cdr ls) docs (cdar ls) options)
+                (lp (cdr ls) docs (list (car ls)) options))))
+       (else
+        (lp (cdr ls) docs commands options))))))
+
+;;> The subcommand form of \scheme{app-help}.  You can use this as a
+;;> subcommand in an application spec, for example as:
+;;> \schemeblock{(help "print help" (,app-help-command args ...))}
+
+(define (app-help-command config spec . args)
+  (app-help spec args (current-output-port)))

lib/chibi/app.sld

@@ -0,0 +1,14 @@
+;;> Unified command-line option parsing and config management.
+
+(define-library (chibi app)
+  (export parse-option parse-options parse-app run-application
+          app-help app-help-command)
+  (import (scheme base)
+          (scheme read)
+          (scheme write)
+          (scheme process-context)
+          (srfi 1)
+          (chibi config)
+          (chibi edit-distance)
+          (chibi string))
+  (include "app.scm"))

lib/chibi/apropos.scm

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

lib/chibi/apropos.sld

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

lib/chibi/assert-test.sld

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

lib/chibi/assert.sld

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

lib/chibi/ast.c

@@ -1,18 +1,40 @@
 /*  ast.c -- interface to the Abstract Syntax Tree            */
-/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include <chibi/eval.h>
 
 #ifndef PLAN9
+#include <stdlib.h>
 #include <errno.h>
 #endif
 
+#ifdef _WIN32
+#if defined(__MINGW32__) || defined(__MINGW64__)
+/* Workaround MinGW header implementation */
+errno_t getenv_s(size_t*, char*, size_t, const char*);
+#endif
+int setenv(const char *name, const char *value, int overwrite)
+{
+  int errcode = 0;
+  if (!overwrite) {
+    size_t envsize = 0;
+    errcode = getenv_s(&envsize, NULL, 0, name);
+    if (errcode || envsize) return errcode;
+  }
+  return _putenv_s(name, value);
+}
+int unsetenv(const char *name)
+{
+  return setenv(name, "", 1);
+}
+#endif
+
 #if ! SEXP_USE_BOEHM
 extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
 #endif
 
-static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) {
+static void sexp_define_type_predicate (sexp ctx, sexp env, const char *cname, sexp_uint_t type) {
   sexp_gc_var2(name, op);
   sexp_gc_preserve2(ctx, name, op);
   name = sexp_c_string(ctx, cname, -1);
@@ -22,7 +44,8 @@ static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_ui
 }
 
 static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
-                                   sexp_uint_t cindex, char* get, char *set) {
+                                   sexp_uint_t cindex,
+                                   const char* get, const char *set) {
   sexp type, index;
   sexp_gc_var2(name, op);
   sexp_gc_preserve2(ctx, name, op);
@@ -39,28 +62,65 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
   sexp_gc_release2(ctx);
 }
 
-static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id) {
+sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
   sexp cell;
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
-  cell = sexp_env_cell(env, id, 0);
-  while ((! cell) && sexp_synclop(id)) {
+  cell = sexp_env_cell(ctx, env, id, 0);
+  if (! cell) {
+    if (sexp_synclop(id)) {
       env = sexp_synclo_env(id);
       id = sexp_synclo_expr(id);
     }
+    cell = sexp_env_cell(ctx, env, id, 0);
+    if (!cell && sexp_truep(createp))
+      cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
+  }
   return cell ? cell : SEXP_FALSE;
 }
 
-static sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_procedure_code(proc);
 }
 
-static sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_procedure_vars(proc);
 }
 
-static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_fixnum(sexp_procedure_num_args(proc));
+}
+
+sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_boolean(sexp_procedure_variadic_p(proc));
+}
+
+sexp sexp_get_procedure_variable_transformer_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_boolean(sexp_procedure_variable_transformer_p(proc));
+}
+
+sexp sexp_get_procedure_flags (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return (sexp) (sexp_uint_t) sexp_procedure_flags(proc);
+}
+
+sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) {
+  sexp flags;
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc);
+  if (sexp_procedure_variable_transformer_p(base_proc))
+    return base_proc;
+  flags = sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER);
+  return sexp_make_procedure(ctx, flags,
+                             sexp_make_fixnum(sexp_procedure_num_args(base_proc)),
+                             sexp_procedure_code(base_proc),
+                             sexp_procedure_vars(base_proc));
+}
+
+sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   if (! sexp_opcodep(op))
     return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
   else if (! sexp_opcode_name(op))
@@ -87,7 +147,7 @@ static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
   return res;
 }
 
-static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp res;
   if (!op)
     return sexp_type_by_index(ctx, SEXP_OBJECT);
@@ -101,7 +161,7 @@ static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp o
   return sexp_translate_opcode_type(ctx, res);
 }
 
-static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
+sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
   sexp res;
   int p = sexp_unbox_fixnum(k);
   if (! sexp_opcodep(op))
@@ -120,7 +180,7 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp
   default:
     res = sexp_opcode_arg3_type(op);
     if (res && sexp_vectorp(res)) {
-      if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
+      if (sexp_vector_length(res) > (unsigned)(sexp_unbox_fixnum(k)-2))
         res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
       else
         res = sexp_type_by_index(ctx, SEXP_OBJECT);
@@ -130,17 +190,17 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp
   return sexp_translate_opcode_type(ctx, res);
 }
 
-static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_class(op));
 }
 
-static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_code(op));
 }
 
-static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp data;
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   data = sexp_opcode_data(op);
@@ -151,29 +211,43 @@ static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
     sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
 }
 
-static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_num_args(op));
 }
 
-static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_boolean(sexp_opcode_variadic_p(op));
 }
 
-static sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
+sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
   sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
   return sexp_make_fixnum(sexp_port_line(p));
 }
 
-static sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
+sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
   sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
   sexp_port_line(p) = sexp_unbox_fixnum(i);
   return SEXP_VOID;
 }
 
-static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_get_port_sourcep (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
+  return sexp_make_boolean(sexp_port_sourcep(p));
+}
+
+sexp sexp_set_port_sourcep (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp b) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
+  sexp_assert_type(ctx, sexp_booleanp, SEXP_BOOLEAN, b);
+  sexp_port_sourcep(p) = sexp_truep(b);
+  return SEXP_VOID;
+}
+
+sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  if (!x)
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
   if (sexp_pointerp(x))
     return sexp_object_type(ctx, x);
   else if (sexp_fixnump(x))
@@ -194,38 +268,91 @@ static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
     return sexp_type_by_index(ctx, SEXP_OBJECT);
 }
 
-static sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
-  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
-  return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
+sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp e2) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1);
+  if (sexp_truep(e2)) sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2);
+  sexp_env_parent(e1) = e2;
+  return SEXP_VOID;
 }
 
-static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
+}
+
+sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
+  sexp_env_lambda(e) = lam;
+  return SEXP_VOID;
+}
+
+sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_make_boolean(sexp_env_syntactic_p(e));
+}
+
+sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  sexp_env_syntactic_p(e) = sexp_truep(synp);
+  return SEXP_VOID;
+}
+
+sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
+  return sexp_env_cell_define(ctx, env, name, value, NULL);
+}
+
+sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+  sexp_gc_var1(tmp);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
+  sexp_gc_preserve1(ctx, tmp);
+  sexp_env_push(ctx, env, tmp, name, value);
+  sexp_gc_release1(ctx);
+  return SEXP_VOID;
+}
+
+sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
+  sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
+  return sexp_make_fixnum(sexp_core_code(c));
+}
+
+sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_name(t);
 }
 
-static sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_cpl(t);
 }
 
-static sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_slots(t);
 }
 
-static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t))
     : sexp_make_fixnum(sexp_type_field_eq_len_base(t));
 }
 
-static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE;
 }
 
-static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_type_printer_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp t, sexp p) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, p);
+  sexp_type_print(t) = p;
+  return SEXP_VOID;
+}
+
+sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   sexp t;
   if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
     return SEXP_ZERO;
@@ -233,15 +360,40 @@ static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_make_fixnum(sexp_type_size_of_object(t, x));
 }
 
-static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
+sexp sexp_immutablep_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return sexp_pointerp(x) ? sexp_make_boolean(sexp_immutablep(x)) : SEXP_TRUE;
+}
+
+sexp sexp_immutable_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp s) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, s);
+#if SEXP_USE_PACKED_STRINGS
+  /* no sharing with packed strings */
+  res = sexp_c_string(ctx, sexp_string_data(s), sexp_string_size(s));
+#else
+  res = sexp_alloc_type(ctx, string, SEXP_STRING);
+  sexp_string_bytes(res) = sexp_string_bytes(s);
+  sexp_string_offset(res) = sexp_string_offset(s);
+  sexp_string_size(res) = sexp_string_size(s);
+  sexp_copy_on_writep(s) = 1;
+#endif
+  sexp_immutablep(res) = 1;
+  return res;
+}
+
+sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
   sexp x = (sexp)sexp_unbox_fixnum(i);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
-  if (sexp_pointerp(x))
+  if (!x || sexp_pointerp(x))
     return dflt;
   return x;
 }
 
-static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
+sexp sexp_object_to_integer (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return sexp_make_integer(ctx, (sexp_uint_t)x);
+}
+
+sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
   sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
   sexp_lambda_name(res) = name;
   sexp_lambda_params(res) = params;
@@ -255,7 +407,7 @@ static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name,
   return res;
 }
 
-static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
+sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
   sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
   sexp_lambda_name(res) = sexp_lambda_name(lambda);
   sexp_lambda_params(res) = sexp_lambda_params(lambda);
@@ -269,21 +421,21 @@ static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
   return res;
 }
 
-static sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
+sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
   sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
   sexp_set_var(res) = var;
   sexp_set_value(res) = value;
   return res;
 }
 
-static sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
+sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
   sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
   sexp_ref_name(res) = name;
   sexp_ref_cell(res) = cell;
   return res;
 }
 
-static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
+sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
   sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
   sexp_cnd_test(res) = test;
   sexp_cnd_pass(res) = pass;
@@ -291,19 +443,26 @@ static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sex
   return res;
 }
 
-static sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
   sexp res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
   sexp_seq_ls(res) = ls;
   return res;
 }
 
-static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
+sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
   sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
   sexp_lit_value(res) = value;
   return res;
 }
 
-static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
+sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
+  sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO);
+  sexp_macro_proc(res) = proc;
+  sexp_macro_env(res) = env;
+  return res;
+}
+
+sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
   sexp ctx2 = ctx;
   if (sexp_envp(e)) {
     ctx2 = sexp_make_child_context(ctx, NULL);
@@ -312,7 +471,12 @@ static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e)
   return sexp_analyze(ctx2, x);
 }
 
-static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  return sexp_extend_env(ctx, env, vars, value);
+}
+
+sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   sexp_gc_var2(ls, res);
   sexp_gc_preserve2(ctx, ls, res);
   res = x;
@@ -324,7 +488,7 @@ static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return res;
 }
 
-static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
   size_t sum_freed=0;
 #if SEXP_USE_BOEHM
   GC_gcollect();
@@ -334,23 +498,95 @@ static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
   return sexp_make_unsigned_integer(ctx, sum_freed);
 }
 
-#ifdef SEXP_USE_GREEN_THREADS
-static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
+sexp sexp_gc_count_op (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_make_unsigned_integer(ctx, sexp_context_gc_count(ctx));
+}
+
+sexp sexp_gc_usecs_op (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_make_unsigned_integer(ctx, sexp_context_gc_usecs(ctx));
+}
+
+#if SEXP_USE_GREEN_THREADS
+sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
   sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P);
-  sexp_global(ctx, SEXP_G_ATOMIC_P) = new;
+  sexp_global(ctx, SEXP_G_ATOMIC_P) = new_val;
   return res;
 }
 #endif
 
-static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+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);
+  res = SEXP_NULL;
+#if SEXP_USE_GREEN_THREADS
+  sexp ls;
+  for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_push(ctx, res, sexp_car(ls));
+  for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_push(ctx, res, sexp_car(ls));
+#endif
+  if (sexp_not(sexp_memq(ctx, ctx, res))) sexp_push(ctx, res, ctx);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y, sexp start) {
   const char *res;
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
-  res = strstr(sexp_string_data(x), sexp_string_data(y));
-  return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE;
+  sexp_assert_type(ctx, sexp_string_cursorp, SEXP_STRING_CURSOR, start);
+  if (sexp_unbox_string_cursor(start) > sexp_string_size(x))
+    return sexp_user_exception(ctx, self, "string-contains: start out of range", start);
+  res = strstr(sexp_string_data(x) + sexp_unbox_string_cursor(start), sexp_string_data(y));
+  return res ? sexp_make_string_cursor(res-sexp_string_data(x)) : SEXP_FALSE;
 }
 
-static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
+  unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
+  sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
+    start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dst);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, src);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sfrom);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sstart);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
+  if (from < 0 || from > to)
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
+  if (start < 0 || start > (sexp_sint_t)sexp_string_size(src))
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
+  if (end < start || end > (sexp_sint_t)sexp_string_size(src))
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
+  pfrom = (unsigned char*)sexp_string_data(dst) + from;
+  pto = (unsigned char*)sexp_string_data(dst) + to;
+  pstart = (unsigned char*)sexp_string_data(src) + start;
+  pend = (unsigned char*)sexp_string_data(src) + end;
+  for ( ; pfrom < pto && pstart < pend; ++pfrom, ++pstart)
+    *pfrom = *pstart;
+  /* adjust for incomplete trailing chars */
+  prev = (unsigned char*)sexp_string_utf8_prev(pfrom);
+  if (sexp_utf8_initial_byte_count(*prev) > pfrom - prev) {
+    for (p = prev; p < pfrom; ++p)
+      *p = '\0';
+    pstart -= pfrom - prev;
+  }
+  return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
+}
+
+sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
+#ifdef PLAN9
+  return SEXP_FALSE;
+#else
+  return sexp_make_fixnum(errno);
+#endif
+}
+
+sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
 #ifdef PLAN9
   return SEXP_FALSE;
 #else
@@ -365,22 +601,46 @@ static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
 #endif
 }
 
-static sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_free_vars(ctx, x, SEXP_NULL);
 }
 
+sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
+  return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
+}
+
+sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
+  return sexp_make_boolean(unsetenv(sexp_string_data(name)));
+}
+
+sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
+  sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
+  sexp_exception_message(res) = SEXP_TRAMPOLINE;
+  return res;
+}
+
 #define sexp_define_type(ctx, name, tag) \
   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, sexp_abi_identifier_t abi) {
+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_global(ctx, SEXP_G_ABI_ERROR);
+    return SEXP_ABI_ERROR;
   sexp_define_type(ctx, "Object", SEXP_OBJECT);
   sexp_define_type(ctx, "Number", SEXP_NUMBER);
   sexp_define_type(ctx, "Bignum", SEXP_BIGNUM);
   sexp_define_type(ctx, "Flonum", SEXP_FLONUM);
   sexp_define_type(ctx, "Integer", SEXP_FIXNUM);
+#if SEXP_USE_RATIOS
+  sexp_define_type(ctx, "Ratio", SEXP_RATIO);
+#endif
+#if SEXP_USE_COMPLEX
+  sexp_define_type(ctx, "Complex", SEXP_COMPLEX);
+#endif
   sexp_define_type(ctx, "Symbol", SEXP_SYMBOL);
   sexp_define_type(ctx, "Char", SEXP_CHAR);
   sexp_define_type(ctx, "Boolean", SEXP_BOOLEAN);
@@ -390,6 +650,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_type(ctx, "Vector", SEXP_VECTOR);
   sexp_define_type(ctx, "Input-Port", SEXP_IPORT);
   sexp_define_type(ctx, "Output-Port", SEXP_OPORT);
+  sexp_define_type(ctx, "File-Descriptor", SEXP_FILENO);
   sexp_define_type(ctx, "Opcode", SEXP_OPCODE);
   sexp_define_type(ctx, "Procedure", SEXP_PROCEDURE);
   sexp_define_type(ctx, "Bytecode", SEXP_BYTECODE);
@@ -398,12 +659,14 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
   sexp_define_type(ctx, "Cnd", SEXP_CND);
   sexp_define_type(ctx, "Set", SEXP_SET);
+  sexp_define_type(ctx, "Set-Syn", SEXP_SET_SYN);
   sexp_define_type(ctx, "Ref", SEXP_REF);
   sexp_define_type(ctx, "Seq", SEXP_SEQ);
   sexp_define_type(ctx, "Lit", SEXP_LIT);
   sexp_define_type(ctx, "Sc", SEXP_SYNCLO);
   sexp_define_type(ctx, "Context", SEXP_CONTEXT);
   sexp_define_type(ctx, "Exception", SEXP_EXCEPTION);
+  sexp_define_type(ctx, "Core", SEXP_CORE);
   sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV);
   sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE);
   sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO);
@@ -414,10 +677,10 @@ 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);
-  sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION);
+  sexp_define_type_predicate(ctx, env, "file-descriptor?", SEXP_FILENO);
   sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", NULL);
   sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", NULL);
   sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", NULL);
@@ -437,21 +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, 1, "bytecode-name", "bytecode-name-set!");
-  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-literals", NULL);
-  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-source", NULL);
-  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", NULL);
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 0, "bytecode-name", "bytecode-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-literals", NULL);
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-source", NULL);
   sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
-  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", 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);
@@ -459,10 +729,11 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "make-set", 2, sexp_make_set_op);
   sexp_define_foreign(ctx, env, "make-lit", 1, sexp_make_lit_op);
   sexp_define_foreign(ctx, env, "make-seq", 1, sexp_make_seq);
+  sexp_define_foreign(ctx, env, "make-macro", 2, sexp_make_macro_op);
   sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize);
-  sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env);
-  sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell);
+  sexp_define_foreign(ctx, env, "extend-env", 3, sexp_extend_env_op);
+  sexp_define_foreign_opt(ctx, env, "env-cell", 3, sexp_get_env_cell, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
   sexp_define_foreign(ctx, env, "opcode-class", 1, sexp_get_opcode_class);
   sexp_define_foreign(ctx, env, "opcode-code", 1, sexp_get_opcode_code);
@@ -473,21 +744,49 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
   sexp_define_foreign(ctx, env, "port-line", 1, sexp_get_port_line);
   sexp_define_foreign(ctx, env, "port-line-set!", 2, sexp_set_port_line);
+  sexp_define_foreign(ctx, env, "port-source?", 1, sexp_get_port_sourcep);
+  sexp_define_foreign(ctx, env, "port-source?-set!", 2, sexp_set_port_sourcep);
   sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of);
   sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op);
   sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op);
   sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op);
   sexp_define_foreign(ctx, env, "type-num-slots", 1, sexp_type_num_slots_op);
   sexp_define_foreign(ctx, env, "type-printer", 1, sexp_type_printer_op);
-  sexp_define_foreign(ctx, env, "environment-parent", 1, sexp_env_parent_op);
+  sexp_define_foreign(ctx, env, "type-printer-set!", 2, sexp_type_printer_set_op);
+  sexp_define_foreign(ctx, env, "env-parent-set!", 2, sexp_env_parent_set_op);
+  sexp_define_foreign(ctx, env, "env-lambda", 1, sexp_env_lambda_op);
+  sexp_define_foreign(ctx, env, "env-lambda-set!", 2, sexp_env_lambda_set_op);
+  sexp_define_foreign(ctx, env, "env-syntactic?", 1, sexp_env_syntactic_op);
+  sexp_define_foreign(ctx, env, "env-syntactic?-set!", 2, sexp_env_syntactic_set_op);
+  sexp_define_foreign(ctx, env, "env-define!", 3, sexp_env_define_op);
+  sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
+  sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
   sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
+  sexp_define_foreign(ctx, env, "immutable?", 1, sexp_immutablep_op);
+  sexp_define_foreign(ctx, env, "immutable-string", 1, sexp_immutable_string_op);
   sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
+  sexp_define_foreign_opt(ctx, env, "object->integer", 1, sexp_object_to_integer, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
-#ifdef SEXP_USE_GREEN_THREADS
+  sexp_define_foreign(ctx, env, "gc-count", 0, sexp_gc_count_op);
+  sexp_define_foreign(ctx, env, "gc-usecs", 0, sexp_gc_usecs_op);
+#if SEXP_USE_GREEN_THREADS
   sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
 #endif
-  sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
+  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);
+  sexp_define_foreign(ctx, env, "errno", 0, sexp_errno);
   sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
+  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

@@ -6,16 +6,16 @@
 ;;> the compiler, and other core types less commonly
 ;;> needed in user code, plus related utilities.
 
-;;> @subsubsection{Analysis and Expansion}
+;;> \section{Analysis and Expansion}
 
-;;> @subsubsubsection{@scheme{(analyze x [env])}}
+;;> \procedure{(analyze x [env])}
 
-;;> Expands and analyzes the expression @var{x} and returns the
+;;> Expands and analyzes the expression \var{x} and returns the
 ;;> resulting AST.
 
-;;> @subsubsubsection{@scheme{(optimize ast)}}
+;;> \procedure{(optimize ast)}
 
-;;> Runs an optimization pass on @var{ast} and returns the
+;;> Runs an optimization pass on \var{ast} and returns the
 ;;> resulting simplified expression.
 
 (define (ast-renames ast)
@@ -78,13 +78,13 @@
         ((null? ls) '())
         (else (f ls))))
 
-;;> Performs a full syntax expansion of the form @var{x} and
+;;> Performs a full syntax expansion of the form \var{x} and
 ;;> returns the resulting s-expression.
 
 (define (macroexpand x)
   (ast->sexp (analyze x)))
 
-;;> Convert @var{ast} to a s-expression, renaming variables if
+;;> Convert \var{ast} to a s-expression, renaming variables if
 ;;> necessary.
 
 (define (ast->sexp ast)
@@ -109,78 +109,106 @@
        ((opcode? x) (cond ((opcode-name x) => string->symbol) (else x)))
        (else x)))))
 
-;;> @subsubsection{Types}
+;;> \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
 ;;> types.  When using
-;;> @hyperlink["http://srfi.schemers.org/srfi-9/srfi-9/html"]{SRFI-9}
-;;> @scheme{define-record-type}, the name is bound to a first class
+;;> \hyperlink["http://srfi.schemers.org/srfi-9/srfi-9/html"]{SRFI-9}
+;;> \scheme{define-record-type}, the name is bound to a first class
 ;;> type object.
 
 ;;> The following core types are also available by name, and may be
-;;> used in the @scheme{match} @scheme{($ ...)} syntax.
+;;> used in the \scheme{match} \scheme{($ ...)} syntax.
 
-;;> @itemlist[
-;;> @item{@scheme{<object>} - the parent of all types}
-;;> @item{@scheme{<number>} - abstract numeric type}
-;;> @item{@scheme{<bignum>} - arbitrary precision exact integers}
-;;> @item{@scheme{<flonum>} - inexact real numbers}
-;;> @item{@scheme{<integer>} - abstract integer type}
-;;> @item{@scheme{<symbol>} - symbols}
-;;> @item{@scheme{<char>} - character}
-;;> @item{@scheme{<boolean>} - @scheme{#t} or @scheme{#f}}
-;;> @item{@scheme{<string>} - strings of characters}
-;;> @item{@scheme{<byte-vector>} - uniform vector of octets}
-;;> @item{@scheme{<pair>} - a @var{car} and @var{cdr}, the basis for lists}
-;;> @item{@scheme{<vector>} - vectors}
-;;> @item{@scheme{<opcode>} - a primitive opcode or C function}
-;;> @item{@scheme{<procedure>} - a closure}
-;;> @item{@scheme{<bytecode>} - the compiled code for a closure}
-;;> @item{@scheme{<env>} - an environment structure}
-;;> @item{@scheme{<macro>} - a macro object, usually not first-class}
-;;> @item{@scheme{<lam>} - a lambda AST type}
-;;> @item{@scheme{<cnd>} - an conditional AST type (i.e. @scheme{if})}
-;;> @item{@scheme{<ref>} - a reference AST type}
-;;> @item{@scheme{<set>} - a mutation AST type (i.e. @scheme{set!})}
-;;> @item{@scheme{<seq>} - a sequence AST type}
-;;> @item{@scheme{<lit>} - a literal AST type}
-;;> @item{@scheme{<sc>} - a syntactic closure}
-;;> @item{@scheme{<context>} - a context object (including threads)}
-;;> @item{@scheme{<exception>} - an exception object}
+;;> \itemlist[
+;;> \item{\scheme{Object} - the parent of all types}
+;;> \item{\scheme{Number} - abstract numeric type}
+;;> \item{\scheme{Bignum} - arbitrary precision exact integers}
+;;> \item{\scheme{Flonum} - inexact real numbers}
+;;> \item{\scheme{Integer} - abstract integer type}
+;;> \item{\scheme{Symbol} - symbols}
+;;> \item{\scheme{Char} - character}
+;;> \item{\scheme{Boolean} - \scheme{#t} or \scheme{#f}}
+;;> \item{\scheme{String} - strings of characters}
+;;> \item{\scheme{Byte-Vector} - uniform vector of octets}
+;;> \item{\scheme{Pair} - a \var{car} and \var{cdr}, the basis for lists}
+;;> \item{\scheme{Vector} - vectors}
+;;> \item{\scheme{Opcode} - a primitive opcode or C function}
+;;> \item{\scheme{Procedure} - a closure}
+;;> \item{\scheme{Bytecode} - the compiled code for a closure}
+;;> \item{\scheme{Env} - an environment structure}
+;;> \item{\scheme{Macro} - a macro object, usually not first-class}
+;;> \item{\scheme{Lam} - a lambda AST type}
+;;> \item{\scheme{Cnd} - an conditional AST type (i.e. \scheme{if})}
+;;> \item{\scheme{Ref} - a reference AST type}
+;;> \item{\scheme{Set} - a mutation AST type (i.e. \scheme{set!})}
+;;> \item{\scheme{Seq} - a sequence AST type}
+;;> \item{\scheme{Lit} - a literal AST type}
+;;> \item{\scheme{Sc} - a syntactic closure}
+;;> \item{\scheme{Context} - a context object (including threads)}
+;;> \item{\scheme{Exception} - an exception object}
 ;;> ]
 
 ;;> The following extended type predicates may also be used to test
 ;;> individual objects for their type:
 
-;;> @itemlist[
-;;> @item{@scheme{environment?}}
-;;> @item{@scheme{bytecode?}}
-;;> @item{@scheme{macro?}}
-;;> @item{@scheme{syntactic-closure?}}
-;;> @item{@scheme{lambda?}}
-;;> @item{@scheme{cnd?}}
-;;> @item{@scheme{ref?}}
-;;> @item{@scheme{set?}}
-;;> @item{@scheme{seq?}}
-;;> @item{@scheme{lit?}}
-;;> @item{@scheme{opcode?}}
-;;> @item{@scheme{type?}}
-;;> @item{@scheme{context?}}
-;;> @item{@scheme{exception?}}
+;;> \itemlist[
+;;> \item{\scheme{environment?}}
+;;> \item{\scheme{bytecode?}}
+;;> \item{\scheme{macro?}}
+;;> \item{\scheme{syntactic-closure?}}
+;;> \item{\scheme{lambda?}}
+;;> \item{\scheme{cnd?}}
+;;> \item{\scheme{ref?}}
+;;> \item{\scheme{set?}}
+;;> \item{\scheme{seq?}}
+;;> \item{\scheme{lit?}}
+;;> \item{\scheme{opcode?}}
+;;> \item{\scheme{type?}}
+;;> \item{\scheme{context?}}
+;;> \item{\scheme{exception?}}
 ;;> ]
 
-;;> @subsubsubsection{@scheme{(type-of x)}}
+;;> \procedure{(type-of x)}
 
-;;> Returns the type of any object @var{x}.
+;;> Returns the type of any object \var{x}.
 
-;;> @subsubsubsection{@scheme{(type-name type)}}
+;;> \procedure{(type-name type)}
 
-;;> Returns the name of type @var{type}.
+;;> Returns the name of type \var{type}.
 
-;;> @subsubsubsection{@scheme{(type-parent type)}}
+;;> \procedure{(type-parent type)}
 
-;;> Returns the immediate parent of type @var{type},
-;;> or @scheme{#f} for a type with no parent.
+;;> Returns the immediate parent of type \var{type},
+;;> or \scheme{#f} for a type with no parent.
 
 (define (type-parent type)
   (let ((v (type-cpl type)))
@@ -188,26 +216,26 @@
          (> (vector-length v) 1)
          (vector-ref v (- (vector-length v) 2)))))
 
-;;> @subsubsubsection{@scheme{(type-cpl type)}}
+;;> \procedure{(type-cpl type)}
 
-;;> Returns the class precedence list of type @var{type} as a
-;;> vector, or @scheme{#f} for a type with no parent.
+;;> Returns the class precedence list of type \var{type} as a
+;;> vector, or \scheme{#f} for a type with no parent.
 
-;;> @subsubsubsection{@scheme{(type-slots type)}}
+;;> \procedure{(type-slots type)}
 
-;;> Returns the slot list of type @var{type}.
+;;> Returns the slot list of type \var{type}.
 
-;;> @subsubsection{Accessors}
+;;> \section{Accessors}
 
 ;;> This section describes additional accessors on AST and other core
 ;;> types.
 
-;;> @subsubsubsection{Procedures}
+;;> \subsection{Procedures}
 
-;;> @itemlist[
-;;> @item{@scheme{(procedure-code f)} - the compiled bytecode object}
-;;> @item{@scheme{(procedure-vars f)} - the variables closed over by @var{f}}
-;;> @item{@scheme{(procedure-name f)} - the name of @var{f} if known, else @scheme{#f}}
+;;> \itemlist[
+;;> \item{\scheme{(procedure-code f)} - the compiled bytecode object}
+;;> \item{\scheme{(procedure-vars f)} - the variables closed over by \var{f}}
+;;> \item{\scheme{(procedure-name f)} - the name of \var{f} if known, else \scheme{#f}}
 ;;> ]
 
 (define (procedure-name x)
@@ -216,149 +244,182 @@
 (define (procedure-name-set! x name)
   (bytecode-name-set! (procedure-code x) name))
 
-;;> @subsubsubsection{Macros}
+;;> \subsection{Macros}
 
-;;> @itemlist[
-;;> @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}
+;;> \itemlist[
+;;> \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)}}
 ;;> ]
 
-;;> @subsubsubsection{Bytecode Objects}
+;;> \subsection{Bytecode Objects}
 
-;;> @itemlist[
-;;> @item{@scheme{(bytecode-name bc)} - the macro procedure}
-;;> @item{@scheme{(bytecode-literals bc)} - literals the bytecode references}
-;;> @item{@scheme{(bytecode-source bc)} - the source location the procedure was defined in}
+;;> \itemlist[
+;;> \item{\scheme{(bytecode-name bc)} - the macro procedure}
+;;> \item{\scheme{(bytecode-literals bc)} - literals the bytecode references}
+;;> \item{\scheme{(bytecode-source bc)} - the source location the procedure was defined in}
 ;;> ]
 
-;;> @subsubsubsection{Syntactic Closures}
+;;> \subsection{Syntactic Closures}
 
-;;> @itemlist[
-;;> @item{@scheme{(syntactic-closure-env sc)}}
-;;> @item{@scheme{(syntactic-closure-vars sc)}}
-;;> @item{@scheme{(syntactic-closure-expr sc)}}
+;;> \itemlist[
+;;> \item{\scheme{(syntactic-closure-env sc)}}
+;;> \item{\scheme{(syntactic-closure-vars sc)}}
+;;> \item{\scheme{(syntactic-closure-expr sc)}}
 ;;> ]
 
 ;;> Return the environment, free variables, and expression
-;;> associated with @var{sc} respectively.
+;;> associated with \var{sc} respectively.
 
-;;> @subsubsubsection{Exceptions}
+;;> \subsection{Exceptions}
 
-;;> @itemlist[
-;;> @item{@scheme{(exception-kind exn)}}
-;;> @item{@scheme{(exception-message exn)}}
-;;> @item{@scheme{(exception-irritants exn)}}
+;;> \itemlist[
+;;> \item{\scheme{(exception-kind exn)}}
+;;> \item{\scheme{(exception-message exn)}}
+;;> \item{\scheme{(exception-irritants exn)}}
 ;;> ]
 
 ;;> Return the kind, message, and irritants
-;;> associated with @var{exn} respectively.
+;;> associated with \var{exn} respectively.
 
-;;> @subsubsubsection{Lambdas}
+;;> \subsection{Lambdas}
 
-;;> @itemlist[
-;;> @item{@scheme{(lambda-name lam)} - the name of the lambda, if known}
-;;> @item{@scheme{(lambda-name-set! lam x)}}
-;;> @item{@scheme{(lambda-params lam)} - the lambda parameter list}
-;;> @item{@scheme{(lambda-params-set! lam x)}}
-;;> @item{@scheme{(lambda-body lam)} - the body of the lambda}
-;;> @item{@scheme{(lambda-body-set! lam x)}}
-;;> @item{@scheme{(lambda-defs lam)} - internal definitions of the lambda}
-;;> @item{@scheme{(lambda-defs-set! lam x)}}
-;;> @item{@scheme{(lambda-locals lam)} - local variables as a list of identifiers}
-;;> @item{@scheme{(lambda-locals-set! lam x)}}
-;;> @item{@scheme{(lambda-flags lam)} - various flags describing the lambda}
-;;> @item{@scheme{(lambda-flags-set! lam x)}}
-;;> @item{@scheme{(lambda-free-vars lam)} - free variables the lambda will need to close over}
-;;> @item{@scheme{(lambda-free-vars-set! lam x)}}
-;;> @item{@scheme{(lambda-set-vars lam)} - variables the lambda mutates}
-;;> @item{@scheme{(lambda-set-vars-set! lam x)}}
-;;> @item{@scheme{(lambda-return-type lam)} - the return type of the lambda}
-;;> @item{@scheme{(lambda-return-type-set! lam x)}}
-;;> @item{@scheme{(lambda-param-types lam)} - the types of the input parameters}
-;;> @item{@scheme{(lambda-param-types-set! lam x)}}
-;;> @item{@scheme{(lambda-source lam)} - the source code of the lambda}
-;;> @item{@scheme{(lambda-source-set! lam x)}}
+;;> \itemlist[
+;;> \item{\scheme{(lambda-name lam)} - the name of the lambda, if known}
+;;> \item{\scheme{(lambda-name-set! lam x)}}
+;;> \item{\scheme{(lambda-params lam)} - the lambda parameter list}
+;;> \item{\scheme{(lambda-params-set! lam x)}}
+;;> \item{\scheme{(lambda-body lam)} - the body of the lambda}
+;;> \item{\scheme{(lambda-body-set! lam x)}}
+;;> \item{\scheme{(lambda-defs lam)} - internal definitions of the lambda}
+;;> \item{\scheme{(lambda-defs-set! lam x)}}
+;;> \item{\scheme{(lambda-locals lam)} - local variables as a list of identifiers}
+;;> \item{\scheme{(lambda-locals-set! lam x)}}
+;;> \item{\scheme{(lambda-flags lam)} - various flags describing the lambda}
+;;> \item{\scheme{(lambda-flags-set! lam x)}}
+;;> \item{\scheme{(lambda-free-vars lam)} - free variables the lambda will need to close over}
+;;> \item{\scheme{(lambda-free-vars-set! lam x)}}
+;;> \item{\scheme{(lambda-set-vars lam)} - variables the lambda mutates}
+;;> \item{\scheme{(lambda-set-vars-set! lam x)}}
+;;> \item{\scheme{(lambda-return-type lam)} - the return type of the lambda}
+;;> \item{\scheme{(lambda-return-type-set! lam x)}}
+;;> \item{\scheme{(lambda-param-types lam)} - the types of the input parameters}
+;;> \item{\scheme{(lambda-param-types-set! lam x)}}
+;;> \item{\scheme{(lambda-source lam)} - the source code of the lambda}
+;;> \item{\scheme{(lambda-source-set! lam x)}}
 ;;> ]
 
-;;> @subsubsubsection{Conditionals}
+;;> \subsection{Conditionals}
 
-;;> @itemlist[
-;;> @item{@scheme{(cnd-test cnd)} - the test for the conditional}
-;;> @item{@scheme{(cnd-test-set! cnd x)}}
-;;> @item{@scheme{(cnd-pass cnd)} - the success branch}
-;;> @item{@scheme{(cnd-pass-set! cnd x)}}
-;;> @item{@scheme{(cnd-fail cnd)} - the failure branch}
-;;> @item{@scheme{(cnd-fail-set! cnd x)}}
+;;> \itemlist[
+;;> \item{\scheme{(cnd-test cnd)} - the test for the conditional}
+;;> \item{\scheme{(cnd-test-set! cnd x)}}
+;;> \item{\scheme{(cnd-pass cnd)} - the success branch}
+;;> \item{\scheme{(cnd-pass-set! cnd x)}}
+;;> \item{\scheme{(cnd-fail cnd)} - the failure branch}
+;;> \item{\scheme{(cnd-fail-set! cnd x)}}
 ;;> ]
 
-;;> @subsubsubsection{Sequences}
+;;> \subsection{Sequences}
 
-;;> @itemlist[
-;;> @item{@scheme{(seq-ls seq)} - the list of sequence expressions}
-;;> @item{@scheme{(seq-ls-set! seq x)}}
+;;> \itemlist[
+;;> \item{\scheme{(seq-ls seq)} - the list of sequence expressions}
+;;> \item{\scheme{(seq-ls-set! seq x)}}
 ;;> ]
 
-;;> @subsubsubsection{References}
+;;> \subsection{References}
 
-;;> @itemlist[
-;;> @item{@scheme{(ref-name ref)} - the name of the referenced variable}
-;;> @item{@scheme{(ref-name-set! ref x)}}
-;;> @item{@scheme{(ref-cell ref)} - the environment cell the reference resolves to}
-;;> @item{@scheme{(ref-cell-set! ref x)}}
+;;> \itemlist[
+;;> \item{\scheme{(ref-name ref)} - the name of the referenced variable}
+;;> \item{\scheme{(ref-name-set! ref x)}}
+;;> \item{\scheme{(ref-cell ref)} - the environment cell the reference resolves to}
+;;> \item{\scheme{(ref-cell-set! ref x)}}
 ;;> ]
 
-;;> @subsubsubsection{Mutations}
+;;> \subsection{Mutations}
 
-;;> @itemlist[
-;;> @item{@scheme{(set-var set)} - a reference to the mutated variable}
-;;> @item{@scheme{(set-var-set! set x)}}
-;;> @item{@scheme{(set-value set)} - the value to set the variable to}
-;;> @item{@scheme{(set-value-set! set x)}}
+;;> \itemlist[
+;;> \item{\scheme{(set-var set)} - a reference to the mutated variable}
+;;> \item{\scheme{(set-var-set! set x)}}
+;;> \item{\scheme{(set-value set)} - the value to set the variable to}
+;;> \item{\scheme{(set-value-set! set x)}}
 ;;> ]
 
-;;> @subsubsubsection{Literals}
+;;> \subsection{Literals}
 
-;;> @itemlist[
-;;> @item{@scheme{(lit-value lit)} - the literal value}
-;;> @item{@scheme{(lit-value-set! lit x)}}
+;;> \itemlist[
+;;> \item{\scheme{(lit-value lit)} - the literal value}
+;;> \item{\scheme{(lit-value-set! lit x)}}
 ;;> ]
 
-;;> @subsubsubsection{Pairs}
+;;> \subsection{Pairs}
 
-;;> @itemlist[
-;;> @item{@scheme{(pair-source x)}}
-;;> @item{@scheme{(pair-source-set! x source)}}
+;;> \itemlist[
+;;> \item{\scheme{(pair-source x)}}
+;;> \item{\scheme{(pair-source-set! x source)}}
 ;;> ]
 
 ;;> Set or return the source code info associated with a pair x.
-;;> Source info is represented as another pair whose @var{car} is
-;;> the source file name and whose @var{cdr} is the line number.
+;;> Source info is represented as another pair whose \var{car} is
+;;> the source file name and whose \var{cdr} is the line number.
 
-;;> @subsubsection{Miscellaneous Utilities}
+;;> \section{Miscellaneous Utilities}
 
-;;> @subsubsubsection{@scheme{(gc)}}
+;;> \procedure{(gc)}
 
 ;;> Force a garbage collection.
 
-;;> @subsubsubsection{@scheme{(object-size x)}}
+;;> \procedure{(object-size x)}
 
-;;> Returns the heap space directly used by @var{x}, not
-;;> counting any elements of @var{x}.
+;;> Returns the heap space directly used by \var{x}, not
+;;> counting any elements of \var{x}.
 
-;;> @subsubsubsection{@scheme{(integer->immediate n)}}
+;;> \procedure{(integer->immediate n)}
 
-;;> Returns the interpretation of the integer @var{n} as
+;;> Returns the interpretation of the integer \var{n} as
 ;;> an immediate object, useful for debugging.
 
-;;> @subsubsubsection{@scheme{(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.
+;;> Returns the first string cursor of \var{pat} in \var{str},
+;;> of \scheme{#f} if it's not found.
 
-;;> @subsubsubsection{@scheme{(atomically expr)}}
+(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
+  ))
 
-;;> Run @var{expr} atomically, disabling yields.  Ideally should only be
+;;> \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
+;;> \scheme{#f} if \var{value} is a function definition.  Used to
+;;> circumvent the vulnerability of the shellshock bug.
+
+(define (safe-setenv name value)
+  (define (function-def? str)
+    (and (> (string-size value) 5)
+         (equal? "() {" (substring value 0 4))))
+  (and (not (function-def? value))
+       (setenv name value)))
+
+;;> \procedure{(atomically expr)}
+
+;;> Run \var{expr} atomically, disabling yields.  Ideally should only be
 ;;> used for brief, deterministic expressions.  If used incorrectly (e.g.
 ;;> running an infinite loop) can render the system unusable.
 ;;> Never expose to a sandbox.
@@ -375,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,15 +1,17 @@
 
 (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 Char Boolean
-   Symbol String Byte-Vector Vector Pair
-   Context Lam Cnd Set Ref Seq Lit Sc Exception
-   syntactic-closure? lambda? cnd? set? ref? seq? lit? type?
-   environment? bytecode? exception? macro? context?
+   Number Bignum Flonum Integer Complex Char Boolean
+   Symbol String Byte-Vector Vector Pair File-Descriptor
+   Context Lam Cnd Set Set-Syn Ref Seq Lit Sc Exception Core
+   syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core?
+   environment? bytecode? exception? macro? context? file-descriptor?
    syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
    copy-lambda make-lambda make-cnd make-ref make-set make-seq make-lit
+   make-macro
    lambda-name lambda-params lambda-body lambda-defs lambda-locals
    lambda-flags lambda-free-vars lambda-set-vars lambda-return-type
    lambda-param-types lambda-source
@@ -19,21 +21,29 @@
    lambda-source-set!
    cnd-test cnd-pass cnd-fail
    cnd-test-set! cnd-pass-set! cnd-fail-set!
-   set-var set-value set-var-set! set-value-set!
+   set-var set-value set-var-set! set-value-set! set-source set-source-set!
    ref-name ref-cell ref-name-set! ref-cell-set!
    seq-ls seq-ls-set! lit-value lit-value-set!
-   exception-kind exception-message exception-irritants
+   exception-kind exception-message exception-irritants exception-source
    opcode-name opcode-num-params opcode-return-type opcode-param-type
-   opcode-class opcode-code opcode-data opcode-variadic?
-   macro-procedure macro-env macro-source
+   opcode-class opcode-code opcode-data opcode-variadic? opcode?
+   macro-procedure macro-env macro-source macro-aux macro-aux-set!
    procedure-code procedure-vars procedure-name procedure-name-set!
+   procedure-arity procedure-variadic? procedure-variable-transformer?
+   procedure-flags make-variable-transformer make-procedure procedure?
    bytecode-name bytecode-literals bytecode-source
-   port-line port-line-set!
-   environment-parent
-   type-name type-cpl type-parent type-slots type-num-slots type-printer
-   object-size integer->immediate gc atomically
-   string-contains integer->error-string
-   flatten-dot update-free-vars!)
+   port-line port-line-set! port-source? port-source?-set!
+   extend-env env-parent env-parent-set! env-lambda env-lambda-set!
+   env-define! env-push! env-syntactic? env-syntactic?-set! core-code
+   type-name type-cpl type-parent type-slots type-num-slots
+   type-printer type-printer-set!
+   object-size object->integer integer->immediate gc gc-usecs gc-count
+   atomically thread-list abort
+   string-contains string-cursor-copy! errno integer->error-string
+   flatten-dot update-free-vars! setenv unsetenv safe-setenv
+   immutable? immutable-string make-immutable!
+   thread-interrupt!
+   chibi-version)
   (import (chibi))
   (include-shared "ast")
   (include "ast.scm"))

lib/chibi/base64-test.sld

@@ -0,0 +1,42 @@
+(define-library (chibi base64-test)
+  (export run-tests)
+  (import (scheme base) (chibi base64) (chibi string) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "base64")
+
+      (test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+          (base64-encode-string "any carnal pleasure."))
+      (test "YW55IGNhcm5hbCBwbGVhc3VyZQ=="
+          (base64-encode-string "any carnal pleasure"))
+      (test "YW55IGNhcm5hbCBwbGVhc3Vy"
+          (base64-encode-string "any carnal pleasur"))
+      (test "YW55IGNhcm5hbCBwbGVhc3U="
+          (base64-encode-string "any carnal pleasu"))
+      (test "YW55IGNhcm5hbCBwbGVhcw=="
+          (base64-encode-string "any carnal pleas"))
+
+      (test "any carnal pleas"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhcw=="))
+      (test "any carnal pleasu"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U="))
+      (test "any carnal pleasur"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3Vy"))
+      (test "any carnal pleas"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhcw"))
+      (test "any carnal pleasu"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U"))
+
+      (test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+          (call-with-output-string
+            (lambda (out)
+              (call-with-input-string "any carnal pleasure."
+                (lambda (in) (base64-encode in out))))))
+
+      (test "any carnal pleasure."
+          (call-with-output-string
+            (lambda (out)
+              (call-with-input-string "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+                (lambda (in) (base64-decode in out))))))
+
+      (test-end))))

lib/chibi/base64.scm

@@ -1,30 +1,8 @@
-;; Copyright (c) 2005-2009 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2005-2014 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
-;; Procedure: base64-encode-string str
-;;   Return a base64 encoded representation of string according to the
-;;   official base64 standard as described in RFC3548.
-
-;; Procedure: base64-decode-string str
-;;   Return a base64 decoded representation of string, also interpreting
-;;   the alternate 62 & 63 valued characters as described in RFC3548.
-;;   Other out-of-band characters are silently stripped, and = signals
-;;   the end of the encoded string.  No errors will be raised.
-
-;; Procedure: base64-encode [port]
-;; Procedure: base64-decode [port]
-;;   Variations of the above which read and write to ports.
-
-;; Procedure: base64-encode-header enc str [start-col max-col nl]
-;;   Return a base64 encoded representation of string as above,
-;;   wrapped in =?ENC?B?...?= as per RFC1522, split across multiple
-;;   MIME-header lines as needed to keep each lines length less than
-;;   MAX-COL.  The string is encoded as is, and the encoding ENC is
-;;   just used for the prefix, i.e. you are responsible for ensuring
-;;   STR is already encoded according to ENC.  The optional argument
-;;   NL is the newline separator, defaulting to CRLF.
-
-;; This API is compatible with the Gauche library rfc.base64.
+;;> RFC 3548 base64 encoding and decoding utilities.
+;;> This API is compatible with the Gauche library rfc.base64.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; string utils
@@ -67,24 +45,24 @@
     (vector-set! res (char->integer #\=) *pad-char*)
     res))
 
-(define (base64-decode-char c)
-  (vector-ref *base64-decode-table* (char->integer c)))
+(define (base64-decode-u8 u8)
+  (vector-ref *base64-decode-table* u8))
 
 (define *base64-encode-table*
   (let ((res (make-vector 64)))
     (let lp ((i 0)) ; map letters
       (cond
        ((<= i 25)
-        (vector-set! res i (integer->char (+ i 65)))
-        (vector-set! res (+ i 26) (integer->char (+ i 97)))
+        (vector-set! res i (+ i 65))
+        (vector-set! res (+ i 26) (+ i 97))
         (lp (+ i 1)))))
     (let lp ((i 0)) ; map numbers
       (cond
        ((<= i 9)
-        (vector-set! res (+ i 52) (integer->char (+ i 48)))
+        (vector-set! res (+ i 52) (+ i 48))
         (lp (+ i 1)))))
-    (vector-set! res 62 #\+)
-    (vector-set! res 63 #\/)
+    (vector-set! res 62 (char->integer #\+))
+    (vector-set! res 63 (char->integer #\/))
     res))
 
 (define (enc i)
@@ -103,21 +81,30 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; decoding
 
+;;> Return a base64 decoded representation of string, also interpreting
+;;> the alternate 62 & 63 valued characters as described in RFC3548.
+;;> Other out-of-band characters are silently stripped, and = signals
+;;> the end of the encoded string.  No errors will be raised.
+
 ;; Create a result buffer with the maximum possible length for the
 ;; input, and pass it to the internal base64-decode-string! utility.
 ;; If the resulting length used is exact, we can return that buffer,
 ;; otherwise we return the appropriate substring.
-(define (base64-decode-string src)
-  (let* ((len (string-length src))
+
+(define (base64-decode-string str)
+  (utf8->string (base64-decode-bytevector (string->utf8 str))))
+
+(define (base64-decode-bytevector src)
+  (let* ((len (bytevector-length src))
          (dst-len (* 3 (arithmetic-shift (+ 3 len) -2)))
-         (dst (make-string dst-len)))
-    (base64-decode-string!
+         (dst (make-bytevector dst-len)))
+    (base64-decode-bytevector!
      src 0 len dst
      (lambda (src-offset res-len b1 b2 b3)
        (let ((res-len (base64-decode-finish dst res-len b1 b2 b3)))
          (if (= res-len dst-len)
              dst
-             (substring dst 0 res-len)))))))
+             (bytevector-copy dst 0 res-len)))))))
 
 ;; This is a little funky.
 ;;
@@ -129,7 +116,7 @@
 ;;   really bad about optimizing nested loops of primitives, so we
 ;;   flatten this into a single loop, using conditionals to determine
 ;;   which character is currently being read.
-(define (base64-decode-string! src start end dst kont)
+(define (base64-decode-bytevector! src start end dst kont)
   (let lp ((i start)
            (j 0)
            (b1 *outside-char*)
@@ -137,7 +124,7 @@
            (b3 *outside-char*))
     (if (>= i end)
         (kont i j b1 b2 b3)
-        (let ((c (base64-decode-char (string-ref src i))))
+        (let ((c (base64-decode-u8 (bytevector-u8-ref src i))))
           (cond
            ((eqv? c *pad-char*)
             (kont i j b1 b2 b3))
@@ -150,23 +137,23 @@
            ((eqv? b3 *outside-char*)
             (lp (+ i 1) j b1 b2 c))
            (else
-            (string-set! dst
+            (bytevector-u8-set!
+             dst
              j
-                         (integer->char
              (bitwise-ior (arithmetic-shift b1 2)
-                                       (extract-bit-field 2 4 b2))))
-            (string-set! dst
+                          (bit-field b2 4 6)))
+            (bytevector-u8-set!
+             dst
              (+ j 1)
-                         (integer->char
              (bitwise-ior
-                           (arithmetic-shift (extract-bit-field 4 0 b2) 4)
-                           (extract-bit-field 4 2 b3))))
-            (string-set! dst
+              (arithmetic-shift (bit-field b2 0 4) 4)
+              (bit-field b3 2 6)))
+            (bytevector-u8-set!
+             dst
              (+ j 2)
-                         (integer->char
              (bitwise-ior
-                           (arithmetic-shift (extract-bit-field 2 0 b3) 6)
-                           c)))
+              (arithmetic-shift (bit-field b3 0 2) 6)
+              c))
             (lp (+ i 1) (+ j 3)
                 *outside-char* *outside-char* *outside-char*)))))))
 
@@ -179,148 +166,181 @@
    ((eqv? b1 *outside-char*)
     j)
    ((eqv? b2 *outside-char*)
-    (string-set! dst j (integer->char (arithmetic-shift b1 2)))
+    (bytevector-u8-set! dst j (arithmetic-shift b1 2))
     (+ j 1))
    (else
-    (string-set! dst
+    (bytevector-u8-set! dst
                         j
-                 (integer->char
                         (bitwise-ior (arithmetic-shift b1 2)
-                               (extract-bit-field 2 4 b2))))
+                                     (bit-field b2 4 6)))
     (cond
      ((eqv? b3 *outside-char*)
       (+ j 1))
      (else
-      (string-set! dst
+      (bytevector-u8-set! dst
                           (+ j 1)
-                   (integer->char
                           (bitwise-ior
-                     (arithmetic-shift (extract-bit-field 4 0 b2) 4)
-                     (extract-bit-field 4 2 b3))))
+                           (arithmetic-shift (bit-field b2 0 4) 4)
+                           (bit-field b3 2 6)))
       (+ j 2))))))
 
-;; General port decoder: work in single blocks at a time to avoid
-;; allocating memory (crucial for Scheme implementations that don't
-;; allow large strings).
+;;>  Variation of the above to read and write to ports.
+
 (define (base64-decode . o)
   (let ((in (if (pair? o) (car o) (current-input-port)))
         (out (if (and (pair? o) (pair? (cdr o)))
                  (cadr o)
                  (current-output-port))))
-    (let ((src (make-string decode-src-length))
-          (dst (make-string decode-dst-length)))
+    (cond
+     ((not (binary-port? in))
+      (let ((str (port->string in)))
+        (write-string (base64-decode-string str) out)))
+     (else
+      (let ((src (make-bytevector decode-src-length))
+            (dst (make-bytevector decode-dst-length)))
         (let lp ((offset 0))
-        (let ((src-len (+ offset
-                          (read-string! decode-src-length src in offset))))
+          (let ((src-len
+                 (+ offset
+                    (read-bytevector! src in offset decode-src-length))))
             (cond
              ((= src-len decode-src-length)
               ;; read a full chunk: decode, write and loop
-            (base64-decode-string!
+              (base64-decode-bytevector!
                src 0 decode-src-length dst
                (lambda (src-offset dst-len b1 b2 b3)
                  (cond
                   ((and (< src-offset src-len)
-                      (eqv? #\= (string-ref src src-offset)))
+                        (eqv? #x3D (bytevector-u8-ref src src-offset)))
                    ;; done
                    (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
-                   (write-string dst out 0 dst-len)))
+                     (write-bytevector dst out 0 dst-len)))
                   ((eqv? b1 *outside-char*)
-                 (write-string dst out 0 dst-len)
+                   (write-bytevector dst out 0 dst-len)
                    (lp 0))
                   (else
-                 (write-string dst out 0 dst-len)
+                   (write-bytevector dst out 0 dst-len)
                    ;; one to three chars left in buffer
-                 (string-set! src 0 (enc b1))
+                   (bytevector-u8-set! src 0 (enc b1))
                    (cond
                     ((eqv? b2 *outside-char*)
                      (lp 1))
                     (else
-                   (string-set! src 1 (enc b2))
+                     (bytevector-u8-set! src 1 (enc b2))
                      (cond
                       ((eqv? b3 *outside-char*)
                        (lp 2))
                       (else
-                     (string-set! src 2 (enc b3))
+                       (bytevector-u8-set! src 2 (enc b3))
                        (lp 3))))))))))
              (else
               ;; end of source - just decode and write once
-            (base64-decode-string!
+              (base64-decode-bytevector!
                src 0 src-len dst
                (lambda (src-offset dst-len b1 b2 b3)
                  (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
-                 (write-string dst out 0 dst-len)))))))))))
+                   (write-bytevector dst out 0 dst-len)))))))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; encoding
 
+;;> Return a base64 encoded representation of string according to the
+;;> official base64 standard as described in RFC3548.
+
 (define (base64-encode-string str)
-  (let* ((len (string-length str))
+  (utf8->string (base64-encode-bytevector (string->utf8 str))))
+
+(define (base64-encode-bytevector bv)
+  (let* ((len (bytevector-length bv))
          (quot (quotient len 3))
          (rem (- len (* quot 3)))
          (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2))
-         (res (make-string res-len)))
-    (base64-encode-string! str 0 len res)
+         (res (make-bytevector res-len)))
+    (base64-encode-bytevector! bv 0 len res)
     res))
 
-(define (base64-encode-string! str start end res)
-  (let* ((res-len (string-length res))
-         (limit (- end 2)))
+(define (base64-encode-bytevector! bv start end res)
+  (let ((limit (- end 2)))
     (let lp ((i start) (j 0))
       (if (>= i limit)
           (case (- end i)
             ((1)
-             (let ((b1 (char->integer (string-ref str i))))
-               (string-set! res j (enc (arithmetic-shift b1 -2)))
-               (string-set! res
+             (let ((b1 (bytevector-u8-ref bv i)))
+               (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+               (bytevector-u8-set!
+                res
                 (+ j 1)
                 (enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
-               (string-set! res (+ j 2) #\=)
-               (string-set! res (+ j 3) #\=)))
+               (bytevector-u8-set! res (+ j 2) (char->integer #\=))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=))
+               (+ j 4)))
             ((2)
-             (let ((b1 (char->integer (string-ref str i)))
-                   (b2 (char->integer (string-ref str (+ i 1)))))
-               (string-set! res j (enc (arithmetic-shift b1 -2)))
-               (string-set! res
+             (let ((b1 (bytevector-u8-ref bv i))
+                   (b2 (bytevector-u8-ref bv (+ i 1))))
+               (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+               (bytevector-u8-set!
+                res
                 (+ j 1)
                 (enc (bitwise-ior
                       (arithmetic-shift (bitwise-and #b11 b1) 4)
-                                  (extract-bit-field 4 4 b2))))
-               (string-set! res
+                      (bit-field b2 4 8))))
+               (bytevector-u8-set!
+                res
                 (+ j 2)
-                            (enc (arithmetic-shift (extract-bit-field 4 0 b2)
-                                                   2)))
-               (string-set! res (+ j 3) #\=))))
-          (let ((b1 (char->integer (string-ref str i)))
-                (b2 (char->integer (string-ref str (+ i 1))))
-                (b3 (char->integer (string-ref str (+ i 2)))))
-            (string-set! res j (enc (arithmetic-shift b1 -2)))
-            (string-set! res
+                (enc (arithmetic-shift (bit-field b2 0 4) 2)))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=))
+               (+ j 4)))
+            (else
+             j))
+          (let ((b1 (bytevector-u8-ref bv i))
+                (b2 (bytevector-u8-ref bv (+ i 1)))
+                (b3 (bytevector-u8-ref bv (+ i 2))))
+            (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+            (bytevector-u8-set!
+             res
              (+ j 1)
              (enc (bitwise-ior
                    (arithmetic-shift (bitwise-and #b11 b1) 4)
-                               (extract-bit-field 4 4 b2))))
-            (string-set! res
+                   (bit-field b2 4 8))))
+            (bytevector-u8-set!
+             res
              (+ j 2)
              (enc (bitwise-ior
-                               (arithmetic-shift (extract-bit-field 4 0 b2) 2)
-                               (extract-bit-field 2 6 b3))))
-            (string-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
+                   (arithmetic-shift (bit-field b2 0 4) 2)
+                   (bit-field b3 6 8))))
+            (bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
             (lp (+ i 3) (+ j 4)))))))
 
+;;>  Variation of the above to read and write to ports.
+
 (define (base64-encode . o)
   (let ((in (if (pair? o) (car o) (current-input-port)))
         (out (if (and (pair? o) (pair? (cdr o)))
                  (cadr o)
                  (current-output-port))))
-    (let ((src (make-string encode-src-length))
-          (dst (make-string
+    (cond
+     ((not (binary-port? in))
+      (let ((str (port->string in)))
+        (write-string (base64-encode-string str) out)))
+     (else
+      (let ((src (make-bytevector encode-src-length))
+            (dst (make-bytevector
                   (arithmetic-shift (quotient encode-src-length 3) 2))))
         (let lp ()
-        (let ((n (read-string! 2048 src in)))
-          (base64-encode-string! src 0 n dst)
-          (write-string dst out 0 (* 3 (quotient (+ n 3) 4)))
+          (let ((n (read-bytevector! src in 0 2048)))
+            (base64-encode-bytevector! src 0 n dst)
+            (write-bytevector dst out 0 (* 4 (quotient (+ n 2) 3)))
             (if (= n 2048)
-              (lp)))))))
+                (lp)
+                (flush-output-port out)))))))))
+
+;;> Return a base64 encoded representation of the string \var{str} as
+;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
+;;> multiple MIME-header lines as needed to keep each lines length
+;;> less than \var{max-col}.  The string is encoded as is, and the
+;;> encoding \var{enc} is just used for the prefix, i.e. you are
+;;> responsible for ensuring \var{str} is already encoded according to
+;;> \var{enc}.  The optional argument \var{nl} is the newline
+;;> separator, defaulting to \var{crlf}.
 
 (define (base64-encode-header encoding str . o)
   (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2))
@@ -344,7 +364,7 @@
                (string-append
                 prefix (substring str 0 first-max-col) "?=" nl "\t" prefix)
                "")
-           (string-concatenate (string-chop (substring str first-max-col len)
+           (string-join (string-chop (substring str first-max-col len)
                                      effective-max-col)
                         (string-append "?=" nl "\t" prefix))
            "?=")))))

lib/chibi/base64.sld

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

lib/chibi/binary-record-chicken.scm

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

lib/chibi/binary-record-test.sld

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

lib/chibi/binary-record.scm

@@ -0,0 +1,160 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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:)
+    ((defrec () n m p r w
+       ((field-tmp field-read field-read-expr field-write field-write-expr field-get) ...)
+       ((field getter . s) ...)
+       (def-setter ...))
+     (begin
+       (define-record-type n (m field ...) p
+         (field getter . s) ...)
+       (define r
+         (let ((field-read field-read-expr) ...)
+           (lambda (in)
+             (let* ((field-tmp (field-read in)) ...)
+               (m field ...)))))
+       (define w
+         (let ((field-write field-write-expr) ...)
+           (lambda (x out)
+             (field-write (field-get x) out) ...)))
+       def-setter ...)
+     ;; workaround for impls which strip hygiene from top-level defs
+     ;; for some reason, works in chicken but not across libraries
+     ;;
+     ;; (begin
+     ;;   (define-values (n m p getter ... setter ...)
+     ;;     (let ()
+     ;;       (define-record-type n (m field ...) p
+     ;;         (field getter . s) ...)
+     ;;       (def setter val) ...
+     ;;       (values (record-rtd n) m p getter ... setter ...)))
+     ;;   (define r
+     ;;     (let ((field-read field-read-expr) ...)
+     ;;       (lambda (in)
+     ;;         (let* ((field-tmp (field-read in)) ...)
+     ;;           (m field ...)))))
+     ;;   (define w
+     ;;     (let ((field-write field-write-expr) ...)
+     ;;       (lambda (x out)
+     ;;         (field-write (field-get x) out) ...))))
+     )
+    ((defrec ((make: x) . rest) n m p r w b f s)
+     (defrec rest n x p r w b f s))
+    ((defrec ((pred: x) . rest) n m p r w b f s)
+     (defrec rest n m x r w b f s))
+    ((defrec ((read: x) . rest) n m p r w b f s)
+     (defrec rest n m p x w b f s))
+    ((defrec ((write: x) . rest) n m p r w b f s)
+     (defrec rest n m p r x b f s))
+    ((defrec ((block: (field (type . args) getter setter) . fields) . rest) n m p r w b f s)
+     (defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w b f s))
+    ((defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w
+       (b ...) (f ...) (s ...))
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (field read-tmp (type read: args) write-tmp (type write: args) getter))
+       (f ...
+          (field getter tmp-setter))
+       (s ...
+          (define setter
+            (let ((pred? (type pred: args)))
+              (lambda (x val)
+                (if (not (pred? val))
+                    (error "invalid val for" 'field val))
+                (tmp-setter x val)))))))
+    ((defrec ((block: (field (type . args) getter) . fields) . rest) n m p r w
+       (b ...) (f ...) s)
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (field read-tmp (type read: args) write-tmp (type write: args) getter))
+       (f ...
+          (field getter))
+       s))
+    ((defrec ((block: (field . x)) . rest) n m p r w b f s)
+     (syntax-error "invalid field in block" (field . x)))
+    ((defrec ((block: data . fields) . rest) n m p r w (b ...) f s)
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (tmp-data read-tmp (read-literal 'data) write-tmp (write-literal 'data) (lambda (x) x)))
+       f
+       s))
+    ((defrec ((block:) . rest) n m p r w b f s)
+     (defrec rest n m p r w b f s))
+    ))

lib/chibi/binary-record.sld

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

lib/chibi/binary-types.scm

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

lib/chibi/bytevector-test.sld

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

lib/chibi/bytevector.scm

@@ -0,0 +1,146 @@
+
+;;> \section{Additional accessors}
+
+;;> Retrieve a 16-bit unsigned integer value from the given bytevector
+;;> \var{bv} at offset \var{i}, in little-endian order.
+
+(define (bytevector-u16-ref-le bv i)
+  (+ (bytevector-u8-ref bv i)
+     (arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 8)))
+
+;;> Retrieve a 16-bit unsigned integer value from the given bytevector
+;;> \var{bv} at offset \var{i}, in big-endian order.
+
+(define (bytevector-u16-ref-be bv i)
+  (+ (arithmetic-shift (bytevector-u8-ref bv i) 8)
+     (bytevector-u8-ref bv (+ i 1))))
+
+;;> Retrieve a 32-bit unsigned integer value from the given bytevector
+;;> \var{bv} at offset \var{i}, in little-endian order.
+
+(define (bytevector-u32-ref-le bv i)
+  (+ (bytevector-u8-ref bv i)
+     (arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 8)
+     (arithmetic-shift (bytevector-u8-ref bv (+ i 2)) 16)
+     (arithmetic-shift (bytevector-u8-ref bv (+ i 3)) 24)))
+
+;;> Retrieve a 32-bit unsigned integer value from the given bytevector
+;;> \var{bv} at offset \var{i}, in big-endian order.
+
+(define (bytevector-u32-ref-be bv i)
+  (+ (arithmetic-shift (bytevector-u8-ref bv i) 24)
+     (arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 16)
+     (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
+;;> the base-256 big-endian form (the zero index holds the MSB).
+
+(define (integer->bytevector n)
+  (cond
+   ((zero? n)
+    (make-bytevector 1 0))
+   ((negative? n)
+    (error "can't convert a negative integer to bytevector" n))
+   (else
+    (let lp ((n n) (res '()))
+      (if (zero? n)
+          (let* ((len (length res))
+                 (bv (make-bytevector len 0)))
+            (do ((i 0 (+ i 1))
+                 (ls res (cdr ls)))
+                ((= i len) bv)
+              (bytevector-u8-set! bv i (car ls))))
+          (lp (quotient n 256) (cons (remainder n 256) res)))))))
+
+;;> The inverse of \scheme{integer->bytevector}.  Convert a bytevector
+;;> representing the base-256 big-endian form (the zero index holds
+;;> the MSB) to the corresponding unsigned integer.
+
+(define (bytevector->integer bv)
+  (let ((len (bytevector-length bv)))
+    (let lp ((i 0) (n 0))
+      (if (>= i len)
+          n
+          (lp (+ i 1)
+              (+ (arithmetic-shift n 8)
+                 (bytevector-u8-ref bv i)))))))
+
+;;> Utility to pad a bytevector with zeros.  Padding is added to the
+;;> left so as not to change the big-endian value.
+
+(define (bytevector-pad-left bv len)
+  (let ((diff (- len (bytevector-length bv))))
+    (if (positive? diff)
+        (bytevector-append bv (make-bytevector diff 0))
+        bv)))
+
+;;> \section{Hex string conversion}
+
+;;> Big-endian conversion, guaranteed padded to even length.
+
+(define (integer->hex-string n)
+  (let* ((res (number->string n 16))
+         (len (string-length res)))
+    (if (even? len)
+        res
+        (string-append "0" res))))
+
+(define (hex-string->integer str)
+  (string->number str 16))
+
+(define (bytevector->hex-string bv)
+  (let ((out (open-output-string))
+        (len (bytevector-length bv)))
+    (let lp ((i 0))
+      (cond
+       ((>= i len)
+        (get-output-string out))
+       (else
+        (write-string (integer->hex-string (bytevector-u8-ref bv i)) out)
+        (lp (+ i 1)))))))
+
+(define (hex-string->bytevector str)
+  (integer->bytevector (hex-string->integer str)))

lib/chibi/bytevector.sld

@@ -0,0 +1,41 @@
+
+;;> Additional bytevector utilities.
+
+(define-library (chibi bytevector)
+  (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-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")
+  (cond-expand
+   (chibi
+    (import (except (scheme bytevector) bytevector-copy!)))
+   (else
+    (include "ieee-754.scm"))))

lib/chibi/channel.scm

@@ -26,7 +26,7 @@
       (set-cdr! rear new))
      (else  ; sending to empty channel
       (channel-front-set! chan new)
-      (condition-variable-signal! (channel-condvar chan)))))
+      (condition-variable-broadcast! (channel-condvar chan)))))
   (mutex-unlock! (channel-mutex chan)))
 
 (define (channel-receive! chan)

lib/chibi/channel.sld

@@ -1,6 +1,9 @@
 
 (define-library (chibi channel)
-  (import (chibi) (srfi 9) (srfi 18))
+  (cond-expand
+   (chibi (import (chibi) (srfi 9)))
+   (else (import (scheme base))))
+  (import (srfi 18))
   (export Channel make-channel channel? channel-empty?
           channel-send! channel-receive!)
   (include "channel.scm"))

lib/chibi/char-set.sld

@@ -1,9 +1,12 @@
 
+;;> A minimal character set library.
+
 (define-library (chibi char-set)
-  (import (chibi) (chibi char-set base) (chibi char-set extras))
+  (import (chibi char-set base) (chibi char-set extras))
   (export
    Char-Set char-set? char-set-contains?
    char-set ucs-range->char-set char-set-copy char-set-size
+   char-set-fold char-set-for-each
    list->char-set char-set->list string->char-set char-set->string
    char-set-adjoin! char-set-adjoin char-set-union char-set-union!
    char-set-intersection char-set-intersection!

lib/chibi/char-set/ascii.scm

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

lib/chibi/char-set/ascii.sld

@@ -1,11 +1,9 @@
 
 (define-library (chibi char-set ascii)
-  (import (chibi) (chibi iset base))
-  (export char-set-contains?
-          char-set:lower-case  char-set:upper-case  char-set:title-case
+  (import (chibi) (chibi iset base) (chibi char-set base))
+  (export char-set:lower-case  char-set:upper-case  char-set:title-case
           char-set:letter      char-set:digit       char-set:letter+digit
           char-set:graphic     char-set:printing    char-set:whitespace
           char-set:iso-control char-set:punctuation char-set:symbol
-          char-set:hex-digit   char-set:blank       char-set:ascii
-          char-set:empty       char-set:full)
+          char-set:hex-digit   char-set:blank)
   (include "ascii.scm"))

lib/chibi/char-set/base.sld

@@ -1,14 +1,23 @@
 
 (define-library (chibi char-set base)
-  (import (chibi) (chibi iset base))
+  (cond-expand
+   (chibi
+    (import (chibi))
+    (begin
+      (define-syntax immutable-char-set
+        (sc-macro-transformer
+         (lambda (expr use-env)
+           (eval (cadr expr) use-env))))))
+   (else
+    (import (scheme base))
+    (begin
+      (define-syntax immutable-char-set
+       (syntax-rules () ((immutable-char-set cs) cs))))))
+  (import (chibi iset base))
   (export (rename Integer-Set Char-Set)
           (rename iset? char-set?)
           immutable-char-set
           char-set-contains?)
   (begin
-    (define-syntax immutable-char-set
-      (sc-macro-transformer
-       (lambda (expr use-env)
-         (eval (cadr expr) use-env))))
     (define (char-set-contains? cset ch)
       (iset-contains? cset (char->integer ch)))))

lib/chibi/char-set/boundary.sld

@@ -0,0 +1,29 @@
+;; Character sets for Unicode boundaries, TR29.
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+;;> Char-sets used for
+;;> \hyperlink["http://unicode.org/reports/tr29/"]{TR29} word
+;;> boundaries.
+
+(define-library (chibi char-set boundary)
+  (cond-expand
+   (chibi (import (chibi)))
+   (else (import (scheme base))))
+  (cond-expand
+   ((library (chibi char-set)) (import (chibi char-set)))
+   (else
+    (import (srfi 14))
+    (begin (define (immutable-char-set cs) cs))))
+  (export char-set:regional-indicator
+          char-set:extend-or-spacing-mark
+          char-set:hangul-l
+          char-set:hangul-v
+          char-set:hangul-t
+          char-set:hangul-lv
+          char-set:hangul-lvt)
+  ;; generated with:
+  ;; tools/extract-unicode-props.scm --derived GraphemeBreakProperty.txt
+  ;;   Control extend-or-spacing-mark=Extend,SpacingMark Regional_Indicator
+  ;;   hangul-l=:L hangul-v=:V hangul-t=:T hangul-lv=:LV hangul-lvt=:LVT
+  (include "boundary.scm"))

lib/chibi/char-set/extras.scm

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

lib/chibi/char-set/extras.sld

@@ -1,9 +1,13 @@
 
 (define-library (chibi char-set extras)
-  (import (chibi) (chibi iset) (chibi char-set base))
+  (cond-expand
+   (chibi (import (chibi)))
+   (else (import (scheme base))))
+  (import (chibi iset) (chibi char-set base))
   (include "extras.scm")
   (export
    char-set ucs-range->char-set char-set-copy char-set-size
+   char-set-fold char-set-for-each
    list->char-set char-set->list string->char-set char-set->string
    char-set-adjoin! char-set-adjoin char-set-union char-set-union!
    char-set-intersection char-set-intersection!

lib/chibi/config.scm

@@ -0,0 +1,511 @@
+;; config.scm -- general configuration management
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> This is a library for unified configuration management.
+;;> Essentially it provides an abstract collection data type for
+;;> looking up named values, two or more of which can be chained
+;;> together.  Values from more recent collections can be preferred as
+;;> with an environment, or the values at multiple levels can be
+;;> flattened together.  Convenience routines are provided from
+;;> loading these collections from files while allowing extensions
+;;> such as configurations from command-line options.
+
+;;> \section{Background}
+;;>
+;;> As any application grows to sufficient complexity, it acquires
+;;> options and behaviors that one may want to modify at startup or
+;;> runtime.  The traditional approach is a combination of
+;;> command-line options, config files, environment variables, and/or
+;;> other specialized settings.  These all have various pros and cons:
+;;>
+;;> \table[(@ (border 1) (style border-collapse:collapse) (width "100%"))]{
+;;> \tr{\th{name} \th{pros} \th{cons}}
+;;> \tr{\td{environment variables}
+;;>     \td{implicit - no need to retype; can share between applications}
+;;>     \td{unclear when set; unexpected differences between users; limited size}}
+;;> \tr{\td{command-line options}
+;;>     \td{explicit - visible each time a command is run; }
+;;>     \td{verbose; limited size}}
+;;> \tr{\td{config files}
+;;>     \td{implicit; preserved - can be shared and version controlled}
+;;>     \td{requires a parser}}
+;;> }
+;;>
+;;> Environment variables are convenient for broad preferences, used
+;;> by many different applications, and unlikely to change per user.
+;;> Command-line options are best for settings that are likely to
+;;> change between invocations of a program.  Anything else is best
+;;> stored in a config file.  If there are settings that multiple
+;;> users of a group or whole system are likely to want to share, then
+;;> it makes sense to cascade multiple config files.
+
+;;> \section{Syntax}
+;;>
+;;> With any other language there is a question of config file syntax,
+;;> and a few popular choices exist such as .ini syntax.  With Scheme
+;;> the obvious choice is sexps, generally as an alist.  We use a
+;;> single alist for the whole file, with symbols for keys and
+;;> arbitrary sexps for values.  The alists are intended primarily for
+;;> editing by hand and need not be dotted, but the interface allows
+;;> dotted values.  Disambiguation is handled as with two separate
+;;> functions, \scheme{(conf-get config key)} and
+;;> \scheme{(conf-get-list config key)}, which both retrieve the value
+;;> associated with \var{key} from \var{config}, in the latter case
+;;> coercing to a list.  The result is determined according to the
+;;> structure of the alist cell as follows:
+;;>
+;;> \table[(@ (border 1) (style border-collapse:collapse) (width "100%"))]{
+;;> \tr{\th{Cell} \th{\scheme{conf-get} result} \th{\scheme{conf-get-list} result}}
+;;> \tr{\td{\scheme{(key)}} \td{\scheme{()}} \td{\scheme{()}}}
+;;> \tr{\td{\scheme{(key . non-list-value)}} \td{\scheme{non-list-value}} \td{\scheme{(non-list-value)}}}
+;;> \tr{\td{\scheme{(key non-list-value)}} \td{\scheme{non-list-value}} \td{\scheme{(non-list-value)}}}
+;;> \tr{\td{\scheme{(key (value1 value2 ...))}} \td{\scheme{(value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}}}
+;;> \tr{\td{\scheme{(key value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}}}
+;;> }
+;;>
+;;> Thus writing the non-dotted value will always do what you want.
+;;> Specifically, the only thing to be careful of is if you want a
+;;> single-element list value, even with \scheme{conf-get}, you should
+;;> write \scheme{(key (value))}.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Interface}
+
+;;> Returns true iff \var{x} is a config object.
+
+(define-record-type Config
+  (%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)
+         (if (and (pair? (car ls)) (eq? key (caar ls)))
+             ls
+             (lp (cdr ls))))))
+
+(define (assq-chain key alist)
+  (let ((x (assq-tail (car key) alist)))
+    (and x
+         (if (null? (cdr key))
+             (car x)
+             (or (assq-chain (cdr key) (cdar x))
+                 (assq-chain key (cdr x)))))))
+
+(define (assq-split key alist)
+  (let lp ((ls alist) (rev '()))
+    (cond
+     ((null? ls) #f)
+     ((and (pair? (car ls)) (eq? key (caar ls))) (cons (reverse rev) ls))
+     (else (lp (cdr ls) (cons (car ls) rev))))))
+
+(define (read-from-file file . 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)
+  (and (list? x) (every pair? x)))
+
+;;> \procedure{(assoc-get alist key [equal? [default]])}
+
+;;> Utility analogous to \scheme{conf-get} on a pure alist.  Returns
+;;> the value of the cell in \var{alist} whose car is \var{equal?} to
+;;> \var{key}, where the value is determined as the \var{cadr} if the
+;;> cell is a proper list of two elements and the \var{cdr} otherwise.
+;;> If no cell is found, returns \var{default}, or \scheme{#f} if
+;;> unspecified.
+
+(define (assoc-get alist key . o)
+  (let ((equal (or (and (pair? o) (car o)) equal?)))
+    (let lp ((ls alist))
+      (cond
+       ((not (pair? ls)) (and (pair? o) (pair? (cdr o)) (cadr o)))
+       ((and (pair? (car ls)) (equal key (caar ls)))
+        (if (and (pair? (cdar ls)) (null? (cdr (cdar ls))))
+            (car (cdar ls))
+            (cdar ls)))
+       (else (lp (cdr ls)))))))
+
+;;> \procedure{(assoc-get-list alist key [default])}
+
+;;> Equivalent to \scheme{assoc-get} but coerces its result to a list
+;;> as described in the syntax section.
+
+(define (assoc-get-list alist key . o)
+  (let ((res (assoc-get alist key)))
+    (if res
+        (if (or (pair? res) (null? res)) res (list res))
+        (if (pair? o) (car o) '()))))
+
+;;> Returns just the base of \var{config} without any parent.
+
+(define (conf-head config)
+  (make-conf
+   (conf-alist config) #f (conf-source config) (conf-timestamp config)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Loading from files.
+
+;;> \procedure{(conf-load file [conf])}
+
+;;> Loads the config file \var{file}, prepending to \var{conf} if
+;;> provided.
+
+(define (conf-load file . o)
+  (make-conf
+   (read-from-file file '())
+   (and (pair? o) (car o))
+   file
+   (current-second)))
+
+;;> Search for and load any files named \var{file} in the
+;;> \var{config-path}, which should be a list of strings.
+
+(define (conf-load-in-path config-path file)
+  (cond
+   ((equal? file "")
+    (error "can't load from empty filename" file))
+   ((eqv? #\/ (string-ref file 0))
+    (conf-load file))
+   (else
+    (let lp ((ls (reverse config-path)) (res #f))
+      (if (null? ls)
+          (or res (make-conf '() #f #f (current-second)))
+          (let ((path (string-append (car ls) "/" file)))
+            (if (file-exists? path)
+                (lp (cdr ls) (conf-load path res))
+                (lp (cdr ls) res))))))))
+
+;;> \procedure{(conf-load-cascaded config-path file [include-keyword])}
+
+;;> Similar to conf-load-in-path, but also recursively loads any
+;;> "include" config files, indicated by a top-level
+;;> \var{include-keyword} with either a string or symbol value.
+;;> Includes are loaded relative to the current file, and cycles
+;;> automatically ignored.
+
+(define (conf-load-cascaded config-path file . o)
+  (define (path-directory file)
+    (let lp ((i (string-length file)))
+      (cond ((zero? i) "./")
+            ((eqv? #\/ (string-ref file (- i 1))) (substring file 0 i))
+            (else (lp (- i 1))))))
+  (define (path-relative file from)
+    (if (eqv? #\/ (string-ref file 0))
+        file
+        (string-append (path-directory from) file)))
+  (let ((include-keyword (if (pair? o) (car o) 'include)))
+    (let load ((ls (list (cons file (and (pair? o) (pair? (cdr o)) (cadr o)))))
+               (seen '())
+               (res '()))
+      (cond
+       ((null? ls)
+        res)
+       (else
+        (let ((file (if (symbol? (caar ls))
+                        (symbol->string (caar ls))
+                        (caar ls)))
+              (depth (cdar ls)))
+          (cond
+           ((member file seen)
+            (load (cdr ls) seen res))
+           ((and (number? depth) (<= depth 0))
+            (load (cdr ls) seen res))
+           (else
+            (let* ((config (conf-load-in-path config-path file))
+                   (includes (conf-get-list config include-keyword)))
+              (load (append (cdr ls)
+                            (map (lambda (x)
+                                   (cons (path-relative x file)
+                                         (and (number? depth) (- depth 1))))
+                                 includes))
+                    (cons file seen)
+                    (append res config)))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (conf-get-cell config key)
+  (cond
+   ((pair? key)
+    (cond
+     ((null? (cdr key)) (conf-get-cell config (car key)))
+     ((assq-chain key (conf-alist config)))
+     ((conf-parent config) => (lambda (p) (conf-get-cell p key)))
+     (else #f)))
+   (else
+    (let search ((config config))
+      (and config
+           (or (assq key (conf-alist config))
+               (search (conf-parent config))))))))
+
+;;> \procedure{(conf-get config key [default])}
+
+;;> Basic config lookup - retrieves the value from \var{config}
+;;> associated with \var{key}.  If not present, return \var{default}.
+;;> In \scheme{conf-get} and related accessors \var{key} can be either
+;;> a symbol, or a list of symbols.  In the latter case, each symbol
+;;> is used as a key in turn, with the value taken as an alist to
+;;> further lookup values in.
+
+(define (conf-get config key . opt)
+  (let ((cell (conf-get-cell config key)))
+    (if (not cell)
+        (and (pair? opt) (car opt))
+        (if (and (pair? (cdr cell)) (null? (cddr cell)))
+            (cadr cell)
+            (cdr cell)))))
+
+;;> \procedure{(conf-get-list config key [default])}
+
+;;> Equivalent to \scheme{conf-get} but coerces its result to a list
+;;> as described in the syntax section.
+
+(define (conf-get-list config key . opt)
+  (let ((res (conf-get config key)))
+    (if res
+        (if (or (pair? res) (null? res)) res (list res))
+        (if (pair? opt) (car opt) '()))))
+
+;;> Equivalent to \scheme{conf-get} but always returns the
+;;> \scheme{cdr} as-is without possibly taking its \scheme{car}.
+
+(define (conf-get-cdr config key . opt)
+  (let ((cell (conf-get-cell config key)))
+    (if (not cell)
+        (and (pair? opt) (car opt))
+        (cdr cell))))
+
+;;> Equivalent to \scheme{conf-get-list} but returns a list of all
+;;> cascaded configs appended together.
+
+(define (conf-get-multi config key)
+  (if (not config)
+      '()
+      (append (conf-get-list (conf-head config) key)
+              (conf-get-multi (conf-parent config) key))))
+
+;;> Extends the config with anadditional alist.
+
+(define (conf-extend config alist . o)
+  (let ((source (and (pair? o) (car o))))
+    (if (pair? alist)
+        (make-conf alist config source (current-second))
+        config)))
+
+;;> Joins two configs.
+
+(define (conf-append a b)
+  (let ((parent (if (conf-parent a) (conf-append (conf-parent a) b) b)))
+    (make-conf (conf-alist a) parent (conf-source a) (conf-timestamp a))))
+
+;;> Utility to create an alist cell representing the chained key
+;;> \var{key} mapped to \var{value}.
+
+(define (conf-unfold-key key value)
+  (if (null? (cdr key))
+      (cons (car key) value)
+      (list (car key) (conf-unfold-key (cdr key) value))))
+
+;;> Replace a new definition into the first config alist.
+
+(define (conf-set config key value)
+  (make-conf
+   (let lp ((key (if (not (list? key)) (list key) key))
+            (alist (conf-alist config)))
+     (cond
+      ((null? (cdr key))
+       (cons (cons (car key) value)
+             (remove (lambda (x) (and (pair? x) (eq? (car key) (car x))))
+                     alist)))
+      ((assq-split (car key) alist)
+       => (lambda (x)
+            (let ((left (car x))
+                  (right (cdr x)))
+              (append left
+                      (cons (cons (car key) (lp (cdr key) (cdar right)))
+                            (cdr right))))))
+      (else
+       (cons (conf-unfold-key key value) alist))))
+   (conf-parent config)
+   (conf-source config)
+   (conf-timestamp config)))
+
+;;> Lift specialized sections to the top-level of a config.
+
+(define (conf-specialize config key name)
+  (let lp ((cfg config) (res '()))
+    (if (not cfg)
+        (make-conf (reverse res) config #f (current-second))
+        (let* ((specialized (assq key (conf-alist cfg)))
+               (named (and specialized (assq name (cdr specialized))))
+               (next (conf-parent cfg)))
+          (if named
+              (lp next (cons (cdr named) res))
+              (lp next res))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Config Verification}
+
+(define (conf-default-warn . args)
+  (for-each
+   (lambda (a) ((if (string? a) display write) a (current-error-port)))
+   args)
+  (newline (current-error-port))
+  #f)
+
+(define (conf-verify-symbol->predicate sym)
+  (case sym
+    ((integer) integer?)
+    ((number) number?)
+    ((list) list?)
+    ((alist) alist?)
+    ((boolean) boolean?)
+    ((char) char?)
+    ((string) string?)
+    ((symbol) symbol?)
+    ((pair) pair?)
+    ((filename dirname) string?)
+    (else (error "no known conf predicate for" sym))))
+
+;; non-short-circuit versions to report all warnings
+
+(define (and* . args)
+  (every (lambda (x) x) args))
+
+(define (every* pred ls)
+  (apply and* (map pred ls)))
+
+(define (conf-verify-match def cell warn)
+  (define (cell-value)
+    (if (and (pair? (cdr cell)) (null? (cddr cell))) (cadr cell) (cdr cell)))
+  (define (cell-list)
+    (if (and (pair? (cdr cell)) (null? (cddr cell)) (not (pair? (cadr cell))))
+        (list (cadr cell))
+        (cdr cell)))
+  (cond
+   ((procedure? def)
+    (or (def (cell-value))
+        (warn "bad conf value for " (car cell) ": " (cell-value))))
+   ((symbol? def)
+    (case def
+      ((existing-filename)
+       (cond
+        ((not (string? (cell-value)))
+         (warn "bad conf value for " (car cell)
+               ": expected a filename but got " (cell-value)))
+        ((not (file-exists? (cell-value)))
+         (warn "conf setting ~S references a non-existent file: ~S"
+               (car cell) (cell-value)))
+        (else
+         #t)))
+      ((existing-dirname)
+       (cond
+        ((not (string? (cell-value)))
+         (warn "bad conf value for " (car cell)
+               ": expected a dirname but got " (cell-value)))
+        ((not (file-directory? (cell-value)))
+         (cond
+          ((file-exists? (cell-value))
+           (warn "conf setting " (car cell)
+                 " expected a directory but found a file: " (cell-value)))
+          (else
+           (warn "conf setting " (car cell)
+                 " references a non-existent directory: " (cell-value)))))
+        (else
+         #t)))
+      ((integer number char string symbol filename dirname boolean pair)
+       (or ((conf-verify-symbol->predicate def) (cell-value))
+           (warn "bad conf value for " (car cell)
+                 ": expected " def " but got " (cell-value))))
+      ((list alist)
+       (or ((conf-verify-symbol->predicate def) (cell-list))
+           (warn "bad conf value for " (car cell)
+                 ": expected " def " but got " (cell-list))))
+      (else
+       (warn "bad conf spec list: " def))))
+   ((pair? def)
+    (case (car def)
+      ((cons)
+       (and*
+        (conf-verify-match
+         (cadr def) (cons `(car ,(car cell)) (car (cell-list))) warn)
+        (conf-verify-match
+         (car (cddr def)) (cons `(car ,(car cell)) (cdr (cell-list))) warn)))
+      ((list)
+       (and (list? (cell-list))
+            (every* (lambda (x)
+                      ;; (cons `(list ,(car cell)) x)
+                      (conf-verify-match (cadr def) x warn))
+                    (cell-list))))
+      ((alist)
+       (let ((key-def (cadr def))
+             (val-def (if (pair? (cddr def)) (car (cddr def)) (lambda (x) #t))))
+         (and (alist? (cell-list))
+              (every* (lambda (x)
+                        (and (pair? x)
+                             (conf-verify-match key-def (car x) warn)
+                             (conf-verify-match val-def (cell-value) warn)))
+                      (cell-list)))))
+      ((conf)
+       (and (alist? (cell-list))
+            (conf-verify (cdr def) (list (cell-list)) warn)))
+      ((or)
+       (or (any (lambda (x) (conf-verify-match x cell (lambda (x) x)))
+                (cdr def))
+           (warn "bad spec value for " (car cell)
+                 ": expected " def " but got " (cell-value))))
+      ((member)
+       (or (member (cell-value) (cdr def))
+           (warn "bad spec value " (cell-value)
+                 " for " (car cell) ", expected one of " (cdr def))))
+      ((quote)
+       (or (equal? (cadr def) (cell-value))
+           (warn "bad conf value for " (car cell)
+                 ": expected '" (cadr def) " but got " (cell-value))))
+      (else
+       (warn "bad conf list spec name: " (car def)))))
+   (else
+    (or (equal? def (cell-value))
+        (warn "bad conf value for " (car cell)
+              ": expected " def " but got " (cell-value))))))
+
+(define (conf-verify-one spec cell warn)
+  (cond
+   ((not (pair? cell))
+    (warn "bad config entry: " cell))
+   ((not (symbol? (car cell)))
+    (warn "non-symbol config entry name: " (car cell)))
+   (else
+    (let ((def (assq (car cell) spec)))
+      (cond
+       ((not def)
+        (warn "unknown config entry: " (car cell)))
+       ((null? (cdr def)))
+       (else (conf-verify-match (cadr def) cell warn)))))))
+
+(define (conf-verify spec config . o)
+  (let ((warn (if (pair? o) (car o) conf-default-warn)))
+    (let lp ((config config))
+      (cond
+       (config
+        (for-each
+         (lambda (cell) (conf-verify-one spec cell warn))
+         (conf-alist config))
+        (lp (conf-parent config)))))))