Merge pull request #1022 from MikeSS8/typo

fix typo

.gitignore

@@ -47,6 +47,7 @@ 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
@@ -62,6 +63,7 @@ lib/srfi/160/uvprims.c
 *.err
 *.fasl
 *.txt
+!CMakeLists.txt
 *.test
 *.train
 *.h5

AUTHORS

@@ -32,38 +32,57 @@ They are not installed or needed but are included for convenience.
 
 Thanks to the following people for patches and bug reports:
 
+  * Adam Feuer
   * Alan Watson
   * Alexei Lozovsky
   * Alexander Shendi
   * Andreas Rottman
+  * Arthur Gleckler
   * Bakul Shah
+  * Ben Davenport-Ray
   * Ben Mather
   * Ben Weaver
   * Bertrand Augereau
+  * Bradley Lucier
   * Bruno Deferrari
+  * Damien Diederen
+  * Daphne Preston-Kendal
   * Doug Currie
   * Derrick Eddington
   * Dmitry Chestnykh
   * Eduardo Cavazos
+  * Ekaitz Zarraga
   * Felix Winkelmann
   * Gregor Klinke
   * Jeremy Wolff
   * Jeronimo Pellegrini
   * John Cowan
   * John Samsa
+  * Jonas Rinke
   * Kris Katterjohn
   * Lars J Aas
+  * Lassi Kortela
   * Lorenzo Campedelli
+  * Lukas Böger
   * Marc Nieper-Wißkirchen
+  * McKay Marston
   * Meng Zhang
   * Michal Kowalski (sladegen)
   * Miroslav Urbanek
+  * Naoki Koguro
+  * Nguyễn Thái Ngọc Duy
+  * Petteri Piiroinen
   * Rajesh Krishnan
+  * Ricardo G. Herdt
+  * Roger Crew
   * Seth Alves
+  * Sören Tempel
   * Stephen Lewis
   * Taylor Venable
   * Travis Cross
+  * Vasilij Schneidermann
   * Vitaliy Mysak
+  * Yota Toyama
   * Yuki Okumura
 
 If you would prefer not to be listed, or are one of the users listed

CMakeLists.txt

@@ -1,33 +1,28 @@
-#
-# FIXME: This CMakeLists.txt is only for Win32 platforms for now
-#
 
-cmake_minimum_required(VERSION 2.8.7)
+cmake_minimum_required(VERSION 3.12)
-project(chibi-scheme)
 
-include(CheckIncludeFile)
+file(READ ${CMAKE_CURRENT_SOURCE_DIR}/VERSION version)
-
+string(STRIP ${version} version)
-#
-# Version setting
-#
 
 file(READ ${CMAKE_CURRENT_SOURCE_DIR}/RELEASE release)
 string(STRIP ${release} release)
 
-file(READ ${CMAKE_CURRENT_SOURCE_DIR}/VERSION rawversion)
+project(chibi-scheme LANGUAGES C VERSION ${version}
-string(STRIP ${rawversion} rawversion)
+    DESCRIPTION "Chibi-Scheme: minimal r7rs implementation, release: ${release}")
-set(version "${rawversion}-cmake")
 
-set(chibischemelib "chibi-scheme-${rawversion}")
+include(CheckIncludeFile)
+include(CheckSymbolExists)
+include(GNUInstallDirs)
+include(CMakePackageConfigHelpers)
 
-if(APPLE)
+set(CMAKE_EXPORT_COMPILE_COMMANDS ON)
-    message(FATAL_ERROR 
-        "DYLD platforms are not supported with this CMakeLists.txt. Use Makefile instead.")
-endif()
 
-if(UNIX)
+set(CMAKE_BUILD_TYPE "${CMAKE_BUILD_TYPE}" CACHE STRING
-    message(FATAL_ERROR 
+    "Build type: None, Debug, Release, RelWithDebInfo, MinSizeRel, or Sanitizer." FORCE)
-        "UNIX platforms are not supported with this CMakeLists.txt. Use Makefile instead.")
+
+if (NOT EXISTS ${CMAKE_BINARY_DIR}/CMakeCache.txt AND NOT CMAKE_BUILD_TYPE)
+    # CMake doesn't have a default build type, so set one manually
+    set(CMAKE_BUILD_TYPE "RelWithDebInfo" CACHE STRING "" FORCE)
 endif()
 
 #
@@ -35,33 +30,25 @@ endif()
 #
 
 check_include_file(poll.h HAVE_POLL_H)
-check_include_file(stdint.h HAVE_STDINT_H)
+check_symbol_exists(ntp_gettime sys/timex.h HAVE_NTP_GETTIME)
-# option(CHIBI_SCHEME_USE_DL "Use dynamic loading" ON)
+check_symbol_exists(int_least8_t inttypes.h HAVE_STDINT_H)
-set(CHIBI_SCHEME_USE_DL OFF)
-option(CHIBI_SCHEME_SHARED "Build chibi-scheme as a shared library" ON)
 
-if(NOT CHIBI_SCHEME_SHARED)
+if (WIN32 AND NOT CYGWIN)
-    add_definitions(-DSEXP_STATIC_LIBRARY=1)
+    set(DEFAULT_SHARED_LIBS OFF)
-endif()
-
-if(CHIBI_SCHEME_USE_DL)
-    add_definitions(-DSEXP_USE_DL=1)
 else()
-    add_definitions(-DSEXP_USE_DL=0)
+    set(DEFAULT_SHARED_LIBS ON)
 endif()
 
-if(HAVE_STDINT_H)
+option(BUILD_SHARED_LIBS "Build chibi-scheme as a shared library" ${DEFAULT_SHARED_LIBS})
-    add_definitions(-DSEXP_USE_INTTYPES=1)
+option(SEXP_USE_BOEHM "Use Boehm garbage collection library" OFF)
-endif()
 
-if(NOT HAVE_POLL_H)
+if(SEXP_USE_BOEHM)
-    # Disable green threads: It depends on non-blocking I/O
+    find_library(BOEHMGC gc REQUIRED)
-    add_definitions(-DSEXP_USE_GREEN_THREADS=0)
+    find_path(BOEHMGC_INCLUDE NAMES gc/gc.h)
 endif()
 
 set(chibi-scheme-exclude-modules)
 if(WIN32)
-    add_definitions(-DBUILDING_DLL)
     set(chibi-scheme-exclude-modules
         # Following modules are not compatible with Win32
         lib/chibi/net.sld
@@ -72,6 +59,48 @@ if(WIN32)
         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
 #
@@ -89,65 +118,163 @@ set(chibi-scheme-srcs
     eval.c
     simplify.c)
 
-include_directories(
-    include
-    ${CMAKE_CURRENT_BINARY_DIR}/include)
-
 #
 # Bootstrap
 #
 
 add_executable(chibi-scheme-bootstrap
+    EXCLUDE_FROM_ALL
     ${chibi-scheme-srcs}
     main.c)
 
-if(WIN32)
+target_link_libraries(chibi-scheme-bootstrap PRIVATE libchibi-common)
-    target_link_libraries(chibi-scheme-bootstrap ws2_32)
+
-endif()
+
+#
+# Core library
+#
+
+add_library(libchibi-scheme
+    ${chibi-scheme-srcs})
+
+target_link_libraries(libchibi-scheme
+    PUBLIC libchibi-common)
+
+set_target_properties(libchibi-scheme
+    PROPERTIES
+    PREFIX "" # It's liblibchibi-scheme otherwise
+    SOVERSION ${CMAKE_PROJECT_VERSION_MAJOR}
+    VERSION ${CMAKE_PROJECT_VERSION})
 
-if(CYGWIN OR WIN32)
-    set(soext ".dll")
-else()
-    set(soext ".so")
-endif()
 
 #
 # Generate modules
 #
 
-# FIXME: Currently, it depends on GLOB thus we have to re-run CMake
-#        when we've gotten additional/removed library 
-
-file(GLOB_RECURSE stubs RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib 
-    ${CMAKE_CURRENT_SOURCE_DIR}/lib/*.stub)
 file(GLOB_RECURSE slds RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}
-    ${CMAKE_CURRENT_SOURCE_DIR}/lib/*.sld)
+    CONFIGURE_DEPENDS lib/*.sld)
+if (chibi-scheme-exclude-modules)
+    # CMake doesn't complain anymore about an empty 2nd argument, but 3.12 does. When we require a
+    # more recent version, the if-guard should go.
     list(REMOVE_ITEM slds ${chibi-scheme-exclude-modules})
+endif()
 
 set(chibi-ffi ${CMAKE_CURRENT_SOURCE_DIR}/tools/chibi-ffi)
 set(chibi-genstatic ${CMAKE_CURRENT_SOURCE_DIR}/tools/chibi-genstatic)
 
-set(stuboutdir ${CMAKE_CURRENT_BINARY_DIR}/stubs/lib)
+add_custom_target(chibi-compiled-libs)
-foreach(e ${stubs})
+
-    get_filename_component(stubdir ${e} PATH)
+function(add_compiled_library cfile)
-    get_filename_component(basename ${e} NAME_WE)
+    if (NOT BUILD_SHARED_LIBS)
-    set(stubfile ${CMAKE_CURRENT_SOURCE_DIR}/lib/${e})
+        return()
-    set(stubdir ${stuboutdir}/${stubdir})
+    endif()
+
+    set(link-libraries LINK_LIBRARIES)
+    cmake_parse_arguments(compiledlib-options "" "" "${link-libraries}" ${ARGN})
+
+    get_filename_component(basename ${cfile} NAME_WE)
+    get_filename_component(libdir ${cfile} DIRECTORY)
+
+    if(NOT IS_ABSOLUTE ${libdir})
+        set(libdir ${CMAKE_CURRENT_BINARY_DIR}/${libdir})
+    endif()
+
+    file(RELATIVE_PATH libname ${CMAKE_CURRENT_BINARY_DIR} ${libdir}/${basename})
+    string(REPLACE "/" "-" libname ${libname})
+
+    add_library(${libname} ${cfile})
+    target_link_libraries(${libname} PRIVATE libchibi-scheme ${compiledlib-options_LINK_LIBRARIES})
+    add_dependencies(chibi-compiled-libs ${libname})
+
+    set_target_properties(${libname} PROPERTIES
+        LIBRARY_OUTPUT_DIRECTORY ${libdir}
+        LIBRARY_OUTPUT_NAME ${basename}
+        PREFIX "")
+
+    file(RELATIVE_PATH installsubdir ${CMAKE_CURRENT_BINARY_DIR}/lib ${libdir})
+    install(TARGETS ${libname}
+        LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}/chibi/${installsubdir})
+endfunction()
+
+if(BUILD_SHARED_LIBS)
+    # This makes sure we only use the separate bootstrap executable for static
+    # builds. With dynamic linking, the default executable is fine. The dispatch
+    # is not a generator expression within the actual custom command to process
+    # the stubs, as older CMake versions fail to properly construct the dependency
+    # on the bootstrap executable from the generator expression.
+    set(bootstrap chibi-scheme)
+else()
+    set(bootstrap chibi-scheme-bootstrap)
+endif()
+
+function(add_stubs_library stub)
+    set(link-libraries LINK_LIBRARIES)
+    cmake_parse_arguments(stubs-options "" "" "${link-libraries}" ${ARGN})
+
+    get_filename_component(stubdir ${stub} PATH)
+    get_filename_component(basename ${stub} NAME_WE)
+    set(stubfile ${CMAKE_CURRENT_SOURCE_DIR}/${stub})
+    set(stubdir ${CMAKE_CURRENT_BINARY_DIR}/${stubdir})
     set(stubout ${stubdir}/${basename}.c)
+    set(stubouts ${stubouts} ${stubout} PARENT_SCOPE)
+    set(stublinkedlibs ${stublinkedlibs} ${stubs-options_LINK_LIBRARIES} PARENT_SCOPE)
+
     file(MAKE_DIRECTORY ${stubdir})
+
     add_custom_command(OUTPUT ${stubout}
-        COMMAND chibi-scheme-bootstrap
+        COMMAND ${bootstrap} ${chibi-ffi} ${stubfile} ${stubout}
-        ${chibi-ffi} ${stubfile} ${stubout}
         DEPENDS ${stubfile} ${chibi-ffi}
         WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
-    list(APPEND stubouts ${stubout})
+
-endforeach()
+    add_compiled_library(${stubout} LINK_LIBRARIES ${stubs-options_LINK_LIBRARIES})
+endfunction()
+
+add_stubs_library(lib/chibi/crypto/crypto.stub)
+add_stubs_library(lib/chibi/emscripten.stub)
+add_stubs_library(lib/chibi/filesystem.stub)
+add_stubs_library(lib/chibi/io/io.stub)
+add_stubs_library(lib/scheme/bytevector.stub)
+add_stubs_library(lib/srfi/144/math.stub)
+add_stubs_library(lib/srfi/160/uvprims.stub)
+
+if(NOT WIN32)
+    add_stubs_library(lib/chibi/net.stub)
+    add_stubs_library(lib/chibi/process.stub)
+    add_stubs_library(lib/chibi/pty.stub LINK_LIBRARIES util)
+    add_stubs_library(lib/chibi/stty.stub)
+    add_stubs_library(lib/chibi/system.stub)
+    add_stubs_library(lib/chibi/time.stub)
+else()
+    add_stubs_library(lib/chibi/win32/process-win32.stub)
+endif()
+
 add_custom_target(chibi-scheme-stubs DEPENDS ${stubouts})
 
+if (NOT BUILD_SHARED_LIBS)
+    add_dependencies(libchibi-scheme chibi-scheme-stubs)
+endif()
+
+add_compiled_library(lib/chibi/weak.c)
+add_compiled_library(lib/chibi/heap-stats.c)
+add_compiled_library(lib/chibi/disasm.c)
+add_compiled_library(lib/chibi/ast.c)
+add_compiled_library(lib/chibi/json.c)
+add_compiled_library(lib/srfi/18/threads.c)
+add_compiled_library(lib/chibi/optimize/rest.c)
+add_compiled_library(lib/chibi/optimize/profile.c)
+add_compiled_library(lib/srfi/27/rand.c)
+add_compiled_library(lib/srfi/151/bit.c)
+add_compiled_library(lib/srfi/39/param.c)
+add_compiled_library(lib/srfi/69/hash.c)
+add_compiled_library(lib/srfi/95/qsort.c)
+add_compiled_library(lib/srfi/98/env.c)
+add_compiled_library(lib/scheme/time.c)
+
 #
 # Generate clib.c for SEXP_USE_STATIC_LIBS
 #
 
+if (NOT BUILD_SHARED_LIBS)
     string(REPLACE ";" "\n" genstatic-input "${slds}")
     set(clibin ${CMAKE_CURRENT_BINARY_DIR}/clib-in.txt)
     set(clibout ${CMAKE_CURRENT_BINARY_DIR}/clib.c)
@@ -170,87 +297,75 @@ add_custom_command(OUTPUT ${clibout}
         ${genstatic-helper}
         ${slds})
 
-#
+    # The generated file will #include both manually written files in
-# Core library
+    # 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})
 
-if(CHIBI_SCHEME_SHARED)
+    target_compile_definitions(libchibi-scheme
-    set(libtype SHARED)
+        PUBLIC
-else()
+        SEXP_USE_STATIC_LIBS=1)
-    set(libtype STATIC)
-endif()
 
-add_library(${chibischemelib} ${libtype}
+    target_sources(libchibi-scheme
-    ${chibi-scheme-srcs}
+        PRIVATE
         ${clibout})
 
-set_target_properties(${chibischemelib}
+    target_link_libraries(libchibi-scheme
-    PROPERTIES 
+        PRIVATE
-    COMPILE_DEFINITIONS "SEXP_USE_STATIC_LIBS=1")
+        ${stublinkedlibs})
-
-add_dependencies(${chibischemelib} chibi-scheme-stubs)
-
-if(WIN32 AND CHIBI_SCHEME_SHARED)
-    target_link_libraries(${chibischemelib} ws2_32)
-    target_compile_definitions(${chibischemelib} PUBLIC -DBUILDING_DLL=1)
 endif()
 
-function(bless_chibi_scheme_executable tgt)
-    target_link_libraries(${tgt} ${chibischemelib})
-    if(WIN32 AND NOT CHIBI_SCHEME_SHARED)
-        target_link_libraries(${tgt} ws2_32)
-    endif()
-endfunction()
-
 #
 # Interpreter
 #
 
-include_directories(
-    .
-    ${stuboutdir}/..)
 add_executable(chibi-scheme
     main.c)
 
-bless_chibi_scheme_executable(chibi-scheme)
+target_link_libraries(chibi-scheme
+    PRIVATE libchibi-scheme)
 
 #
 # Generate "chibi/install.h"
 #
 
-if(CYGWIN OR WIN32)
-    set(thePrefix "bin")
-else()
-    set(thePrefix "lib")
-endif()
-
-if(WIN32)
-    set(pathsep "\\;")
-else()
-    set(pathsep ":")
-endif()
-
 if(WIN32)
     set(platform "windows")
+elseif(CYGWIN)
+    set(platform "cygwin")
+elseif(APPLE)
+    set(platform "macosx")
+elseif(CMAKE_SYSTEM MATCHES "[Bb][Ss][Dd]")
+    set(platform "bsd")
+elseif(CMAKE_SYSTEM MATCHES "[Aa]ndroid")
+    set(platform "android")
+elseif(CMAKE_SYSTEM MATCHES "[Ss]un[Oo][Ss]")
+    set(platform "solaris")
+elseif (CMAKE_SYSTEM MATCHES "[Ll]inux")
+    set(platform "linux")
 else()
-    set(platform "unknown")
+    set(platform "unix")
 endif()
 
+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()
 
-set(default_module_path
+configure_file(include/chibi/install.h.in include/chibi/install.h)
-    ""
-    #"${CMAKE_INSTALL_PREFIX}/${thePrefix}${pathsep}${CMAKE_INSTALL_PREFIX}/bin"
-    )
-
-file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/include/chibi)
-
-file(WRITE
-    ${CMAKE_CURRENT_BINARY_DIR}/include/chibi/install.h
-    "#define sexp_so_extension \"${soext}\"
-#define sexp_default_module_path \"${default_module_path}\"
-#define sexp_platform \"${platform}\"
-#define sexp_version \"\"
-#define sexp_release_name \"${release}\"")
 
 #
 # Testing
@@ -260,28 +375,27 @@ enable_testing()
 
 set(chibi-scheme-tests
     r7rs-tests
-    ## Not connected
+    division-tests
-    #division-tests
+    syntax-tests
-    #r5rs-tests
+    unicode-tests)
-    #syntax-tests
-    #unicode-tests
-    ## Require threads
-    # lib-tests
-    )
 
 foreach(e ${chibi-scheme-tests})
     add_test(NAME "${e}"
-        COMMAND chibi-scheme tests/${e}.scm
+        COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib tests/${e}.scm
         WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
 endforeach()
 
+add_test(NAME r5rs-test
+    COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib -xchibi tests/r5rs-tests.scm
+    WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+
 file(GLOB_RECURSE srfi_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
-    ${CMAKE_CURRENT_SOURCE_DIR}/lib/srfi/*/test.sld)
+    CONFIGURE_DEPENDS lib/srfi/*/test.sld)
 
 file(GLOB_RECURSE chibi_scheme_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
-    ${CMAKE_CURRENT_SOURCE_DIR}/lib/chibi/*-test.sld)
+    CONFIGURE_DEPENDS lib/chibi/*-test.sld)
 
-set(testexcludes
+set(win32testexcludes
     # Excluded tests
     chibi/filesystem-test
     chibi/memoize-test
@@ -296,21 +410,25 @@ set(testexcludes
     chibi/tar-test # Depends (chibi system)
     chibi/process-test # Not applicable
     chibi/pty-test # Depends (chibi pty)
+    chibi/shell-test # Depends Linux procfs
     )
 
-set(testlibs)
 foreach(e ${srfi_tests} ${chibi_scheme_tests})
     get_filename_component(pth ${e} PATH)
     get_filename_component(nam ${e} NAME_WE)
     list(APPEND testlibs ${pth}/${nam})
 endforeach()
-list(REMOVE_ITEM testlibs ${testexcludes})
+
+if(WIN32)
+    list(REMOVE_ITEM testlibs ${win32testexcludes})
+endif()
 
 foreach(e ${testlibs})
     string(REGEX REPLACE "/" "_" testname ${e})
     string(REGEX REPLACE "/" " " form ${e})
     add_test(NAME "lib_${testname}"
-        COMMAND chibi-scheme -e "(import (${form}))"
+        COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib
+        -e "(import (${form}))"
         -e "(run-tests)"
         WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
 endforeach()
@@ -322,7 +440,8 @@ endforeach()
 add_executable(test-foreign-apply-loop
     tests/foreign/apply-loop.c)
 
-bless_chibi_scheme_executable(test-foreign-apply-loop)
+target_link_libraries(test-foreign-apply-loop
+    PRIVATE libchibi-scheme)
 
 add_test(NAME "foreign-apply-loop"
     COMMAND test-foreign-apply-loop
@@ -331,8 +450,154 @@ add_test(NAME "foreign-apply-loop"
 add_executable(test-foreign-typeid
     tests/foreign/typeid.c)
 
-bless_chibi_scheme_executable(test-foreign-typeid)
+target_link_libraries(test-foreign-typeid
+    PRIVATE libchibi-scheme)
 
 add_test(NAME "foreign-typeid"
     COMMAND test-foreign-typeid
     WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR})
+
+
+#
+# Image, pkgconfig and meta file generation
+#
+
+add_custom_command(OUTPUT chibi.img
+    COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib -mchibi.repl
+    -d ${CMAKE_CURRENT_BINARY_DIR}/chibi.img
+    WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+add_custom_command(OUTPUT red.img
+    COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib -xscheme.red -mchibi.repl
+    -d ${CMAKE_CURRENT_BINARY_DIR}/red.img
+    WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+add_custom_command(OUTPUT snow.img
+    COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib
+        -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils
+        -d ${CMAKE_CURRENT_BINARY_DIR}/snow.img
+    WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+
+if(BUILD_SHARED_LIBS)
+    # Currently, image dumps only work with shared library builds, which includes Windows
+    add_custom_target(chibi-images ALL
+        DEPENDS
+        ${CMAKE_CURRENT_BINARY_DIR}/chibi.img
+        ${CMAKE_CURRENT_BINARY_DIR}/red.img
+        ${CMAKE_CURRENT_BINARY_DIR}/snow.img
+        # The dependency on libchibi-scheme is crucial here:
+        chibi-compiled-libs)
+endif()
+
+configure_file(contrib/chibi-scheme.pc.cmake.in chibi-scheme.pc @ONLY)
+
+function(generate_package_list libdir output)
+    add_custom_command(OUTPUT ${output}
+        COMMAND
+        ${CMAKE_COMMAND}
+        -DEXEC=$<TARGET_FILE:chibi-scheme>
+        -DLIBDIR=${libdir}
+        -DGENMETA=tools/generate-install-meta.scm
+        -DVERSION=${CMAKE_PROJECT_VERSION}
+        -DOUT=${CMAKE_CURRENT_BINARY_DIR}/${output}
+        -P contrib/chibi-generate-install-meta-helper.cmake
+        WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
+        DEPENDS
+        chibi-scheme
+        tools/generate-install-meta.scm
+        contrib/chibi-generate-install-meta-helper.cmake)
+endfunction()
+
+generate_package_list(lib/chibi .chibi.meta)
+generate_package_list(lib/scheme .scheme.meta)
+generate_package_list(lib/srfi .srfi.meta)
+
+add_custom_target(chibi-meta-lists ALL
+    DEPENDS
+    ${CMAKE_CURRENT_BINARY_DIR}/.chibi.meta
+    ${CMAKE_CURRENT_BINARY_DIR}/.scheme.meta
+    ${CMAKE_CURRENT_BINARY_DIR}/.srfi.meta)
+
+
+#
+# Installation
+#
+
+install(DIRECTORY include/chibi
+    DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}
+    PATTERN "sexp-*.[hc]" EXCLUDE
+    PATTERN "*.h.in" EXCLUDE)
+
+install(FILES ${CMAKE_CURRENT_BINARY_DIR}/include/chibi/install.h
+    DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}/chibi)
+
+install(FILES ${CMAKE_CURRENT_BINARY_DIR}/chibi-scheme.pc
+    DESTINATION ${CMAKE_INSTALL_LIBDIR}/pkgconfig)
+
+add_library(chibi::libchibi-scheme ALIAS libchibi-scheme)
+
+install(TARGETS libchibi-scheme libchibi-common chibi-scheme
+    EXPORT chibi-scheme-targets
+    RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}
+    LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}
+    ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR})
+
+install(FILES
+    tools/chibi-ffi
+    tools/chibi-doc
+    tools/snow-chibi
+    tools/snow-chibi.scm
+    DESTINATION ${CMAKE_INSTALL_BINDIR})
+
+install(FILES
+    doc/chibi-scheme.1
+    doc/chibi-ffi.1
+    doc/chibi-doc.1
+    DESTINATION ${CMAKE_INSTALL_MANDIR}/man1)
+
+if(BUILD_SHARED_LIBS)
+    install(FILES
+        ${CMAKE_CURRENT_BINARY_DIR}/chibi.img
+        ${CMAKE_CURRENT_BINARY_DIR}/red.img
+        ${CMAKE_CURRENT_BINARY_DIR}/snow.img
+        DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi)
+endif()
+
+install(DIRECTORY
+    lib/
+    DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi
+    PATTERN "*win32" EXCLUDE
+    PATTERN "*test.sld" EXCLUDE
+    PATTERN "*.c" EXCLUDE
+    PATTERN "*.stub" EXCLUDE)
+
+# This is to revert the above exclusion pattern
+install(FILES lib/chibi/test.sld
+    DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi/chibi)
+
+if(WIN32)
+    install(DIRECTORY
+        lib/
+        DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi
+        FILES_MATCHING
+        PATTERN "*win32/*.scm"
+        PATTERN "*win32/*.sld")
+endif()
+
+install(FILES
+    ${CMAKE_CURRENT_BINARY_DIR}/.chibi.meta
+    ${CMAKE_CURRENT_BINARY_DIR}/.scheme.meta
+    ${CMAKE_CURRENT_BINARY_DIR}/.srfi.meta
+    DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/chibi)
+
+install(EXPORT chibi-scheme-targets
+    FILE chibi-scheme-targets.cmake
+    NAMESPACE chibi::
+    DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/chibi)
+
+write_basic_package_version_file(chibi-scheme-config-version.cmake
+    VERSION ${CMAKE_PROJECT_VERSION}
+    COMPATIBILITY ExactVersion)
+
+install(FILES
+    contrib/chibi-scheme-config.cmake
+    ${CMAKE_CURRENT_BINARY_DIR}/chibi-scheme-config-version.cmake
+    DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/chibi)

CONTRIBUTING.md

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

COPYING

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

Makefile

@@ -1,6 +1,6 @@
 # -*- makefile-gmake -*-
 
-.PHONY: dist mips-dist cleaner test test-all test-dist checkdefs debian snowballs init-dev
+.PHONY: dist mips-dist cleaner distclean dist-clean test test-all test-dist checkdefs debian snowballs init-dev
 .DEFAULT_GOAL := all
 
 CHIBI_VERSION ?= $(shell cat VERSION)
@@ -11,7 +11,7 @@ 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
 
@@ -46,12 +46,14 @@ COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
 BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
 INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h
 
-MODULE_DOCS := app ast base64 bytevector config crypto/md5 crypto/rsa \
+MODULE_DOCS := app assert ast base64 binary-record bytevector config \
-	crypto/sha2 diff disasm doc edit-distance equiv filesystem generic \
+	crypto/md5 crypto/rsa crypto/sha2 diff disasm doc edit-distance \
-	heap-stats io iset/base iset/constructors iset/iterators json loop \
+	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 \
-	parse pathname process repl scribble string stty sxml system temp-file \
+	optional parse pathname process repl scribble string stty sxml system \
-	test time trace type-inference uri weak monad/environment crypto/sha2
+	temp-file test time trace type-inference uri weak monad/environment \
+	crypto/sha2 shell
 
 IMAGE_FILES = lib/chibi.img lib/red.img lib/snow.img
 
@@ -79,23 +81,32 @@ js/chibi.js: chibi-scheme-emscripten chibi-scheme-static.bc js/pre.js js/post.js
 	emcc -O0 chibi-scheme-static.bc -o $@ -s ALLOW_MEMORY_GROWTH=1 -s MODULARIZE=1 -s EXPORT_NAME=\"Chibi\" -s EXPORTED_FUNCTIONS=@js/exported_functions.json `find  lib -type f \( -name "*.scm" -or -name "*.sld" \) -printf " --preload-file %p"` -s 'EXTRA_EXPORTED_RUNTIME_METHODS=["ccall", "cwrap"]' --pre-js js/pre.js --post-js js/post.js
 
 chibi-scheme-static.bc:
-	emmake $(MAKE) PLATFORM=emscripten CHIBI_DEPENDENCIES= CHIBI=./chibi-scheme-emscripten PREFIX= CFLAGS=-O2 SEXP_USE_DL=0 EXE=.bc SO=.bc CPPFLAGS="-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1 -DSEXP_USE_ALIGNED_BYTECODE=1 -DSEXP_USE_STATIC_LIBS=1 -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0" clibs.c chibi-scheme-static.bc
+	emmake $(MAKE) PLATFORM=emscripten CHIBI_DEPENDENCIES= CHIBI=./chibi-scheme-emscripten PREFIX= CFLAGS=-O2 SEXP_USE_DL=0 EXE=.bc SO=.bc STATICFLAGS=-shared CPPFLAGS="-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1 -DSEXP_USE_ALIGNED_BYTECODE=1 -DSEXP_USE_STATIC_LIBS=1 -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0" clibs.c chibi-scheme-static.bc VERBOSE=1
 
 chibi-scheme-emscripten: VERSION
-	$(MAKE) dist-clean
+	$(MAKE) distclean
 	$(MAKE) chibi-scheme-static PLATFORM=emscripten SEXP_USE_DL=0
 	(tempfile="`mktemp -t chibi.XXXXXX`" && \
 	mv chibi-scheme-static$(EXE) "$$tempfile" && \
-	$(MAKE) dist-clean; \
+	$(MAKE) distclean; \
 	mv "$$tempfile" chibi-scheme-emscripten)
 
-include/chibi/install.h: Makefile
+include/chibi/install.h: Makefile.libs Makefile.detect
 	echo '#define sexp_so_extension "'$(SO)'"' > $@
 	echo '#define sexp_default_module_path "'$(MODDIR):$(BINMODDIR):$(SNOWMODDIR):$(SNOWBINMODDIR)'"' >> $@
 	echo '#define sexp_platform "'$(PLATFORM)'"' >> $@
+	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 $@ $<
 
@@ -131,13 +142,17 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
 	$(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 -ldl -lutil
+	$(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 -ldl -lutil
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) $(STATIC_LDFLAGS)
 
 clibs.c: $(GENSTATIC) $(CHIBI_DEPENDENCIES) $(COMPILED_LIBS:%$(SO)=%.c)
-	$(GIT) ls-files lib | $(GREP) .sld | $(CHIBI) -q $(GENSTATIC) > $@
+	if [ -d .git ]; then \
+		$(GIT) ls-files lib | $(GREP) .sld | $(CHIBI) -q $(GENSTATIC) > $@; \
+	else \
+		$(FIND) lib -name \*.sld | $(CHIBI) -q $(GENSTATIC) > $@; \
+	fi
 
 chibi-scheme.pc: chibi-scheme.pc.in
 	echo "# pkg-config" > chibi-scheme.pc
@@ -206,6 +221,7 @@ lib/chibi/show/width.scm: build-lib/chibi/char-set/width.scm chibi-scheme$(EXE)
 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 > $@
 
@@ -260,13 +276,16 @@ test-r5rs: chibi-scheme$(EXE)
 test-r7rs: chibi-scheme$(EXE)
 	$(CHIBI) tests/r7rs-tests.scm
 
+test-syntax: chibi-scheme$(EXE)
+	$(CHIBI) tests/syntax-tests.scm
+
 test: test-r7rs
 
 test-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-libs test-ffi test-division
+test-all: test test-syntax test-libs test-ffi test-division
 
 test-dist: test-all test-memory test-build
 
@@ -290,7 +309,8 @@ cleaner: clean
 	    js/chibi.* \
 	    $(shell $(FIND) lib -name \*.o)
 
-dist-clean: dist-clean-libs cleaner
+distclean: dist-clean-libs cleaner
+dist-clean: distclean
 
 install-base: all
 	$(MKDIR) $(DESTDIR)$(BINDIR)
@@ -299,10 +319,10 @@ install-base: all
 	$(INSTALL) -m0755 tools/chibi-doc $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 tools/snow-chibi $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 tools/snow-chibi.scm $(DESTDIR)$(BINDIR)/
-	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term
+	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(MODDIR)/chibi/text
 	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
 	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
-	$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(MODDIR)/srfi/146 
+	$(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/
@@ -321,6 +341,7 @@ install-base: all
 	$(INSTALL) -m0644 lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
 	$(INSTALL) -m0644 lib/chibi/snow/*.sld lib/chibi/snow/*.scm $(DESTDIR)$(MODDIR)/chibi/snow/
 	$(INSTALL) -m0644 lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
+	$(INSTALL) -m0644 lib/chibi/text/*.sld lib/chibi/text/*.scm $(DESTDIR)$(MODDIR)/chibi/text/
 	$(INSTALL) -m0644 lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
 	$(INSTALL) -m0644 lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
 	$(INSTALL) -m0644 lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/
@@ -349,10 +370,15 @@ install-base: all
 	$(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/
@@ -387,14 +413,14 @@ install-base: all
 	$(INSTALL) -m0644 doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
 	$(INSTALL) -m0644 doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
 	$(INSTALL) -m0644 doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
-	-if type $(LDCONFIG) >/dev/null 2>/dev/null; then $(LDCONFIG); fi
+	-if type $(LDCONFIG) >/dev/null 2>/dev/null; then $(LDCONFIG) >/dev/null 2>/dev/null; fi
 
 install: install-base
 ifneq "$(IMAGE_FILES)" ""
 	echo "Generating images"
-	-cd / && LD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(DESTDIR)$(MODDIR):$(DESTDIR)$(BINMODDIR)" $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) -d $(DESTDIR)$(MODDIR)/chibi.img
+	-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.repl -d $(MODDIR)/chibi.img
-	-cd / && LD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(DESTDIR)$(MODDIR):$(DESTDIR)$(BINMODDIR)" $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) -xscheme.red -d $(DESTDIR)$(MODDIR)/red.img
+	-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -xscheme.red -mchibi.repl -d $(MODDIR)/red.img
-	-cd / && LD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(DESTDIR)$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(DESTDIR)$(MODDIR):$(DESTDIR)$(BINMODDIR)" $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils -d $(DESTDIR)$(MODDIR)/snow.img
+	-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils -d $(DESTDIR)$(MODDIR)/snow.img
 endif
 
 uninstall:
@@ -434,6 +460,7 @@ uninstall:
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(BINMODDIR)/chibi/snow
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/text $(DESTDIR)$(BINMODDIR)/chibi/text
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/time $(DESTDIR)$(BINMODDIR)/scheme/time
@@ -459,21 +486,26 @@ uninstall:
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(BINMODDIR)/srfi/143
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(BINMODDIR)/srfi/151
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(BINMODDIR)/srfi/144
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(BINMODDIR)/srfi/146
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(BINMODDIR)/srfi/159
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(BINMODDIR)/srfi/160
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(BINMODDIR)/srfi/166
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/179 $(DESTDIR)$(BINMODDIR)/srfi/179
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/211 $(DESTDIR)$(BINMODDIR)/srfi/211
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/231 $(DESTDIR)$(BINMODDIR)/srfi/231
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
 	-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
 	-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
 	-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
 
-dist: dist-clean
+dist: distclean
 	$(RM) chibi-scheme-$(CHIBI_VERSION).tgz
 	$(MKDIR) chibi-scheme-$(CHIBI_VERSION)
 	@for f in `git ls-files | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-$(CHIBI_VERSION)/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-$(CHIBI_VERSION)/$$f; done
 	$(TAR) cphzvf chibi-scheme-$(CHIBI_VERSION).tgz chibi-scheme-$(CHIBI_VERSION)
 	$(RM) -r chibi-scheme-$(CHIBI_VERSION)
 
-mips-dist: dist-clean
+mips-dist: distclean
 	$(RM) chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`.tgz
 	$(MKDIR) chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`
 	@for f in `git ls-files | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`/$$f; done
@@ -492,9 +524,11 @@ snowballs:
 	$(SNOW_CHIBI) package --license public-domain lib/chibi/match.sld
 	$(SNOW_CHIBI) package -r lib/chibi/char-set.sld
 	$(SNOW_CHIBI) package -r lib/chibi/iset.sld lib/chibi/iset/optimize.sld
-	$(SNOW_CHIBI) package -r --doc https://srfi.schemers.org/srfi-166/srfi-166.html lib/srfi/166.sld lib/chibi/show/shared.sld
+	$(SNOW_CHIBI) package --doc https://srfi.schemers.org/srfi-115/srfi-115.html --test-library lib/srfi/115.sld
-	$(SNOW_CHIBI) package --doc https://srfi.schemers.org/srfi-115/srfi-115.html 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

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
@@ -51,12 +52,17 @@ 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
@@ -93,6 +99,7 @@ CLINKFLAGS = -shared
 CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DSEXP_USE_GREEN_THREADS=0 -DSEXP_USE_GC_FILE_DESCRIPTORS=0 -DBUILDING_DLL
 LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
 STATICFLAGS =
+STATIC_LDFLAGS = -lm -ldl
 LIBDL = -lws2_32
 else
 ifeq ($(PLATFORM),msys)
@@ -103,6 +110,7 @@ CLIBFLAGS =
 CLINKFLAGS = -shared
 CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
 LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATIC_LDFLAGS = -lm -ldl
 else
 ifeq ($(PLATFORM),cygwin)
 SO  = .dll
@@ -112,6 +120,7 @@ CLIBFLAGS =
 CLINKFLAGS = -shared
 CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
 LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATIC_LDFLAGS = -lm -ldl
 else
 SO  = .so
 EXE =
@@ -126,6 +135,10 @@ endif
 endif
 endif
 
+ifeq ($(PLATFORM),emscripten)
+STATIC_LDFLAGS = -lm -ldl
+endif
+
 ifeq ($(PLATFORM),unix)
 #RLDFLAGS=-rpath $(LIBDIR)
 RLDFLAGS=-Wl,-R$(LIBDIR)

Makefile.libs

@@ -27,22 +27,36 @@ FIND      ?= find
 SYMLINK   ?= ln -s
 LDCONFIG  ?= ldconfig
 
-PREFIX    ?= /usr/local
+# gnu coding standards
-BINDIR    ?= $(PREFIX)/bin
+prefix      ?= /usr/local
-LIBDIR    ?= $(PREFIX)/lib
+PREFIX      ?= $(prefix)
-SOLIBDIR  ?= $(LIBDIR)
+exec_prefix ?= $(PREFIX)
-INCDIR    ?= $(PREFIX)/include/chibi
+bindir      ?= $(exec_prefix)/bin
-MODDIR    ?= $(PREFIX)/share/chibi
+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    ?= $(PREFIX)/share/man/man1
+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       ?=
 
 ########################################################################
@@ -53,7 +67,7 @@ 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) $<

README.md

@@ -2,7 +2,7 @@
 
 **Minimal Scheme Implementation for use as an Extension Language**
 
-http://synthcode.com/wiki/chibi-scheme
+https://github.com/ashinn/chibi-scheme
 
 Chibi-Scheme is a very small library intended for use as an extension
 and scripting language in C programs.  In addition to support for
@@ -16,7 +16,7 @@ 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 seemless Unicode support
+* full and seamless Unicode support
 * low-level and high-level hygienic macros
 * an extensible module system
 
@@ -27,7 +27,7 @@ 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 and OS X, Plan 9, Windows, iOS, Android,
+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.
@@ -50,7 +50,11 @@ to install the binaries and libraries.  You can optionally specify a
 By default files are installed in **/usr/local**.
 
 If you want to try out chibi-scheme without installing, be sure to set
-`LD_LIBRARY_PATH` so it can find the shared libraries.
+`LD_LIBRARY_PATH` (`DYLD_LIBRARY_PATH` on macOS) so it can find the
+shared libraries.
+
+To make the emscripten build run `make js` (_not_ `emmake make js`).
 
 For more detailed documentation, run `make doc` and see the generated
-*doc/chibi.html*.
+*doc/chibi.html* or read the [manual](http://synthcode.com/scheme/chibi/)
+online.

RELEASE

@@ -1 +1 @@
-fluoride
+sodium

VERSION

@@ -1 +1 @@
-0.9.1
+0.11.0

bignum.c

@@ -999,8 +999,8 @@ sexp sexp_complex_sub (sexp ctx, sexp a, sexp b) {
   sexp_gc_var2(res, tmp);
   sexp_gc_preserve2(ctx, res, tmp);
   tmp = sexp_complex_copy(ctx, b);
-  sexp_negate(sexp_complex_real(tmp));
+  sexp_negate_maybe_ratio(sexp_complex_real(tmp));
-  sexp_negate(sexp_complex_imag(tmp));
+  sexp_negate_maybe_ratio(sexp_complex_imag(tmp));
   res = sexp_complex_add(ctx, a, tmp);
   sexp_gc_release2(ctx);
   return res;
@@ -1110,7 +1110,7 @@ sexp sexp_complex_sqrt (sexp ctx, sexp z) {
   r = sqrt(x*x + y*y);
   res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
   sexp_complex_real(res) = sexp_make_flonum(ctx, sqrt((x+r)/2));
-  sexp_complex_imag(res) = sexp_make_flonum(ctx, ((y<0||(y==0&&1/y<0))?-1:1)*sqrt((-x+r)/2));
+  sexp_complex_imag(res) = sexp_make_flonum(ctx, ((y<-0.0)?-1:1)*sqrt((-x+r)/2));
   sexp_gc_release1(ctx);
   return res;
 }
@@ -1453,11 +1453,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
     sexp_negate_exact(sexp_ratio_numerator(tmp2));
     r = sexp_ratio_add(ctx, a, tmp2);
     if (negatep) {
-      if (sexp_ratiop(r)) {
+      sexp_negate_maybe_ratio(r);
-        sexp_negate_exact(sexp_ratio_numerator(r));
-      } else {
-        sexp_negate_exact(r);
-      }
     }
     break;
 #endif
@@ -1489,10 +1485,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
     if (negatep) {
       if (sexp_complexp(r)) {
         r = sexp_complex_copy(ctx, r);
-        sexp_negate(sexp_complex_real(r));
+        sexp_negate_maybe_ratio(sexp_complex_real(r));
-        sexp_negate(sexp_complex_imag(r));
+        sexp_negate_maybe_ratio(sexp_complex_imag(r));
       } else {
-        sexp_negate(r);
+        sexp_negate_maybe_ratio(r);
       }
     }
     break;
@@ -1766,6 +1762,9 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
     break;
   case SEXP_NUM_FIX_FIX:
     r = sexp_fx_div(a, b);
+    if ((sexp_sint_t)a < 0 && (sexp_sint_t)b < 0 && (sexp_sint_t)r < 0) {
+      r = sexp_quotient(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
+    }
     break;
   case SEXP_NUM_FIX_BIG:
     r = SEXP_ZERO;
@@ -1868,16 +1867,16 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
   sexp_gc_preserve1(ctx, tmp);
   if (at > bt) {
     r = sexp_compare(ctx, b, a);
-    sexp_negate(r);
+    if (!sexp_exceptionp(r)) { sexp_negate(r); }
   } else {
     switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
     case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
     case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
 #if SEXP_USE_COMPLEX
-    case SEXP_NUM_CPX_CPX: case SEXP_NUM_CPX_FIX:
+    case SEXP_NUM_CPX_CPX: case SEXP_NUM_FIX_CPX:
-    case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG:
+    case SEXP_NUM_FLO_CPX: case SEXP_NUM_BIG_CPX:
 #if SEXP_USE_RATIOS
-    case SEXP_NUM_CPX_RAT:
+    case SEXP_NUM_RAT_CPX:
 #endif
 #endif
       r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
@@ -1886,12 +1885,13 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
       r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b));
       break;
     case SEXP_NUM_FIX_FLO:
-      f = sexp_fixnum_to_double(a);
+      if (isinf(sexp_flonum_value(b))) {
-      g = sexp_flonum_value(b);
+        r = sexp_flonum_value(b) > 0 ? SEXP_NEG_ONE : SEXP_ONE;
-      if (isnan(g))
+      } else if (isnan(sexp_flonum_value(b))) {
         r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
-      else
+      } else {
-        r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
+        r = sexp_compare(ctx, a, tmp=sexp_inexact_to_exact(ctx, NULL, 1, b));
+      }
       break;
     case SEXP_NUM_FIX_BIG:
       if ((sexp_bignum_hi(b) > 1) ||
@@ -1933,8 +1933,7 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
       } else if (isnan(f)) {
         r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
       } else {
-        g = sexp_ratio_to_double(ctx, b);
+        r = sexp_compare(ctx, tmp=sexp_inexact_to_exact(ctx, NULL, 1, a), b);
-        r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
       }
       break;
     case SEXP_NUM_FIX_RAT:
@@ -1945,6 +1944,9 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
       r = sexp_ratio_compare(ctx, a, b);
       break;
 #endif
+    default:
+      r = sexp_xtype_exception(ctx, NULL, "unknown comparison", a);
+      break;
     }
   }
   sexp_gc_release1(ctx);

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

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

contrib/chibi-scheme-config.cmake

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

contrib/chibi-scheme.pc.cmake.in

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

doc/chibi-doc.1

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

doc/chibi-ffi.1

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

doc/chibi-scheme.1

@@ -225,13 +225,17 @@ Loads the Scheme heap from
 .I image-file
 instead of compiling the init file on the fly.
 This feature is still experimental.
+.TP
+.BI -b
+Makes stdio nonblocking (blocking by default). Only available when
+lightweight threads are enabled.
 
 .SH ENVIRONMENT
 .TP
 .B CHIBI_MODULE_PATH
 A colon separated list of directories to search for module
 files, inserted before the system default load paths.  chibi-scheme
-searchs for modules in directories in the following order:
+searches for modules in directories in the following order:
 
 .TP
           directories included with the -I path option
@@ -243,7 +247,13 @@ searchs for modules in directories in the following order:
           directories included with -A path option
 
 If CHIBI_MODULE_PATH is unset, the directories "./lib", and "." are
-search in order.
+searched in order. Set to empty to only consider -I, system
+directories and -A.
+
+.TP
+.B CHIBI_IGNORE_SYSTEM_PATH
+If set to anything but "0", system directories (as listed above) are
+not included in the search paths.
 
 .SH AUTHORS
 .PP

doc/chibi.scrbl

@@ -4,7 +4,7 @@
 \author{Alex Shinn}
 
 \centered{\smaller{Minimal Scheme Implementation for use as an Extension Language}}
-\centered{\url{http://synthcode.com/wiki/chibi-scheme}}
+\centered{\url{https://github.com/ashinn/chibi-scheme}}
 
 \section{Introduction}
 
@@ -28,8 +28,8 @@ standard modules.  You can choose whichever layer suits your needs
 best and customize the rest.  Adding your own primitives or wrappers
 around existing C libraries is easy with the C FFI.
 
-Chibi is known to build and run on 32 and 64-bit Linux, FreeBSD,
+Chibi is known to build and run on 32 and 64-bit Linux, OpenBSD, FreeBSD,
-DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
+DragonFlyBSD, OS X, iOS, Windows (under Cygwin) and Plan9.
 
 \section{Installation}
 
@@ -69,6 +69,13 @@ To compile a static executable, use
 
 \command{make chibi-scheme-static SEXP_USE_DL=0}
 
+Note this static executable has none of the external binary libraries
+included, which means among other things you can't load the
+\scheme{(scheme base)} default language.  You need to specify the
+\scheme{(chibi)} or other Scheme-only language to run:
+
+\command{./chibi-scheme-static -q}
+
 To compile a static executable with all C libraries statically
 included, first you need to create a clibs.c file, which can be done
 with:
@@ -79,7 +86,8 @@ or edited manually.  Be sure to run this with a non-static
 chibi-scheme.  Then you can make the static executable with:
 
 \command{
-make -B chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS
+make -B chibi-scheme-static SEXP_USE_DL=0 \
+  CPPFLAGS="-DSEXP_USE_STATIC_LIBS -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0"
 }
 
 By default files are installed in /usr/local.  You can optionally
@@ -128,6 +136,8 @@ documentation system described in
 build this manual.  \ccode{chibi-ffi} is a tool to build wrappers for
 C libraries, described in the FFI section below.
 
+See the examples directory for some sample programs.
+
 \section{Default Language}
 
 \subsection{Scheme Standard}
@@ -155,13 +165,14 @@ currently unspecified.
 In R7RS (and R6RS) semantics it is impossible to use two macros from
 different modules which both use the same auxiliary keywords (like
 \scheme{else} in \scheme{cond} forms) without renaming one of the
-keywords.  By default Chibi considers all top-level bindings
+keywords.  To minimize conflicts Chibi offers a special module named
-effectively unbound when matching auxiliary keywords, so this case
+\scheme{(auto)} which can export any identifier requested with
-will "just work".  This decision was made because the chance of
+\scheme{only}, e.g. \scheme{(import (only (auto) foo))} will import
-different modules using the same keywords seems more likely than user
+an auxiliary syntax \scheme{foo} binding.  Separate modules can use
-code unintentionally matching a top-level keyword with a different
+this to get the same binding without needing to know about each other
-binding, however if you want to use R7RS semantics you can compile
+in advance.  This is a Chibi-specific extension so is non-portable, but
-with \ccode{SEXP_USE_STRICT_TOPLEVEL_BINDINGS=1}.
+you can always define a static \scheme{(auto)} module exporting a list
+of all known bindings for other implementations.
 
 \scheme{load} is extended to accept an optional environment argument, like
 \scheme{eval}.  You can also \scheme{load} shared libraries in addition to
@@ -222,6 +233,15 @@ These forms perform basic selection and renaming of individual
 identifiers from the given module. They may be composed to perform
 combined selection and renaming.
 
+Note while the repl provides default bindings as a convenience,
+programs have strict semantics as in R7RS and must start with at least
+one import, e.g.
+
+\schemeblock{
+(import (scheme base))
+(write-string "Hello world!\n")
+}
+
 Some modules can be statically included in the initial configuration,
 and even more may be included in image files, however in general
 modules are searched for in a module load path.  The definition of the
@@ -230,7 +250,7 @@ module \scheme{(foo bar baz)} is searched for in the file
 installed directories, \scheme{"."} and \scheme{"./lib"}.  Additional
 directories can be specified with the command-line options \ccode{-I}
 and \ccode{-A} (see the command-line options below) or with the
-\scheme{add-modue-directory} procedure at runtime.  You can search for
+\scheme{add-module-directory} procedure at runtime.  You can search for
 a module file with \scheme{(find-module-file <file>)}, or load it with
 \scheme{(load-module-file <file> <env>)}.
 
@@ -415,7 +435,7 @@ temporary values we may generate, which is what the
 \cmacro{sexp_gc_var2}, \cmacro{sexp_gc_preserve2} and
 \cmacro{sexp_gc_release2} macros do (there are similar macros for
 values 1-6).  Precise GCs prevent a class of memory leaks (and
-potential attackes based thereon), but if you prefer convenience then
+potential attacks based thereon), but if you prefer convenience then
 Chibi can be compiled with a conservative GC and you can ignore these.
 
 The interesting part is then the calls to \cfun{sexp_load},
@@ -682,7 +702,9 @@ need to check manually before applying the predicate.
 \item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer}
 \item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real}
 \item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer}
-\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer}
+\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer (or flonum truncating without loss)}
+\item{\ccode{sexp_ratiop(obj)} - \var{obj} is an exact rational (with SEXP_USE_RATIOS)}
+\item{\ccode{sexp_complexp(obj)} - \var{obj} is a complex number (with SEXP_USE_COMPLEX)}
 \item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number}
 \item{\ccode{sexp_charp(obj)} - \var{obj} is a character}
 \item{\ccode{sexp_stringp(obj)} - \var{obj} is a string}
@@ -778,6 +800,8 @@ once.
 \item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise}
 \item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}}
 \item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer}
+\item{\ccode{sexp_make_flonum(sexp ctx, float f)} - creates a new floating point value}
+\item{\ccode{sexp_flonum_value(obj)} - converts a flonum to a C float}
 \item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}}
 \item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char}
 \item{\ccode{sexp sexp_make_string_cursor(int offset)} - creates a string cursor for the given byte offset}
@@ -810,6 +834,7 @@ Any of these may fail and return the OOM exception object.
 \item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}}
 \item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)}
 \item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements}
+\item{\ccode{sexp_list3(sexp ctx, sexp obj1, sexp obj2, sexp obj3)} - create a list of three elements}
 \item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}}
 \item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}.  If \var{len} is -1, uses strlen(\var{str}).}
 \item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}.  If \var{len} is -1, uses strlen(\var{str}).}
@@ -848,7 +873,7 @@ Any of these may fail and return the OOM exception object.
 \item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}}
 \item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}}
 \item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}}
-\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \scheme{append} for two arguments}
+\item{\ccode{sexp_append2(sexp ctx, sexp ls1, sexp ls2)} - \scheme{append} for two arguments}
 \item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}}
 \item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}}
 \item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}}
@@ -938,16 +963,27 @@ NULL in which case the pointers are never freed, or otherwise a
 procedure of one argument which should release any resources.
 }}
 
-\item{\ccode{sexp sexp_make_cpointer(sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep)}
+\item{\ccode{sexp sexp_make_cpointer(sexp ctx, sexp_uint_t type_tag, void* value, sexp parent, int freep)}
 \p{
-Creates a new instance of the type indicated by type_id wrapping
+Creates a new instance of the type indicated by type_tag wrapping
 value. If parent is provided, references to the child will also
 preserve the parent, important e.g. to preserve an enclosing struct
 when wrapped references to nested structs are still in use.  If freep
 is true, then when reclaimed by the GC the finalizer for this type,
 if any, will be called on the instance.
 
-You can retrieve the id from a type object with sexp_type_tag(type).
+You can retrieve the tag from a type object with sexp_type_tag(type).
+}}
+
+\item{\ccode{sexp sexp_lookup_type(sexp ctx, sexp name, sexp tag_or_id)}
+\p{
+Returns the type whose name matches the string \var{name}.  If
+\var{tag_or_id} is an integer, it is taken as the tag and requires the
+numeric type tag (as from sexp_type_tag) to also match.
+}
+\p{If \var{tag_or_id} is a string, it is taken as the unique id of the
+type, and must match sexp_type_id(type).  However, currently
+sexp_type_id(type) is never set.
 }}
 
 ]
@@ -1238,6 +1274,7 @@ snow-fort):
 \item{\hyperlink["http://srfi.schemers.org/srfi-46/srfi-46.html"]{(srfi 46) - basic syntax-rules extensions}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-55/srfi-55.html"]{(srfi 55) - require-extension}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-62/srfi-62.html"]{(srfi 62) - s-expression comments}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-64/srfi-64.html"]{(srfi 64) - a scheme API for test suites}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-69/srfi-69.html"]{(srfi 69) - basic hash tables}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-95/srfi-95.html"]{(srfi 95) - sorting and merging}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-98/srfi-98.html"]{(srfi 98) - environment access}}
@@ -1272,7 +1309,14 @@ snow-fort):
 \item{\hyperlink["http://srfi.schemers.org/srfi-160/srfi-160.html"]{(srfi 160) - homogeneous numeric vector libraries}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-165/srfi-165.html"]{(srfi 165) - the environment Monad}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-166.html"]{(srfi 166) - monadic formatting}}
-\item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-188.html"]{(srfi 188) - splicing binding constructs for syntactic keywords}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-179/srfi-179.html"]{(srfi 179) - nonempty intervals and generalized arrays}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-188/srfi-188.html"]{(srfi 188) - splicing binding constructs for syntactic keywords}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-193/srfi-193.html"]{(srfi 193) - command-line}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-211/srfi-211.html"]{(srfi 211) - scheme macro libaries}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-219/srfi-219.html"]{(srfi 219) - define higher-order lambda}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-227/srfi-227.html"]{(srfi 227) - optional arguments}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-229/srfi-229.html"]{(srfi 229) - tagged procedures}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-231/srfi-231.html"]{(srfi 231) - intervals and generalized arrays}}
 
 ]
 
@@ -1285,8 +1329,12 @@ namespace.
 
 \item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}}
 
+\item{\hyperlink["lib/chibi/assert.html"]{(chibi assert) - A nicer assert macro}}
+
 \item{\hyperlink["lib/chibi/base64.html"]{(chibi base64) - Base64 encoding and decoding}}
 
+\item{\hyperlink["lib/chibi/binary-record.html"]{(chibi binary-record) - Record types with binary serialization}}
+
 \item{\hyperlink["lib/chibi/bytevector.html"]{(chibi bytevector) - Bytevector Utilities}}
 
 \item{\hyperlink["lib/chibi/config.html"]{(chibi config) - General configuration management}}
@@ -1343,6 +1391,8 @@ namespace.
 
 \item{\hyperlink["lib/chibi/net/servlet.html"]{(chibi net servlet) - HTTP servlets for http-server or CGI}}
 
+\item{\hyperlink["lib/chibi/optional.html"]{(chibi optional) - Syntax to support optional and named keyword arguments}}
+
 \item{\hyperlink["lib/chibi/parse.html"]{(chibi parse) - Parser combinators with convenient syntax}}
 
 \item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}}
@@ -1351,6 +1401,10 @@ namespace.
 
 \item{\hyperlink["lib/chibi/repl.html"]{(chibi repl) - A full-featured Read/Eval/Print Loop}}
 
+\item{\hyperlink["lib/chibi/shell.html"]{(chibi shell) - Process combinators with high-level pipeline syntax in the spirit of SCSH.}}
+
+\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formatting.}}
+
 \item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}}
 
 \item{\hyperlink["lib/chibi/string.html"]{(chibi string) - Cursor-based string library (predecessor to SRFI 130)}}
@@ -1394,7 +1448,9 @@ with image files on your platform you can run
 
 By default \scheme{snow-chibi} looks for packages in the public
 repository \hyperlink["http://snow-fort.org/"]{http://snow-fort.org/},
-though you can customize this with the \scheme{--repository-uri} option.
+though you can customize this with the \scheme{--repository-uri} or
+\scheme{--repo} option (e.g. "http://snow-fort.org/s/repo.scm").
+
 Packages can be browsed on the site, but you can also search and query
 from the command-line tool.
 
@@ -1426,6 +1482,11 @@ older version, a warning is printed.}}
 The basic package management functionality, installing upgrading and
 removing packages.
 
+By default the packages will be managed for Chibi. You can specify
+what Scheme implementation to install, upgrade... with
+\scheme{--implementations} or \scheme{--impls} option. Specify "all"
+to manage all supported implementations.
+
 \itemlist[
 
 \item{install names ... - install packages
@@ -1434,8 +1495,10 @@ use the dotted shorthand.  Explicit names for packages are optional,
 as a package can always be referred to by the name of any library it
 contains.  If multiple packages provide libraries with the same name,
 you will be asked to confirm which implementation to install.}
+
 \p{You can also bypass the repository and install a manually downloaded
-snowball by giving a path to that file instead of a name.}}
+snowball by giving a path to that file instead of a name. No package
+dependencies will be checked for install in this case}}
 
 \item{upgrade names ... - upgrade installed packages
 \p{Upgrade the packages if new versions are available.
@@ -1457,6 +1520,10 @@ update with this command.}}
 Creating packages can be done with the \scheme{package} command,
 though other commands allow for uploading to public repositories.
 
+By default the public repository is
+\hyperlink["http://snow-fort.org/"]{http://snow-fort.org/} but you can
+customize this with the \scheme{--host} option.
+
 \itemlist[
 
 \item{package files ... - create a package
@@ -1554,10 +1621,12 @@ command tells you which you currently have installed.  The following
 are currently supported:
 
 \itemlist[
-\item{chibi - native support as of version 0.7.3}
+\item{chibi - version >= 0.7.3}
 \item{chicken - version >= 4.9.0 with the \scheme{r7rs} egg}
+\item{cyclone - version >= 0.5.3}
 \item{foment - version >= 0.4}
 \item{gauche - version >= 0.9.4}
 \item{kawa - version >= 2.0; you need to add the install dir to the search path, e.g. \scheme{-Dkawa.import.path=/usr/local/share/kawa}}
 \item{larceny - version 0.98; you need to add "lib/Snow" to the paths in startup.sch}
+\item{sagittarius - version >= 0.98}
 ]

eval.c

@@ -45,7 +45,9 @@ void sexp_warn (sexp ctx, const char *msg, sexp x) {
   if (sexp_oportp(out)) {
     sexp_write_string(ctx, strictp ? "ERROR: " : "WARNING: ", out);
     sexp_write_string(ctx, msg, out);
+    if (x != SEXP_UNDEF) {
       sexp_write(ctx, x, out);
+    }
     sexp_write_char(ctx, '\n', out);
     if (strictp) sexp_stack_trace(ctx, out);
   }
@@ -206,7 +208,7 @@ sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
   res = SEXP_NULL;
 #if SEXP_USE_RENAME_BINDINGS
   for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
-    sexp_push(ctx, res, sexp_cadr(ls));
+    sexp_push(ctx, res, sexp_car(ls));
 #endif
   for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
     if (sexp_env_value(ls) != SEXP_UNDEF)
@@ -221,7 +223,7 @@ sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
   e = sexp_alloc_type(ctx, env, SEXP_ENV);
   sexp_env_parent(e) = env;
   sexp_env_bindings(e) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
   sexp_env_renames(e) = SEXP_NULL;
 #endif
   for ( ; sexp_pairp(vars); vars = sexp_cdr(vars))
@@ -241,7 +243,7 @@ sexp sexp_extend_synclo_env (sexp ctx, sexp env) {
       e2 = e2 ? (sexp_env_parent(e2) = sexp_alloc_type(ctx, env, SEXP_ENV)) : e;
       sexp_env_bindings(e2) = sexp_env_bindings(e1);
       sexp_env_syntactic_p(e2) = 1;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
       sexp_env_renames(e2) = sexp_env_renames(e1);
 #endif
     }
@@ -361,6 +363,17 @@ sexp sexp_complete_bytecode (sexp ctx) {
 #if SEXP_USE_FULL_SOURCE_INFO
   if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) {
     sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc));
+    /* omit the leading -1 source marker for the bytecode if the next */
+    /* entry is in the same file */
+    if (sexp_pairp(sexp_cdr(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_car(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cdar(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cadr(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cdr(sexp_cadr(sexp_bytecode_source(bc)))) &&
+        sexp_cadr(sexp_car(sexp_bytecode_source(bc)))
+        == sexp_cadr(sexp_cadr(sexp_bytecode_source(bc)))) {
+      sexp_bytecode_source(bc) = sexp_cdr(sexp_bytecode_source(bc));
+    }
     sexp_bytecode_source(bc) = sexp_list_to_vector(ctx, sexp_bytecode_source(bc));
   }
 #endif
@@ -496,12 +509,12 @@ void sexp_init_eval_context_globals (sexp ctx) {
   sexp_init_eval_context_bytecodes(ctx);
 #endif
   sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL;
-  no_sys_path = getenv(SEXP_NO_SYSTEM_PATH_VAR);
-  if (!no_sys_path || strcmp(no_sys_path, "0")==0)
-    sexp_add_path(ctx, sexp_default_module_path);
   user_path = getenv(SEXP_MODULE_PATH_VAR);
   if (!user_path) user_path = sexp_default_user_module_path;
   sexp_add_path(ctx, user_path);
+  no_sys_path = getenv(SEXP_NO_SYSTEM_PATH_VAR);
+  if (!no_sys_path || strcmp(no_sys_path, "0")==0)
+    sexp_add_path(ctx, sexp_default_module_path);
 #if SEXP_USE_GREEN_THREADS
   sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)
     = sexp_user_exception(ctx, SEXP_FALSE, "I/O would block", SEXP_NULL);
@@ -613,8 +626,7 @@ static int sexp_contains_syntax_p_bound(sexp x, int depth) {
       if (i > 0 && (ls1 == ls2 || ls1 == sexp_car(ls2)))
         return 0; /* cycle, no synclo found, assume none */
     }
-    if (sexp_synclop(ls1))
+    return sexp_contains_syntax_p_bound(ls1, depth-1);
-      return sexp_contains_syntax_p_bound(sexp_id_name(ls1), depth-1);
   } else if (sexp_vectorp(x)) {
     for (i = 0; i < sexp_vector_length(x); ++i)
       if (sexp_contains_syntax_p_bound(sexp_vector_ref(x, sexp_make_fixnum(i)), depth-1))
@@ -653,6 +665,8 @@ sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
 
 sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) {
   sexp cell1, cell2;
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2);
   cell1 = sexp_env_cell(ctx, e1, id1, 0);
   cell2 = sexp_env_cell(ctx, e2, id2, 0);
   if (cell1 && (cell1 == cell2))
@@ -753,6 +767,26 @@ static sexp analyze_seq (sexp ctx, sexp ls, int depth, int defok) {
   return res;
 }
 
+static sexp analyze_macro_once (sexp ctx, sexp x, sexp op, int depth) {
+  sexp res;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
+  tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
+  tmp = sexp_cons(ctx, x, tmp);
+  res = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+  if (!sexp_exceptionp(res) && !sexp_exceptionp(sexp_context_exception(ctx)))
+    res = sexp_apply(res, sexp_macro_proc(op), tmp);
+  if (sexp_pairp(sexp_car(tmp)) && sexp_pair_source(sexp_car(tmp))) {
+    if (sexp_pairp(res))
+      sexp_pair_source(res) = sexp_pair_source(sexp_car(tmp));
+    else if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(x)))
+      sexp_exception_source(res) = sexp_pair_source(sexp_car(tmp));
+  }
+  sexp_gc_release1(ctx);
+  return res;
+}
+
 static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
   sexp env = sexp_context_env(ctx), res;
   sexp_gc_var1(cell);
@@ -772,14 +806,23 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
 
 static sexp analyze_set (sexp ctx, sexp x, int depth) {
   sexp res, varenv;
-  sexp_gc_var2(ref, value);
+  sexp_gc_var4(ref, value, cell, op);
-  sexp_gc_preserve2(ctx, ref, value);
+  sexp_gc_preserve4(ctx, ref, value, cell, op);
   if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
          && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
     res = sexp_compile_error(ctx, "bad set! syntax", x);
+  } else {
+    cell = sexp_env_cell(ctx, sexp_context_env(ctx), sexp_cadr(x), 0);
+    op = cell ? sexp_cdr(cell) : NULL;
+    if (op && sexp_macrop(op)) {
+      if (!sexp_procedure_variable_transformer_p(sexp_macro_proc(op))) {
+        res = sexp_compile_error(ctx, "can't mutate a syntax keyword", sexp_cadr(x));
+      } else {
+        res = analyze_macro_once(ctx, x, op, depth);
+      }
     } else {
       ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv);
-    if (sexp_lambdap(sexp_ref_loc(ref)))
+      if (sexp_refp(ref) && sexp_lambdap(sexp_ref_loc(ref)))
         sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
       value = analyze(ctx, sexp_caddr(x), depth, 0);
       if (sexp_exceptionp(ref)) {
@@ -794,7 +837,8 @@ static sexp analyze_set (sexp ctx, sexp x, int depth) {
         sexp_set_source(res) = sexp_pair_source(x);
       }
     }
-  sexp_gc_release2(ctx);
+  }
+  sexp_gc_release4(ctx);
   return res;
 }
 
@@ -889,11 +933,18 @@ static sexp analyze_if (sexp ctx, sexp x, int depth) {
     res = sexp_compile_error(ctx, "too many args to if", x);
   } else {
     test = analyze(ctx, sexp_cadr(x), depth, 0);
+    if (sexp_exceptionp(test)) {
+      res = test;
+    } else {
       pass = analyze(ctx, sexp_caddr(x), depth, 0);
+      if (sexp_exceptionp(pass)) {
+        res = pass;
+      } else {
         fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
         fail = analyze(ctx, fail_expr, depth, 0);
-    res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
+        res = sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail);
-           sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
+      }
+    }
     if (sexp_cndp(res)) sexp_cnd_source(res) = sexp_pair_source(x);
   }
   sexp_gc_release3(ctx);
@@ -1011,7 +1062,7 @@ static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp, int depth) {
     sexp_env_syntactic_p(env) = 1;
     sexp_env_parent(env) = sexp_context_env(ctx);
     sexp_env_bindings(env) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
     sexp_env_renames(env) = SEXP_NULL;
 #endif
     ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
@@ -1051,8 +1102,13 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
     } else if (sexp_idp(sexp_car(x))) {
       if (! cell) {
         res = analyze_app(ctx, x, depth);
-        if (sexp_exceptionp(res))
+        if (sexp_exceptionp(res)) {
           sexp_warn(ctx, "exception inside undefined operator: ", sexp_car(x));
+          /* the common case of no imports */
+          if (!sexp_env_parent(sexp_context_env(ctx))) {
+            sexp_warn(ctx, "did you forget to import a language? e.g. (import (scheme base))", SEXP_UNDEF);
+          }
+        }
       } else {
         op = sexp_cdr(cell);
         if (sexp_corep(op)) {
@@ -1064,7 +1120,12 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
               : sexp_compile_error(ctx, "unexpected define", x);
             break;
           case SEXP_CORE_SET:
-            res = analyze_set(ctx, x, depth); break;
+            x = analyze_set(ctx, x, depth);
+            if (!sexp_exceptionp(x) && !sexp_setp(x))
+              goto loop;
+            else
+              res = x;
+            break;
           case SEXP_CORE_LAMBDA:
             res = analyze_lambda(ctx, x, depth); break;
           case SEXP_CORE_IF:
@@ -1095,14 +1156,7 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
             res = sexp_compile_error(ctx, "unknown core form", op); break;
           }
         } else if (sexp_macrop(op)) {
-          tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
+          x = analyze_macro_once(ctx, x, op, depth);
-          tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
-          tmp = sexp_cons(ctx, x, tmp);
-          x = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
-          if (!sexp_exceptionp(x) && !sexp_exceptionp(sexp_context_exception(ctx)))
-            x = sexp_apply(x, sexp_macro_proc(op), tmp);
-          if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x)))
-            sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp));
           goto loop;
         } else if (sexp_opcodep(op)) {
           res = sexp_length(ctx, sexp_cdr(x));
@@ -1134,7 +1188,14 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
         sexp_warn(ctx, "invalid operator in application: ", x);
     }
   } else if (sexp_idp(x)) {
+    cell = sexp_env_cell(ctx, sexp_context_env(ctx), x, 0);
+    op = cell ? sexp_cdr(cell) : NULL;
+    if (op && sexp_macrop(op)) {
+      x = analyze_macro_once(ctx, x, op, depth);
+      goto loop;
+    } else {
       res = analyze_var_ref(ctx, x, NULL);
+    }
   } else if (sexp_synclop(x)) {
     tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
     if (sexp_pairp(sexp_synclo_free_vars(x))) {
@@ -1319,24 +1380,53 @@ sexp sexp_stream_portp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
 #endif
 
 #if SEXP_USE_STATIC_LIBS
-#if SEXP_USE_STATIC_LIBS_NO_INCLUDE
+#if SEXP_USE_STATIC_LIBS_EMPTY
+struct sexp_library_entry_t* sexp_static_libraries = NULL;
+#elif SEXP_USE_STATIC_LIBS_NO_INCLUDE
 extern struct sexp_library_entry_t* sexp_static_libraries;
 #else
 #include "clibs.c"
 #endif
+
+void sexp_add_static_libraries(struct sexp_library_entry_t* libraries)
+{
+  struct sexp_library_entry_t *entry, *table;
+
+  if (!sexp_static_libraries) {
+    sexp_static_libraries = libraries;
+    return;
+  }
+
+  for (table = sexp_static_libraries; ;
+       table = (struct sexp_library_entry_t*)entry->init) {
+    for (entry = &table[0]; entry->name; entry++)
+       ;
+    if (!entry->init) {
+      entry->init = (sexp_init_proc)libraries;
+      return;
+    }
+  }
+}
+
 static struct sexp_library_entry_t *sexp_find_static_library(const char *file)
 {
   size_t base_len;
-  struct sexp_library_entry_t *entry;
+  struct sexp_library_entry_t *entry, *table;
 
+  if(!sexp_static_libraries)
+    return NULL;
   if (file[0] == '.' && file[1] == '/')
     file += 2;
   base_len = strlen(file) - strlen(sexp_so_extension);
   if (strcmp(file + base_len, sexp_so_extension))
     return NULL;
-  for (entry = &sexp_static_libraries[0]; entry->name; entry++)
+  for (table = sexp_static_libraries;
+       table;
+       table = (struct sexp_library_entry_t*)entry->init) {
+    for (entry = &table[0]; entry->name; entry++)
       if (! strncmp(file, entry->name, base_len))
         return entry;
+  }
   return NULL;
 }
 #else
@@ -1612,8 +1702,8 @@ sexp sexp_inexact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
   if (sexp_flonump(z))
     d = sexp_flonum_value(z);
   else if (sexp_fixnump(z))
-    d = (double)sexp_unbox_fixnum(z);
+    d = (double)sexp_unbox_fixnum(z); /* may be larger or smaller than z */
-  maybe_convert_ratio(ctx, z)        /* XXXX add ratio sqrt */
+  maybe_convert_ratio(ctx, z)         /* TODO: add ratio sqrt */
   maybe_convert_complex(z, sexp_complex_sqrt)
   else
     return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
@@ -1653,6 +1743,11 @@ sexp sexp_exact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
     if (!sexp_exceptionp(res)) {
       rem = sexp_mul(ctx, res, res);
       rem = sexp_sub(ctx, z, rem);
+      if (sexp_negativep(rem)) {
+        res = sexp_sub(ctx, res, SEXP_ONE);
+        rem = sexp_mul(ctx, res, res);
+        rem = sexp_sub(ctx, z, rem);
+      }
       res = sexp_cons(ctx, res, rem);
     }
   }
@@ -1662,8 +1757,10 @@ sexp sexp_exact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
 #endif
 
 sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
-#if SEXP_USE_BIGNUMS
+#if SEXP_USE_BIGNUMS || SEXP_USE_RATIOS
   sexp_gc_var2(res, rem);
+#endif
+#if SEXP_USE_BIGNUMS
   if (sexp_bignump(z)) {
     sexp_gc_preserve2(ctx, res, rem);
     res = sexp_bignum_sqrt(ctx, z, &rem);
@@ -1673,6 +1770,20 @@ sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
     sexp_gc_release2(ctx);
     return res;
   }
+#endif
+#if SEXP_USE_RATIOS
+  if (sexp_ratiop(z)) {
+    sexp_gc_preserve2(ctx, res, rem);
+    res = sexp_sqrt(ctx, self, n, sexp_ratio_numerator(z));
+    rem = sexp_sqrt(ctx, self, n, sexp_ratio_denominator(z));
+    if (sexp_exactp(res) && sexp_exactp(rem)) {
+      res = sexp_make_ratio(ctx, res, rem);
+    } else {
+      res = sexp_inexact_sqrt(ctx, self, n, z);
+    }
+    sexp_gc_release2(ctx);
+    return res;
+  }
 #endif
   return sexp_inexact_sqrt(ctx, self, n, z);
 }
@@ -1836,8 +1947,8 @@ sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
       res = sexp_xtype_exception(ctx, self, "exact: not an integer", z);
 #endif
 #if SEXP_USE_BIGNUMS
-    } else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM)
+    } else if ((sexp_flonum_value(z) > (double)SEXP_MAX_FIXNUM)
-               || sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
+               || sexp_flonum_value(z) < (double)SEXP_MIN_FIXNUM) {
       res = sexp_double_to_bignum(ctx, sexp_flonum_value(z));
 #endif
     } else {
@@ -1936,7 +2047,7 @@ void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) {
   p = (unsigned char*)sexp_string_data(str) + i;
   old_len = sexp_utf8_initial_byte_count(*p);
   new_len = sexp_utf8_char_byte_count(c);
-  if (old_len != new_len) { /* resize bytes if needed */
+  if (sexp_copy_on_writep(str) || old_len != new_len) { /* resize bytes if needed */
     len = sexp_string_size(str)+(new_len-old_len);
     b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID);
     if (! sexp_exceptionp(b)) {
@@ -1947,10 +2058,17 @@ void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) {
       p = q + i;
     }
     sexp_string_size(str) += new_len - old_len;
+    sexp_copy_on_writep(str) = 0;
   }
   sexp_utf8_encode_char(p, new_len, c);
-  if (old_len != new_len)
+  if (old_len != new_len) {
+#if SEXP_USE_STRING_INDEX_TABLE
     sexp_update_string_index_lookup(ctx, str);
+#elif SEXP_USE_STRING_REF_CACHE
+  sexp_cached_char_idx(str) = 0;
+  sexp_cached_cursor(str) = sexp_make_string_cursor(0);
+#endif
+  }
 }
 
 sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch) {
@@ -1958,6 +2076,8 @@ sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, s
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
   sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
+  if (sexp_immutablep(str))
+    return sexp_xtype_exception(ctx, self, "string-set!: immutable string", str);
   off = sexp_string_index_to_cursor(ctx, self, n, str, i);
   if (sexp_exceptionp(off)) return off;
   if (sexp_unbox_string_cursor(off) >= (sexp_sint_t)sexp_string_size(str))
@@ -2172,9 +2292,9 @@ static struct sexp_core_form_struct core_forms[] = {
   {SEXP_CORE_BEGIN, (sexp)"begin"},
   {SEXP_CORE_QUOTE, (sexp)"quote"},
   {SEXP_CORE_SYNTAX_QUOTE, (sexp)"syntax-quote"},
-  {SEXP_CORE_DEFINE_SYNTAX, (sexp)"%define-syntax"},
+  {SEXP_CORE_DEFINE_SYNTAX, (sexp)"define-syntax"},
-  {SEXP_CORE_LET_SYNTAX, (sexp)"%let-syntax"},
+  {SEXP_CORE_LET_SYNTAX, (sexp)"let-syntax"},
-  {SEXP_CORE_LETREC_SYNTAX, (sexp)"%letrec-syntax"},
+  {SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"},
 };
 
 sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
@@ -2182,7 +2302,7 @@ sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
   sexp_env_lambda(e) = NULL;
   sexp_env_parent(e) = NULL;
   sexp_env_bindings(e) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
   sexp_env_renames(e) = SEXP_NULL;
 #endif
   return e;
@@ -2465,10 +2585,19 @@ sexp sexp_make_standard_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version
   sexp_gc_preserve1(ctx, env);
   env = sexp_make_primitive_env(ctx, version);
   if (! sexp_exceptionp(env)) env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
+  if (sexp_envp(env)) sexp_immutablep(env) = 1;
   sexp_gc_release1(ctx);
   return env;
 }
 
+sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  if (sexp_pointerp(x)) {
+    sexp_immutablep(x) = 1;
+    return SEXP_TRUE;
+  }
+  return SEXP_FALSE;
+}
+
 sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;

examples/hello.scm

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

examples/simple-http-client.scm

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

examples/simple-http-server.scm

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

gc.c

@@ -37,7 +37,7 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
   return h;
 }
 
-#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
+#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)
@@ -696,6 +696,7 @@ int sexp_find_fixed_chunk_heap_usage(sexp ctx, size_t size, size_t* sum_freed, s
 }
 #endif
 
+#if ! SEXP_USE_MALLOC
 void* sexp_alloc (sexp ctx, size_t size) {
   void *res;
   size_t max_freed, sum_freed, total_size=0;
@@ -741,6 +742,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
 #endif
   return res;
 }
+#endif
 
 
 void sexp_gc_init (void) {

include/chibi/bignum.h

@@ -8,7 +8,11 @@
 #include "chibi/eval.h"
 
 #if SEXP_USE_CUSTOM_LONG_LONGS
+#ifdef PLAN9
+#include <ape/stdint.h>
+#else
 #include <stdint.h>
+#endif
 typedef struct
 {
   uint64_t hi;
@@ -98,7 +102,7 @@ static inline sexp_luint_t luint_from_uint(sexp_uint_t v) {
 }
 
 static inline sexp_sint_t lsint_to_sint(sexp_lsint_t v) {
-  return lsint_lt_0(v) ? -v.lo : v.lo;
+  return v.lo;
 }
 
 static inline sexp_uint_t luint_to_uint(sexp_luint_t v) {

include/chibi/eval.h

@@ -129,6 +129,7 @@ SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
 SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
 SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
 SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
 SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
 #if SEXP_USE_AUTO_FORCE
 SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
@@ -194,6 +195,8 @@ SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name
 #define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL)
 #define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p)
 #define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p)
+#define sexp_define_foreign_proc(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_NONE,(const char*)#f,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_proc_rest(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_VARIADIC,(const char*)#f,(sexp_proc1)f,NULL)
 
 #define sexp_env_key(x) sexp_car(x)
 #define sexp_env_value(x) sexp_cdr(x)

include/chibi/features.h

@@ -1,5 +1,5 @@
 /*  features.h -- general feature configuration               */
-/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2021 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 /* uncomment this to disable most features */
@@ -23,16 +23,27 @@
 /*   sexp_init_library(ctx, env) function provided. */
 /* #define SEXP_USE_DL 0 */
 
-/* uncomment this to statically compile all C libs */
+/* uncomment this to support statically compiled C libs */
-/*   If set, this will statically include the clibs.c file */
+/*   Unless SEXP_USE_STATIC_LIBS_EMPTY is set (see below), this */
-/*   into the standard environment, so that you can have */
+/*   will statically include the clibs.c file into the standard */
-/*   access to a predefined set of C libraries without */
+/*   environment, so that you can have access to a predefined set */
-/*   needing dynamic loading.  The clibs.c file is generated */
+/*   of C libraries without needing dynamic loading.  The clibs.c */
-/*   automatically by searching the lib directory for */
+/*   file is generated automatically by searching the lib directory */
-/*   modules with include-shared, but can be hand-tailored */
+/*   for modules with include-shared, but can be hand-tailored to */
-/*   to your needs. */
+/*   your needs.  You can also register your own C libraries using */
+/*   sexp_add_static_libraries (see below). */
 /* #define SEXP_USE_STATIC_LIBS 1 */
 
+/* uncomment this to enable user exported C libs */
+/*   You can register your own C libraries using */
+/*   sexp_add_static_libraries.  Each entry in the supplied table, */
+/*   is a name/entry point pair.  These work as if they were */
+/*   dynamically loaded libraries, so naming follows the same */
+/*   conventions.  An entry {"foo", init_foo} will register a */
+/*   library that can be loaded with (load "foo"), or */
+/*   (include-shared "foo"), both of which will call init_foo. */
+/* #define SEXP_USE_STATIC_LIBS_EMPTY 1 */
+
 /* uncomment this to disable detailed source info for debugging */
 /*   By default Chibi will associate source info with every */
 /*   bytecode offset.  By disabling this only lambda-level source */
@@ -64,6 +75,15 @@
 /*   if you suspect a bug in the native GC. */
 /* #define SEXP_USE_BOEHM 1 */
 
+/* uncomment this to enable automatic file descriptor unification */
+/*   File descriptors as returned by C functions are raw integers, */
+/*   which are convereted to GC'ed first-class objects on the Scheme */
+/*   side.  By default we assume that each fd is new, however if this */
+/*   option is enabled and an fd is returned which matches an existing */
+/*   open fd, they are assumed to refer to the same descriptor and */
+/*   unified. */
+/* #define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 1 */
+
 /* uncomment this to disable weak references */
 /* #define SEXP_USE_WEAK_REFERENCES 0 */
 
@@ -168,11 +188,27 @@
 /* uncomment this if you don't want 1## style approximate digits */
 /* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */
 
+/* uncomment this to disable a workaround for numeric formatting, */
+/* to fix numbers in locales which don't use the '.' decimal sep */
+/* #define SEXP_USE_PATCH_NON_DECIMAL_NUMERIC_FORMATS 0 */
+
 /* uncomment this if you don't need extended math operations */
 /*   This includes the trigonometric and expt functions. */
 /*   Automatically disabled if you've disabled flonums. */
 /* #define SEXP_USE_MATH 0 */
 
+/* uncomment this to enable lenient matching of top-level bindings */
+/*   Historically, to match behavior with some other Schemes and in */
+/*   hopes of making it easier to use macros and modules, Chibi allowed */
+/*   top-level bindings with the same underlying symbol name to match */
+/*   with identifier=?.  In particular, there still isn't a good way */
+/*   to handle the case where auxiliary syntax conflicts with some other */
+/*   binding without renaming one or the other (though SRFI 206 helps). */
+/*   However, if people make use of this you can write Chibi programs */
+/*   which don't work portably in other implementations, which has been */
+/*   a source of confusion, so the default has reverted to strict R7RS. */
+/* #define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0 */
+
 /* uncomment this to disable warning about references to undefined variables */
 /*   This is something of a hack, but can be quite useful. */
 /*   It's very fast and doesn't involve any separate analysis */
@@ -231,6 +267,12 @@
 /*                                                                  */
 /* #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 */
 /*   automatically closed when they're garbage collected.  Doesn't */
@@ -259,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 */
@@ -303,12 +345,21 @@
 #define SEXP_MAX_ANALYZE_DEPTH 8192
 #endif
 
+/* The size of flexible arrays (empty arrays at the end of a struct */
+/* representing the trailing data), when compiled with C++.  Technically */
+/* 0 is an illegal value here, and the C++ idiom is to use 1, but this */
+/* breaks compatibility with C when computing the size of structs, and */
+/* in practice all of the major C++ compilers support 0. */
+#ifndef SEXP_FLEXIBLE_ARRAY_SIZE
+#define SEXP_FLEXIBLE_ARRAY_SIZE 0
+#endif
+
 /************************************************************************/
 /*         DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE            */
 /************************************************************************/
 
 #ifndef SEXP_64_BIT
-#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) || defined(__mips64__) || defined(__sparc64__)
+#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) || defined(__mips64__) || defined(__sparc64__) || defined(__arm64)
 #define SEXP_64_BIT 1
 #else
 #define SEXP_64_BIT 0
@@ -427,13 +478,17 @@
 #endif
 #endif
 
+#ifndef SEXP_USE_STATIC_LIBS_EMPTY
+#define SEXP_USE_STATIC_LIBS_EMPTY 0
+#endif
+
 #ifndef SEXP_USE_STATIC_LIBS
-#define SEXP_USE_STATIC_LIBS 0
+#define SEXP_USE_STATIC_LIBS SEXP_USE_STATIC_LIBS_EMPTY
 #endif
 
 /* don't include clibs.c - include separately or link */
 #ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
-#ifdef PLAN9
+#if defined(PLAN9) || SEXP_USE_STATIC_LIBS_EMPTY
 #define SEXP_USE_STATIC_LIBS_NO_INCLUDE 0
 #else
 #define SEXP_USE_STATIC_LIBS_NO_INCLUDE 1
@@ -452,9 +507,17 @@
 #define SEXP_USE_BOEHM 0
 #endif
 
+#ifdef SEXP_USE_UNIFY_FILENOS_BY_NUMBER
+#define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 0
+#endif
+
 #ifndef SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_UNIFY_FILENOS_BY_NUMBER
+#define SEXP_USE_WEAK_REFERENCES 1
+#else
 #define SEXP_USE_WEAK_REFERENCES ! SEXP_USE_NO_FEATURES
 #endif
+#endif
 
 #ifndef SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
 #define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 0
@@ -553,7 +616,7 @@
 #endif
 
 #ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
-#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
+#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 1
 #endif
 
 #if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
@@ -627,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
@@ -651,6 +718,10 @@
 #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_UNIFORM_VECTOR_LITERALS
 #endif

include/chibi/gc_heap.h

@@ -7,6 +7,8 @@
 
 #include "chibi/sexp.h"
 
+#if SEXP_USE_IMAGE_LOADING
+
 #ifdef __cplusplus
 extern "C" {
 #endif
@@ -98,4 +100,6 @@ SEXP_API char* sexp_load_image_err();
 }
 #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.h

@@ -1,5 +1,5 @@
 /*  sexp.h -- header for sexp library                         */
-/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2022 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #ifndef SEXP_H
@@ -7,7 +7,7 @@
 
 #ifdef __cplusplus
 extern "C" {
-#define SEXP_FLEXIBLE_ARRAY [1]
+#define SEXP_FLEXIBLE_ARRAY [SEXP_FLEXIBLE_ARRAY_SIZE]
 #else
 #define SEXP_FLEXIBLE_ARRAY []
 #endif
@@ -82,6 +82,12 @@ typedef long long off_t;
 #define exit(x)           exits(TOSTRING(x))
 #define fabsl          fabs
 #define M_LN10         2.30258509299404568402  /* log_e 10 */
+#define FLT_RADIX 2
+#define isfinite(x) !(isNaN(x) || isInf(x,0))
+typedef u32int uint32_t;
+typedef s32int int32_t;
+typedef u64int uint64_t;
+typedef s64int int64_t;
 #else
 #include <stddef.h>
 #include <stdlib.h>
@@ -225,9 +231,15 @@ typedef int sexp_sint_t;
 #define sexp_heap_align(n) sexp_align(n, 5)
 #define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
 #elif SEXP_64_BIT
+#if PLAN9
+typedef uintptr sexp_tag_t;
+typedef uintptr sexp_uint_t;
+typedef intptr sexp_sint_t;
+#else
 typedef unsigned int sexp_tag_t;
 typedef unsigned long sexp_uint_t;
 typedef long sexp_sint_t;
+#endif
 #define SEXP_PRIdFIXNUM "ld"
 #define sexp_heap_align(n) sexp_align(n, 5)
 #define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
@@ -238,6 +250,13 @@ typedef int sexp_sint_t;
 #define SEXP_PRIdFIXNUM "d"
 #define sexp_heap_align(n) sexp_align(n, 5)
 #define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
+#elif PLAN9
+typedef uintptr sexp_tag_t;
+typedef unsigned int sexp_uint_t;
+typedef int sexp_sint_t;
+#define SEXP_PRIdFIXNUM "d"
+#define sexp_heap_align(n) sexp_align(n, 4)
+#define sexp_heap_chunks(n) (sexp_heap_align(n)>>4)
 #else
 typedef unsigned short sexp_tag_t;
 typedef unsigned int sexp_uint_t;
@@ -251,10 +270,15 @@ typedef int sexp_sint_t;
 #define SEXP_PROC_NONE ((sexp_uint_t)0)
 #define SEXP_PROC_VARIADIC ((sexp_uint_t)1)
 #define SEXP_PROC_UNUSED_REST ((sexp_uint_t)2)
+#define SEXP_PROC_VARIABLE_TRANSFORMER ((sexp_uint_t)4)
 
 
 #ifdef SEXP_USE_INTTYPES
+#ifdef PLAN9
+#include <ape/stdint.h>
+#else
 #include <stdint.h>
+#endif
 # ifdef UINT8_MAX
 #  define SEXP_UINT8_DEFINED 1
 typedef uint8_t  sexp_uint8_t;
@@ -270,9 +294,13 @@ typedef int32_t sexp_int32_t;
 # else
 # include <limits.h>
 # if SEXP_USE_UNIFORM_VECTOR_LITERALS
+# ifdef PLAN9
+# include <ape/stdint.h>
+# else
 # include <stdint.h>
 # endif
 # endif
+# endif
 # if UCHAR_MAX == 255
 #  define SEXP_UINT8_DEFINED 1
 typedef unsigned char sexp_uint8_t;
@@ -367,8 +395,8 @@ struct sexp_gc_var_t {
   struct sexp_gc_var_t *next;
 };
 
-struct sexp_library_entry_t {   /* for static builds */
+struct sexp_library_entry_t {   /* for static builds and user exported C */
-  const char *name;
+  const char *name;             /* libaries */
   sexp_init_proc init;
 };
 
@@ -414,6 +442,7 @@ struct sexp_struct {
   unsigned int freep:1;
   unsigned int brokenp:1;
   unsigned int syntacticp:1;
+  unsigned int copyonwritep:1;
 #if SEXP_USE_TRACK_ALLOC_SOURCE
   const char* source;
   void* backtrace[SEXP_BACKTRACE_SIZE];
@@ -432,11 +461,9 @@ struct sexp_struct {
     } pair;
     struct {
       sexp_uint_t length;
-      sexp data SEXP_FLEXIBLE_ARRAY;
     } vector;
     struct {
       sexp_uint_t length;
-      char data SEXP_FLEXIBLE_ARRAY;
     } bytes;
     struct {
       sexp bytes;
@@ -449,18 +476,19 @@ struct sexp_struct {
       sexp charlens;
 #endif
       sexp_uint_t length;
-      char data SEXP_FLEXIBLE_ARRAY;
 #else
       sexp bytes;
 #if SEXP_USE_STRING_INDEX_TABLE
       sexp charlens;
+#elif SEXP_USE_STRING_REF_CACHE
+      sexp_uint_t cached_char_idx;
+      sexp cached_cursor;
 #endif
       sexp_uint_t offset, length;
 #endif
     } string;
     struct {
       sexp_uint_t length;
-      char data SEXP_FLEXIBLE_ARRAY;
     } symbol;
     struct {
       sexp name;
@@ -478,12 +506,11 @@ struct sexp_struct {
       sexp_sint_t fd, count;
     } fileno;
     struct {
-      sexp kind, message, irritants, procedure, source;
+      sexp kind, message, irritants, procedure, source, stack_trace;
     } exception;
     struct {
       signed char sign;
       sexp_uint_t length;
-      sexp_uint_t data SEXP_FLEXIBLE_ARRAY;
     } bignum;
     struct {
       sexp numerator, denominator;
@@ -495,7 +522,6 @@ struct sexp_struct {
       sexp parent;
       sexp_uint_t length;
       void *value;
-      char body SEXP_FLEXIBLE_ARRAY;
     } cpointer;
     /* runtime types */
     struct {
@@ -507,11 +533,10 @@ struct sexp_struct {
     struct {
       sexp name, literals, source;
       sexp_uint_t length, max_depth;
-      unsigned char data SEXP_FLEXIBLE_ARRAY;
     } bytecode;
     struct {
       sexp bc, vars;
-      char flags;
+      char flags;  /* a boxed fixnum truncated to char */
       sexp_proc_num_args_t num_args;
     } procedure;
     struct {
@@ -551,7 +576,6 @@ struct sexp_struct {
     /* compiler state */
     struct {
       sexp_uint_t length, top;
-      sexp data SEXP_FLEXIBLE_ARRAY;
     } stack;
     struct {
       sexp stack, env, parent, child,
@@ -568,7 +592,7 @@ struct sexp_struct {
       unsigned char* ip;
       struct timeval tval;
 #endif
-      char tailp, tracep, timeoutp, waitp, errorp;
+      char tailp, tracep, timeoutp, waitp, errorp, interruptp;
       sexp_uint_t last_fp;
       sexp_uint_t gc_count;
 #if SEXP_USE_TIME_GC
@@ -750,9 +774,11 @@ void* sexp_alloc(sexp ctx, size_t size);
 #define sexp_markedp(x)          ((x)->markedp)
 #define sexp_flags(x)            ((x)->flags)
 #define sexp_immutablep(x)       ((x)->immutablep)
+#define sexp_mutablep(x)         (!(x)->immutablep)
 #define sexp_freep(x)            ((x)->freep)
 #define sexp_brokenp(x)          ((x)->brokenp)
 #define sexp_pointer_magic(x)    ((x)->magic)
+#define sexp_copy_on_writep(x)   ((x)->copyonwritep)
 
 #if SEXP_USE_TRACK_ALLOC_SOURCE
 #define sexp_pointer_source(x)   ((x)->source)
@@ -767,11 +793,12 @@ void* sexp_alloc(sexp ctx, size_t size);
 
 #define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b)))
 
-#if SEXP_USE_IMMEDIATE_FLONUMS
 union sexp_flonum_conv {
   float flonum;
   unsigned int bits;
 };
+
+#if SEXP_USE_IMMEDIATE_FLONUMS
 #define sexp_flonump(x)      (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_IFLONUM_TAG)
 SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x);
 #if SEXP_64_BIT
@@ -852,6 +879,8 @@ SEXP_API sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_s32vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S32)
 #define sexp_u64vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U64)
 #define sexp_s64vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S64)
+#define sexp_f8vectorp(x)   (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F8)
+#define sexp_f16vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F16)
 #define sexp_f32vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F32)
 #define sexp_f64vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F64)
 #define sexp_c64vectorp(x)  (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_C64)
@@ -867,6 +896,8 @@ SEXP_API sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_s32vectorp(x)  (sexp_vectorp(x))
 #define sexp_u64vectorp(x)  (sexp_vectorp(x))
 #define sexp_s64vectorp(x)  (sexp_vectorp(x))
+#define sexp_f8vectorp(x)   (sexp_vectorp(x))
+#define sexp_f16vectorp(x)  (sexp_vectorp(x))
 #define sexp_f32vectorp(x)  (sexp_vectorp(x))
 #define sexp_f64vectorp(x)  (sexp_vectorp(x))
 #define sexp_c64vectorp(x)  (sexp_vectorp(x))
@@ -1019,7 +1050,10 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_negativep(x) (sexp_exact_negativep(x) ||                   \
                            (sexp_flonump(x) && sexp_flonum_value(x) < 0))
 #define sexp_positivep(x) (!(sexp_negativep(x)))
-#define sexp_pedantic_negativep(x) (sexp_exact_negativep(x) ||          \
+#define sexp_pedantic_negativep(x) (                 \
+  sexp_exact_negativep(x) ||                         \
+  (sexp_ratiop(x) &&                                 \
+   sexp_exact_negativep(sexp_ratio_numerator(x))) || \
   (sexp_flonump(x) &&                                \
    ((sexp_flonum_value(x) < 0) ||                    \
     (sexp_flonum_value(x) == 0 &&                    \
@@ -1045,12 +1079,20 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_negate_flonum(x) sexp_flonum_value(x) = -(sexp_flonum_value(x))
 #endif
 
+/* TODO: Doesn't support x == SEXP_MIN_FIXNUM. */
 #define sexp_negate(x)                                  \
   if (sexp_flonump(x))                                  \
     sexp_negate_flonum(x);                              \
   else                                                  \
     sexp_negate_exact(x)
 
+#define sexp_negate_maybe_ratio(x)                      \
+  if (sexp_ratiop(x)) {                                 \
+    sexp_negate_exact(sexp_ratio_numerator(x));         \
+  } else {                                              \
+    sexp_negate(x);                                     \
+  }
+
 #if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS
 
 #if SEXP_64_BIT
@@ -1083,6 +1125,13 @@ SEXP_API unsigned long long sexp_bignum_to_uint(sexp x);
 #define sexp_flonum_eqv(x, y) (sexp_flonum_value(x) == sexp_flonum_value(y))
 #endif
 
+#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
+SEXP_API double sexp_quarter_to_double(unsigned char q);
+SEXP_API unsigned char sexp_double_to_quarter(double f);
+SEXP_API double sexp_half_to_double(unsigned short x);
+SEXP_API unsigned short sexp_double_to_half(double x);
+#endif
+
 /*************************** field accessors **************************/
 
 #if SEXP_USE_SAFE_ACCESSORS
@@ -1101,8 +1150,11 @@ SEXP_API unsigned long long sexp_bignum_to_uint(sexp x);
 #define sexp_cpointer_field(x, field) ((x)->value.cpointer.field)
 #endif
 
+#define sexp_flexible_array_field(x, type, field_type) \
+  ((field_type*)((char*)(x)+sexp_sizeof(type)))
+
 #define sexp_vector_length(x) (sexp_field(x, vector, SEXP_VECTOR, length))
-#define sexp_vector_data(x)   (sexp_field(x, vector, SEXP_VECTOR, data))
+#define sexp_vector_data(x)   sexp_flexible_array_field(x, vector, sexp)
 
 #if SEXP_USE_SAFE_VECTOR_ACCESSORS
 #define sexp_vector_ref(x,i)   (sexp_unbox_fixnum(i)>=0 && sexp_unbox_fixnum(i)<sexp_vector_length(x) ? sexp_vector_data(x)[sexp_unbox_fixnum(i)] : (fprintf(stderr, "vector-ref length out of range %s on line %d: vector %p (length %lu): %ld\n", __FILE__, __LINE__, x, sexp_vector_length(x), sexp_unbox_fixnum(i)), SEXP_VOID))
@@ -1116,17 +1168,18 @@ SEXP_API unsigned long long sexp_bignum_to_uint(sexp x);
 #define sexp_procedure_flags(x)      (sexp_field(x, procedure, SEXP_PROCEDURE, flags))
 #define sexp_procedure_variadic_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIADIC)
 #define sexp_procedure_unused_rest_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_UNUSED_REST)
+#define sexp_procedure_variable_transformer_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIABLE_TRANSFORMER)
 #define sexp_procedure_code(x)       (sexp_field(x, procedure, SEXP_PROCEDURE, bc))
 #define sexp_procedure_vars(x)       (sexp_field(x, procedure, SEXP_PROCEDURE, vars))
 #define sexp_procedure_source(x)     sexp_bytecode_source(sexp_procedure_code(x))
 
 #define sexp_bytes_length(x)  (sexp_field(x, bytes, SEXP_BYTES, length))
-#define sexp_bytes_data(x)    (sexp_field(x, bytes, SEXP_BYTES, data))
+#define sexp_bytes_data(x)   sexp_flexible_array_field(x, bytes, char)
 #define sexp_bytes_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_bytes_data(x))
 
 static const unsigned char sexp_uvector_sizes[] = {
-  0, 1, 8, 8, 16, 16, 32, 32, 64, 64, 32, 64, 64, 128};
+  0, 1, 8, 8, 16, 16, 32, 32, 64, 64, 32, 64, 64, 128, 8, 16};
-static const unsigned char sexp_uvector_chars[] = "#ususususuffcc";
+static const unsigned char sexp_uvector_chars[] = "#ususususuffccff";
 
 enum sexp_uniform_vector_type {
   SEXP_NOT_A_UNIFORM_TYPE,
@@ -1142,7 +1195,10 @@ enum sexp_uniform_vector_type {
   SEXP_F32,
   SEXP_F64,
   SEXP_C64,
-  SEXP_C128
+  SEXP_C128,
+  SEXP_F8,
+  SEXP_F16,
+  SEXP_END_OF_UNIFORM_TYPES
 };
 
 #define sexp_uvector_freep(x) (sexp_freep(x))
@@ -1161,13 +1217,17 @@ enum sexp_uniform_vector_type {
 #define sexp_string_size(x)     (sexp_field(x, string, SEXP_STRING, length))
 #define sexp_string_charlens(x) (sexp_field(x, string, SEXP_STRING, charlens))
 #if SEXP_USE_PACKED_STRINGS
-#define sexp_string_data(x)   (sexp_field(x, string, SEXP_STRING, data))
+#define sexp_string_data(x)   sexp_flexible_array_field(x, string, char)
 #define sexp_string_bytes(x)  (x)
 #else
 #define sexp_string_bytes(x)  (sexp_field(x, string, SEXP_STRING, bytes))
 #define sexp_string_offset(x) (sexp_field(x, string, SEXP_STRING, offset))
 #define sexp_string_data(x)   (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x))
 #endif
+#if SEXP_USE_STRING_REF_CACHE
+#define sexp_cached_char_idx(x) (sexp_field(x, string, SEXP_STRING, cached_char_idx))
+#define sexp_cached_cursor(x) (sexp_field(x, string, SEXP_STRING, cached_cursor))
+#endif
 #define sexp_string_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_string_data(x))
 
 #if SEXP_USE_PACKED_STRINGS
@@ -1179,7 +1239,7 @@ enum sexp_uniform_vector_type {
 #define sexp_bytes_ref(x, i)    (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)]))
 #define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v))
 
-#define sexp_lsymbol_data(x)   (sexp_field(x, symbol, SEXP_SYMBOL, data))
+#define sexp_lsymbol_data(x)   sexp_flexible_array_field(x, symbol, char)
 #define sexp_lsymbol_length(x) (sexp_field(x, symbol, SEXP_SYMBOL, length))
 
 #define sexp_port_stream(p)     (sexp_pred_field(p, port, sexp_portp, stream))
@@ -1217,6 +1277,7 @@ enum sexp_uniform_vector_type {
 #define sexp_exception_irritants(x) (sexp_field(x, exception, SEXP_EXCEPTION, irritants))
 #define sexp_exception_procedure(x) (sexp_field(x, exception, SEXP_EXCEPTION, procedure))
 #define sexp_exception_source(x)    (sexp_field(x, exception, SEXP_EXCEPTION, source))
+#define sexp_exception_stack_trace(x) (sexp_field(x, exception, SEXP_EXCEPTION, stack_trace))
 
 #define sexp_trampolinep(x) (sexp_exceptionp(x) && sexp_exception_kind(x) == SEXP_TRAMPOLINE)
 #define sexp_trampoline_procedure(x) sexp_exception_procedure(x)
@@ -1225,7 +1286,6 @@ enum sexp_uniform_vector_type {
 
 #define sexp_cpointer_freep(x)      (sexp_freep(x))
 #define sexp_cpointer_length(x)     (sexp_cpointer_field(x, length))
-#define sexp_cpointer_body(x)       (sexp_cpointer_field(x, body))
 #define sexp_cpointer_parent(x)     (sexp_cpointer_field(x, parent))
 #define sexp_cpointer_value(x)      (sexp_cpointer_field(x, value))
 #define sexp_cpointer_maybe_null_value(x) (sexp_not(x) ? NULL : sexp_cpointer_value(x))
@@ -1235,7 +1295,7 @@ enum sexp_uniform_vector_type {
 #define sexp_bytecode_name(x)     (sexp_field(x, bytecode, SEXP_BYTECODE, name))
 #define sexp_bytecode_literals(x) (sexp_field(x, bytecode, SEXP_BYTECODE, literals))
 #define sexp_bytecode_source(x)   (sexp_field(x, bytecode, SEXP_BYTECODE, source))
-#define sexp_bytecode_data(x)     (sexp_field(x, bytecode, SEXP_BYTECODE, data))
+#define sexp_bytecode_data(x)     sexp_flexible_array_field(x, bytecode, unsigned char)
 
 #define sexp_env_cell_syntactic_p(x)   ((x)->syntacticp)
 
@@ -1325,7 +1385,7 @@ enum sexp_uniform_vector_type {
 
 #define sexp_stack_length(x)  (sexp_field(x, stack, SEXP_STACK, length))
 #define sexp_stack_top(x)     (sexp_field(x, stack, SEXP_STACK, top))
-#define sexp_stack_data(x)    (sexp_field(x, stack, SEXP_STACK, data))
+#define sexp_stack_data(x)    sexp_flexible_array_field(x, stack, sexp)
 
 #define sexp_promise_donep(x) (sexp_field(x, promise, SEXP_PROMISE, donep))
 #define sexp_promise_value(x) (sexp_field(x, promise, SEXP_PROMISE, value))
@@ -1373,6 +1433,7 @@ enum sexp_uniform_vector_type {
 
 #define sexp_context_result(x)   (sexp_field(x, context, SEXP_CONTEXT, result))
 #define sexp_context_errorp(x)   (sexp_field(x, context, SEXP_CONTEXT, errorp))
+#define sexp_context_interruptp(x) (sexp_field(x, context, SEXP_CONTEXT, interruptp))
 
 /* during compilation, sexp_context_specific is set to a vector */
 /* containing the following elements: */
@@ -1469,7 +1530,7 @@ SEXP_API sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
 
 #define sexp_bignum_sign(x)            (sexp_field(x, bignum, SEXP_BIGNUM, sign))
 #define sexp_bignum_length(x)          (sexp_field(x, bignum, SEXP_BIGNUM, length))
-#define sexp_bignum_data(x)            (sexp_field(x, bignum, SEXP_BIGNUM, data))
+#define sexp_bignum_data(x)            sexp_flexible_array_field(x, bignum, sexp_uint_t)
 
 /****************************** arithmetic ****************************/
 
@@ -1509,6 +1570,7 @@ enum sexp_context_globals {
   SEXP_G_OOM_ERROR,             /* out of memory exception object */
   SEXP_G_OOS_ERROR,             /* out of stack exception object */
   SEXP_G_ABI_ERROR,             /* incompatible ABI loading library */
+  SEXP_G_INTERRUPT_ERROR,       /* C-c in the repl */
   SEXP_G_OPTIMIZATIONS,
   SEXP_G_SIGNAL_HANDLERS,
   SEXP_G_META_ENV,
@@ -1642,6 +1704,16 @@ sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl);
 #define sexp_current_source_param
 #endif
 
+/* To export a library from the embedding C program to Scheme, so    */
+/* that it can be included into Scheme library foo/qux.sld as        */
+/* (include-shared "bar"), libraries should contain the entry        */
+/* {"foo/bar", init_bar}.  The signature and function of init_bar is */
+/* the same as that of sexp_init_library in shared libraries.  The   */
+/* array libraries must be terminated with {NULL, NULL} and must     */
+/* remain valid throughout its use by Chibi.                         */
+
+SEXP_API void sexp_add_static_libraries(struct sexp_library_entry_t* libraries);
+
 SEXP_API sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_current_source_param);
 SEXP_API sexp sexp_make_context(sexp ctx, size_t size, size_t max_size);
 SEXP_API sexp sexp_cons_op(sexp ctx, sexp self, sexp_sint_t n, sexp head, sexp tail);
@@ -1718,14 +1790,18 @@ SEXP_API sexp sexp_lookup_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name
 SEXP_API sexp sexp_open_input_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp str);
 SEXP_API sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n);
 SEXP_API sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
 SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source);
 SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x);
+SEXP_API sexp sexp_user_exception_ls (sexp ctx, sexp self, const char *msg, int n, ...);
 SEXP_API sexp sexp_file_exception (sexp ctx, sexp self, const char *msg, sexp x);
 SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x);
 SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x);
 SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
+SEXP_API sexp sexp_get_stack_trace (sexp ctx);
 SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
 SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
+SEXP_API sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
 SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
 SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
 SEXP_API sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y);
@@ -1751,7 +1827,7 @@ SEXP_API int sexp_write_utf8_char (sexp ctx, int c, sexp out);
 #define sexp_string_ref(ctx, s, i)    (sexp_string_utf8_index_ref(ctx, NULL, 2, s, i))
 #define sexp_string_set(ctx, s, i, ch) (sexp_string_utf8_index_set(ctx, NULL, 3, s, i, ch))
 #define sexp_string_cursor_ref(ctx, s, i)    (sexp_string_utf8_ref(ctx, s, i))
-#define sexp_string_cursor_set(ctx, s, i)    (sexp_string_utf8_set(ctx, s, i))
+#define sexp_string_cursor_set(ctx, s, i, ch)    (sexp_string_utf8_set(ctx, s, i, ch))
 #define sexp_string_cursor_next(s, i) sexp_make_string_cursor(sexp_unbox_string_cursor(i) + sexp_utf8_initial_byte_count(((unsigned char*)sexp_string_data(s))[sexp_unbox_string_cursor(i)]))
 #define sexp_string_cursor_prev(s, i) sexp_make_string_cursor(sexp_string_utf8_prev((unsigned char*)sexp_string_data(s)+sexp_unbox_string_cursor(i)) - sexp_string_data(s))
 #define sexp_string_length(s) sexp_string_utf8_length((unsigned char*)sexp_string_data(s), sexp_string_size(s))
@@ -1860,6 +1936,7 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp);
 #define sexp_read(ctx, in) sexp_read_op(ctx, NULL, 1, in)
 #define sexp_write(ctx, obj, out) sexp_write_op(ctx, NULL, 2, obj, out)
 #define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx, NULL, 2, e, out)
+#define sexp_print_exception_stack_trace(ctx, e, out) sexp_print_exception_stack_trace_op(ctx, NULL, 2, e, out)
 #define sexp_flush_output(ctx, out) sexp_flush_output_op(ctx, NULL, 1, out)
 #define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx, NULL, 2, a, b)
 #define sexp_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x)

lib/chibi/accept.c

@@ -95,7 +95,7 @@ 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, INET6_ADDRSTRLEN, "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
+  /* snprintf(buf, sizeof(buf), "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
   inet_ntop(addr->sa_family,
             (addr->sa_family == AF_INET6 ?
              (void*)(&(((struct sockaddr_in6 *)addr)->sin6_addr)) :

lib/chibi/app-test.sld

@@ -41,4 +41,9 @@
           (guard (exn (else 'error))
             (run-application zoo-app-spec
                              '("zoo" "--soap" "wash" "--animals" "rhino"))))
+      (let ((out (open-output-string)))
+        (parameterize ((current-output-port out))
+          (run-application zoo-app-spec '("zoo" "help"))
+          (test "Usage: zoo [options] <command>\nCommands:\n  feed animals ... - feed the animals\n  wash animals ... - wash the animals\n  help - print help\nOptions:\n      --animals - list of animals to act on (default all)\n  -l, --lions - also apply the action to lions\n"
+              (get-output-string out))))
       (test-end))))

lib/chibi/app.scm

@@ -1,12 +1,19 @@
 ;; app.scm -- unified option parsing and config
-;; Copyright (c) 2012-2015 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2012-2024 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
-;;> The high-level interface.  Given an application spec \var{spec},
+;;> The high-level interface.  Parses a command-line with optional
-;;> parses the given command-line arguments \var{args} into a config
+;;> and/or positional arguments, with arbitrarily nested subcommands
-;;> object, prepended to the existing object \var{config} if given.
+;;> (optionally having their own arguments), and calls the
-;;> Then runs the corresponding command (or sub-command) procedure
+;;> corresponding main procedure on the parsed config.
-;;> from \var{spec}.
+;;>
+;;> Given an application spec \var{spec}, parses the given
+;;> command-line arguments \var{args} into a config object (from
+;;> \scheme{(chibi config)}), prepended to the existing object
+;;> \var{config} if given.  Then runs the corresponding command (or
+;;> sub-command) procedure from \var{spec} on the following arguments:
+;;>
+;;> \scheme{(<proc> <config> <spec> <positional args> ...)}
 ;;>
 ;;> The app spec should be a list of the form:
 ;;>
@@ -18,6 +25,7 @@
 ;;> \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}
@@ -55,7 +63,43 @@
 ;;> files, whereas the app specs include embedded procedure objects so
 ;;> are typically written with \scheme{quasiquote}.
 ;;>
-;;> Complete Example:
+;;> Complete Example - stripped down ls(1):
+;;>
+;;> \schemeblock{
+;;> (import (scheme base)
+;;>         (scheme process-context)
+;;>         (scheme write)
+;;>         (srfi 130)
+;;>         (chibi app)
+;;>         (chibi config)
+;;>         (chibi filesystem))
+;;>
+;;> (define (ls cfg spec . files)
+;;>   (for-each
+;;>     (lambda (x)
+;;>       (for-each
+;;>         (lambda (file)
+;;>           (unless (and (string-prefix? "." file)
+;;>                        (not (conf-get cfg 'all)))
+;;>             (write-string file)
+;;>             (when (conf-get cfg 'long)
+;;>               (write-string " ")
+;;>               (write (file-modification-time file)))
+;;>             (newline)))
+;;>         (if (file-directory? x) (directory-files x) (list x))))
+;;>     files))
+;;>
+;;> (run-application
+;;>   `(ls
+;;>     "list directory contents"
+;;>     (@
+;;>      (long boolean (#\\l) "use a long listing format")
+;;>      (all boolean (#\\a) "do not ignore entries starting with ."))
+;;>     (,ls files ...))
+;;>   (command-line))
+;;> }
+;;>
+;;> Subcommand Skeleton Example:
 ;;>
 ;;> \schemeblock{
 ;;> (run-application
@@ -63,7 +107,7 @@
 ;;>     "Zookeeper Application"
 ;;>     (@
 ;;>      (animals (list symbol) "list of animals to act on (default all)")
-;;>      (lions boolean (#\l) "also apply the action to lions"))
+;;>      (lions boolean (#\\l) "also apply the action to lions"))
 ;;>     (or
 ;;>      (feed "feed the animals" () (,feed animals ...))
 ;;>      (wash "wash the animals" (@ (soap boolean)) (,wash animals ...))
@@ -125,7 +169,7 @@
   (let ((args (or (and (pair? o) (car o)) (command-line)))
         (config (and (pair? o) (pair? (cdr o)) (cadr o))))
     (cond
-     ((parse-app '() (cdr spec) '() (cdr args) config #f #f)
+     ((parse-app '() (cdr spec) '() (cdr args) config #f #f '())
       => (lambda (v)
            (let ((proc (vector-ref v 0))
                  (cfg (vector-ref v 1))
@@ -150,7 +194,7 @@
 ;;> \var{fail} with a single string argument describing the error,
 ;;> returning that result.
 
-(define (parse-option prefix conf-spec args fail)
+(define (parse-option prefix conf-spec args types fail)
   (define (parse-value type str)
     (cond
      ((not (string? str))
@@ -187,7 +231,10 @@
                    res))
                #f))
         (else
-         (list str #f))))))
+         (cond
+          ((assq type types)
+           => (lambda (cell) (list ((cadr cell) str) #f)))
+          (else (list str #f))))))))
   (define (lookup-conf-spec conf-spec syms strs)
     (let ((sym (car syms))
           (str (car strs)))
@@ -302,7 +349,7 @@
 ;;> is the list of remaining non-option arguments.  Calls fail on
 ;;> error and tries to continue processing from the result.
 
-(define (parse-options prefix conf-spec orig-args fail)
+(define (parse-options prefix conf-spec orig-args types fail)
   (let lp ((args orig-args)
            (opts (make-conf '() #f (cons 'options orig-args) #f)))
     (cond
@@ -312,7 +359,7 @@
           (not (eqv? #\- (string-ref (car args) 0))))
       (cons opts (if (equal? (car args) "--") (cdr args) args)))
      (else
-      (let ((val+args (parse-option prefix conf-spec args fail)))
+      (let ((val+args (parse-option prefix conf-spec args types fail)))
         (lp (cdr val+args)
             (conf-set opts (caar val+args) (cdar val+args))))))))
 
@@ -332,7 +379,7 @@
 ;;> all prefixed by \var{prefix}.  The original \var{spec} is used for
 ;;> \scheme{app-help}.
 
-(define (parse-app prefix spec opt-spec args config init end . o)
+(define (parse-app prefix spec opt-spec args config init end types . o)
   (define (next-prefix prefix name)
     (append (if (null? prefix) '(command) prefix) (list name)))
   (define (prev-prefix prefix)
@@ -367,7 +414,7 @@
      ((null? spec)
       (error "no procedure in application spec"))
      ((or (null? (car spec)) (equal? '(@) (car spec)))
-      (parse-app prefix (cdr spec) opt-spec args config init end fail))
+      (parse-app prefix (cdr spec) opt-spec args config init end types fail))
      ((pair? (car spec))
       (case (caar spec)
         ((@)
@@ -383,38 +430,41 @@
                    (car tail))))
                 (new-fail
                  (lambda (new-prefix new-spec new-opt new-args reason)
-                   (parse-option (prev-prefix prefix) opt-spec new-args fail)))
+                   (parse-option (prev-prefix prefix) opt-spec new-args types fail)))
-                (cfg+args (parse-options prefix new-opt-spec args new-fail))
+                (cfg+args (parse-options prefix new-opt-spec args types new-fail))
                 (config (conf-append (car cfg+args) config))
                 (args (cdr cfg+args)))
            (parse-app prefix (cdr spec) new-opt-spec args config
-                      init end new-fail)))
+                      init end types new-fail)))
         ((or)
-         (any (lambda (x) (parse-app prefix x opt-spec args config init end))
+         (any (lambda (x) (parse-app prefix x opt-spec args config init end types))
               (cdar spec)))
         ((begin:)
          (parse-app prefix (cdr spec) opt-spec args config
-                    (cadr (car spec)) end fail))
+                    (cadr (car spec)) end types fail))
         ((end:)
          (parse-app prefix (cdr spec) opt-spec args config
-                    init (cadr (car spec)) fail))
+                    init (cadr (car spec)) types fail))
+        ((types:)
+         (parse-app prefix (cdr spec) opt-spec args config
+                    init end (cdr (car spec)) fail))
         (else
          (if (procedure? (caar spec))
              (vector (caar spec) config args init end) ; TODO: verify
              (parse-app prefix (car spec) opt-spec args config
-                        init end fail)))))
+                        init end types fail)))))
      ((symbol? (car spec))
       (and (pair? args)
            (eq? (car spec) (string->symbol (car args)))
            (let ((prefix (next-prefix prefix (car spec))))
              (parse-app prefix (cdr spec) opt-spec (cdr args) config
-                        init end fail))))
+                        init end types fail))))
      ((procedure? (car spec))
       (vector (car spec) config args init end))
      (else
       (if (not (string? (car spec)))
           (error "unknown application spec" (car spec)))
-      (parse-app prefix (cdr spec) opt-spec args config init end fail)))))
+      (parse-app prefix (cdr spec) opt-spec args config init end types fail)))))
 
 (define (print-command-help command out)
   (cond
@@ -488,7 +538,7 @@
             (and (pair? (car ls)) (memq (caar ls) '(begin: end:) )))
         (lp (cdr ls) (car ls) commands options))
        ((and (pair? (car ls)) (eq? '@ (caar ls)))
-        (lp (cdr ls) docs commands (append options (cadr (car ls)))))
+        (lp (cdr ls) docs commands (append options (cdar ls))))
        ((and (pair? (car ls)) (symbol? (caar ls)))
         ;; don't print nested commands
         (if (pair? commands)

lib/chibi/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

@@ -98,9 +98,26 @@ sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp pro
   return sexp_make_boolean(sexp_procedure_variadic_p(proc));
 }
 
+sexp sexp_get_procedure_variable_transformer_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_boolean(sexp_procedure_variable_transformer_p(proc));
+}
+
 sexp sexp_get_procedure_flags (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
-  return sexp_make_fixnum(sexp_procedure_flags(proc));
+  return (sexp) (sexp_uint_t) sexp_procedure_flags(proc);
+}
+
+sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) {
+  sexp flags;
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc);
+  if (sexp_procedure_variable_transformer_p(base_proc))
+    return base_proc;
+  flags = sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER);
+  return sexp_make_procedure(ctx, flags,
+                             sexp_make_fixnum(sexp_procedure_num_args(base_proc)),
+                             sexp_procedure_code(base_proc),
+                             sexp_procedure_vars(base_proc));
 }
 
 sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
@@ -347,12 +364,21 @@ sexp sexp_immutablep_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_pointerp(x) ? sexp_make_boolean(sexp_immutablep(x)) : SEXP_TRUE;
 }
 
-sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_immutable_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp s) {
-  if (sexp_pointerp(x)) {
+  sexp res;
-    sexp_immutablep(x) = 1;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, s);
-    return SEXP_TRUE;
+#if SEXP_USE_PACKED_STRINGS
-  }
+  /* no sharing with packed strings */
-  return SEXP_FALSE;
+  res = sexp_c_string(ctx, sexp_string_data(s), sexp_string_size(s));
+#else
+  res = sexp_alloc_type(ctx, string, SEXP_STRING);
+  sexp_string_bytes(res) = sexp_string_bytes(s);
+  sexp_string_offset(res) = sexp_string_offset(s);
+  sexp_string_size(res) = sexp_string_size(s);
+  sexp_copy_on_writep(s) = 1;
+#endif
+  sexp_immutablep(res) = 1;
+  return res;
 }
 
 sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
@@ -488,6 +514,12 @@ sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
 }
 #endif
 
+sexp sexp_thread_interrupt (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  sexp_context_interruptp(thread) = 1;
+  return sexp_make_boolean(ctx == thread);
+}
+
 sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
@@ -645,7 +677,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
   sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
   sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
-  sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
   sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE);
   sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE);
   sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT);
@@ -683,11 +714,14 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   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);
@@ -729,7 +763,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
   sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
   sexp_define_foreign(ctx, env, "immutable?", 1, sexp_immutablep_op);
-  sexp_define_foreign(ctx, env, "make-immutable!", 1, sexp_make_immutable_op);
+  sexp_define_foreign(ctx, env, "immutable-string", 1, sexp_immutable_string_op);
   sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
   sexp_define_foreign_opt(ctx, env, "object->integer", 1, sexp_object_to_integer, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
@@ -738,6 +772,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
 #if SEXP_USE_GREEN_THREADS
   sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
 #endif
+  sexp_define_foreign(ctx, env, "%thread-interrupt!", 1, sexp_thread_interrupt);
   sexp_define_foreign(ctx, env, "thread-list", 0, sexp_thread_list);
   sexp_define_foreign_opt(ctx, env, "string-contains", 3, sexp_string_contains, sexp_make_string_cursor(0));
   sexp_define_foreign(ctx, env, "string-cursor-copy!", 5, sexp_string_cursor_copy);

lib/chibi/ast.scm

@@ -109,6 +109,34 @@
        ((opcode? x) (cond ((opcode-name x) => string->symbol) (else x)))
        (else x)))))
 
+;;> \section{Identifier Macros}
+
+;;> \procedure{(make-variable-transformer proc)}
+
+;;> Returns a new procedure wrapping the input procedure \var{proc}.
+;;> The returned procedure, if used as a macro transformer procedure,
+;;> can expand an instance of \scheme{set!} with its keyword on the
+;;> left hand side.
+
+;;> \macro{(identifier-syntax clauses ...)}
+
+;;> A high-level form for creating identifier macros. See
+;;> \hyperlink["http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-14.html#node_idx_796"]{the R6RS specification.}
+
+(define-syntax identifier-syntax
+  (syntax-rules (set!)
+    ((_ template)
+     (syntax-rules ()
+       ((_ xs (... ...))
+        (template xs (... ...)))
+       (x template)))
+    ((_ (id_1 template_1) ((set! id_2 pattern) template_2))
+     (make-variable-transformer
+      (syntax-rules (set!)
+        ((set! id_2 pattern) template_2)
+        ((id_1 xs (... ...)) (template_1 xs (... ...)))
+        (id_1 template_1))))))
+
 ;;> \section{Types}
 
 ;;> All objects have an associated type, and types may have parent
@@ -408,3 +436,7 @@
  (else
   (define-syntax atomically
     (syntax-rules () ((atomically . body) (begin . body))))))
+
+(define (thread-interrupt! thread)
+  (if (%thread-interrupt! thread)
+      (yield!)))

lib/chibi/ast.sld

@@ -1,7 +1,8 @@
 
 (define-library (chibi ast)
   (export
-   analyze optimize env-cell ast->sexp macroexpand type-of
+   analyze optimize env-cell ast->sexp macroexpand identifier-syntax
+   type-of
    Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env
    Number Bignum Flonum Integer Complex Char Boolean
    Symbol String Byte-Vector Vector Pair File-Descriptor
@@ -25,10 +26,11 @@
    seq-ls seq-ls-set! lit-value lit-value-set!
    exception-kind exception-message exception-irritants exception-source
    opcode-name opcode-num-params opcode-return-type opcode-param-type
-   opcode-class opcode-code opcode-data opcode-variadic?
+   opcode-class opcode-code opcode-data opcode-variadic? opcode?
    macro-procedure macro-env macro-source macro-aux macro-aux-set!
    procedure-code procedure-vars procedure-name procedure-name-set!
-   procedure-arity procedure-variadic? procedure-flags
+   procedure-arity procedure-variadic? procedure-variable-transformer?
+   procedure-flags make-variable-transformer make-procedure procedure?
    bytecode-name bytecode-literals bytecode-source
    port-line port-line-set! port-source? port-source?-set!
    extend-env env-parent env-parent-set! env-lambda env-lambda-set!
@@ -39,7 +41,8 @@
    atomically thread-list abort
    string-contains string-cursor-copy! errno integer->error-string
    flatten-dot update-free-vars! setenv unsetenv safe-setenv
-   immutable? make-immutable!
+   immutable? immutable-string make-immutable!
+   thread-interrupt!
    chibi-version)
   (import (chibi))
   (include-shared "ast")

lib/chibi/binary-record-test.sld

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

lib/chibi/binary-record.scm

@@ -1,6 +1,80 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; binary records
+;; Binary Records
+
+;;> \macro{(define-binary-record-type <name> [<bindings> ...] (block: <fields> ...))}
+;;>
+;;> Defines a new record type that supports serializing to and from
+;;> binary ports.  The generated procedures accept keyword-style
+;;> arguments:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{(make: <constructor-name>)}}
+;;> \item{\scheme{(pred: <predicate-name>)}}
+;;> \item{\scheme{(read: <reader-name>)}}
+;;> \item{\scheme{(write: <writer-name>)}}
+;;> \item{\scheme{(block: <fields> ...)}}
+;;> ]
+;;>
+;;> The fields are also similar to \scheme{define-record-type} but
+;;> with an additional type:
+;;>
+;;> \scheme{(field (type args ...) getter setter)}
+;;>
+;;> Built-in types include:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{(u8)} - a single byte in [0, 255]}
+;;> \item{\scheme{(u16/le)} - a little-endian short integer}
+;;> \item{\scheme{(u16/be)} - a big-endian short integer}
+;;> \item{\scheme{(fixed-string <length>)} - a fixed-length utf-8 string}
+;;> \item{\scheme{(padded-string <length> (pad <pad-char>))} - a utf-8 string padded to a given length}
+;;> \item{\scheme{(octal <length>)} - an integer in octal string format}
+;;> \item{\scheme{(decimal <length>)} - an integer in decimal string format}
+;;> \item{\scheme{(hexadecimal <length>)} - an integer in hexadecimal string format}
+;;> ]
+;;>
+;;> In addition, the field can be a literal (char, string or
+;;> bytevector), for instance as a file magic sequence or fixed
+;;> separator.  The fields (and any constants) are serialized in the
+;;> order they appear in the block.  For example, the header of a GIF
+;;> file could be defined as:
+;;>
+;;> \example{
+;;>  (define-binary-record-type gif-header
+;;>    (make: make-gif-header)
+;;>    (pred: gif-header?)
+;;>    (read: read-gif-header)
+;;>    (write: write-gif-header)
+;;>    (block:
+;;>     "GIF89a"
+;;>     (width (u16/le) gif-header-width)
+;;>     (height (u16/le) gif-header-height)
+;;>     (gct (u8) gif-header-gct)
+;;>     (bgcolor (u8) gif-header-gbcolor)
+;;>     (aspect-ratio (u8) gif-header-aspect-ratio)
+;;>     ))
+;;> }
+;;>
+;;> For a more complex example see the \scheme{(chibi tar)}
+;;> implementation.
+;;>
+;;> The binary type itself is a macro used to expand to a predicate
+;;> and reader/writer procedures, which can be defined with
+;;> \scheme{define-binary-type}.  For example,
+;;>
+;;> \example{
+;;>  (define-binary-type (u8)
+;;>    (lambda (x) (and (exact-integer? x) (<= 0 x 255)))
+;;>    read-u8
+;;>    write-u8)
+;;> }
+
+(define-syntax define-binary-record-type
+  (syntax-rules ()
+    ((define-binary-record-type name x ...)
+     (defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
+       () () ()))))
 
 (define-syntax defrec
   (syntax-rules (make: pred: read: write: block:)
@@ -84,9 +158,3 @@
     ((defrec ((block:) . rest) n m p r w b f s)
      (defrec rest n m p r w b f s))
     ))
-
-(define-syntax define-binary-record-type
-  (syntax-rules ()
-    ((define-binary-record-type name x ...)
-     (defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
-       () () ()))))

lib/chibi/binary-record.sld

@@ -8,6 +8,26 @@
   (cond-expand
    ((library (srfi 130)) (import (srfi 130)))
    (else (import (srfi 13))))
+  (cond-expand
+   ;; ((library (auto))
+   ;;  (import (only (auto) make: pred: read: write: block:)))
+   (else
+    ;; indirect exports for chicken
+    (export defrec define-auxiliary-syntax syntax-let-optionals*)
+    (begin
+      (define-syntax define-auxiliary-syntax
+        (syntax-rules ()
+          ((define-auxiliary-syntax name)
+           (define-syntax name
+             (syntax-rules ()
+               ((name . x)
+                (syntax-error "invalid use of auxiliary syntax"
+                              (name . x))))))))
+      (define-auxiliary-syntax make:)
+      (define-auxiliary-syntax pred:)
+      (define-auxiliary-syntax read:)
+      (define-auxiliary-syntax write:)
+      (define-auxiliary-syntax block:))))
   (export
    ;; interface
    define-binary-record-type
@@ -16,9 +36,8 @@
    octal decimal hexadecimal
    ;; auxiliary syntax
    make: pred: read: write: block:
-   ;; indirect exports
+   ;; new types
-   define-binary-type defrec define-auxiliary-syntax
+   define-binary-type)
-   syntax-let-optionals*)
   (include "binary-types.scm")
   (cond-expand
    (chicken

lib/chibi/binary-types.scm

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

lib/chibi/csv-test.sld

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

lib/chibi/csv.scm

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

lib/chibi/csv.sld

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

lib/chibi/diff-test.sld

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

lib/chibi/diff.scm

@@ -67,13 +67,53 @@
 ;;> ports, which are tokenized into a sequence by calling \var{reader}
 ;;> until \var{eof-object} is found.  Returns a list of three values,
 ;;> the sequences read from \var{a} and \var{b}, and the \scheme{lcs}
-;;> result.
+;;> result.  Unless \var{minimal?} is set, we trim common
+;;> prefixes/suffixes before computing the lcs.
 (define (diff a b . o)
   (let-optionals o ((reader read-line)
-                    (eq equal?))
+                    (eq equal?)
+                    (optimal? #f))
     (let ((a-ls (source->list a reader))
           (b-ls (source->list b reader)))
-      (list a-ls b-ls (lcs-with-positions a-ls b-ls eq)))))
+      (if optimal?
+          (list a-ls b-ls (lcs-with-positions a-ls b-ls eq))
+          (let lp1 ((i 0) (a a-ls) (b b-ls))
+            (cond
+             ((or (null? a) (null? b))  ;; prefix or equal
+              (if (and (null? a) (null? b))
+                  (let ((n-ls (iota (length a-ls))))  ;; equal
+                    (list a-ls b-ls (map list a-ls n-ls n-ls)))
+                  (list a-ls b-ls (lcs-with-positions a-ls b-ls eq))))
+             ((eq (car a) (car b))
+              (lp1 (+ i 1) (cdr a) (cdr b)))
+             (else
+              (let lp2 ((j 0) (ra (reverse a)) (rb (reverse b)))
+                (cond
+                 ((or (null? ra) (null? rb))  ;; can't happen
+                  (list a-ls b-ls (lcs-with-positions a-ls b-ls eq)))
+                 ((eq (car ra) (car rb))
+                  (lp2 (+ j 1) (cdr ra) (cdr rb)))
+                 (else
+                  (let* ((a-ls2 (reverse ra))
+                         (b-ls2 (reverse rb))
+                         (a-left-len (+ i (length a-ls2)))
+                         (b-left-len (+ i (length b-ls2))))
+                    (list a-ls
+                          b-ls
+                          (append
+                           (map (lambda (x i) (list x i i))
+                                (take a-ls i)
+                                (iota i))
+                           (map (lambda (x)
+                                  (list (car x)
+                                        (+ i (cadr x))
+                                        (+ i (car (cddr x)))))
+                                (lcs-with-positions a-ls2 b-ls2 eq))
+                           (map (lambda (x i)
+                                  (list x (+ i a-left-len) (+ i b-left-len)))
+                                (take-right a j)
+                                (iota j))))))
+                 )))))))))
 
 ;;> Utility to format the result of a \var{diff} to output port
 ;;> \var{out} (default \scheme{(current-output-port)}).  Applies
@@ -146,7 +186,7 @@
         (write-string (green line) out))
        ((remove)
         (write-string (red "-") out)
-        (write-string (red line out)))
+        (write-string (red line) out))
        ((same)
         (write-char #\space out)
         (write-string line out))

lib/chibi/disasm.c

@@ -22,13 +22,13 @@
 
 static void sexp_write_pointer (sexp ctx, void *p, sexp out) {
   char buf[32];
-  snprintf(buf, 32, "%p", p);
+  snprintf(buf, sizeof(buf), "%p", p);
   sexp_write_string(ctx, buf, out);
 }
 
 static void sexp_write_integer (sexp ctx, sexp_sint_t n, sexp out) {
   char buf[32];
-  snprintf(buf, 32, SEXP_PRId, n);
+  snprintf(buf, sizeof(buf), SEXP_PRId, n);
   sexp_write_string(ctx, buf, out);
 }
 

lib/chibi/doc-test.sld

@@ -36,4 +36,14 @@
                       " line"))
           (ansi->sxml
            "plain \x1B;[4munder \x1B;[31mred\x1B;[39m line\x1B;[24m"))
+      (test '(code "(" "string?" " "
+                   (span (@ (class . "string")) "\"hello\"")
+                   ")")
+          (expand-docs '(scheme "(string? \"hello\")")
+                       (make-default-doc-env)))
+      (test '(code "(" "string?" " "
+                   (span (@ (class . "string")) "\"<hello>\"")
+                   ")")
+          (expand-docs '(scheme "(string? \"<hello>\")")
+                       (make-default-doc-env)))
       (test-end))))

lib/chibi/doc.scm

@@ -177,9 +177,11 @@
 (define (print-module-docs mod-name . o)
   (let ((out (if (pair? o) (car o) (current-output-port)))
         (render (or (and (pair? o) (pair? (cdr o)) (cadr o))
-                    sxml-display-as-text)))
+                    sxml-display-as-text))
+        (unexpanded?
+         (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (car (cddr o)))))
     (render
-     (generate-docs
+     ((if unexpanded? (lambda (sxml env) (fixup-docs sxml)) generate-docs)
       `((title ,(write-to-string mod-name))
         ,@(extract-module-docs mod-name #f))
       (make-module-doc-env mod-name))
@@ -265,6 +267,8 @@
      (url . ,expand-url)
      (hyperlink . ,expand-hyperlink)
      (rawcode . code)
+     (pre . pre)
+     (bibitem . ,(lambda (x env) '()))  ;; TODO: bibtex
      (code . ,expand-code)
      (codeblock . ,expand-codeblock)
      (ccode
@@ -425,7 +429,7 @@
     sxml)))
 
 (define (expand-procedure sxml env)
-  ((expand-section 'h3) `(,(car sxml) (rawcode ,@(cdr sxml))) env))
+  ((expand-section 'h4) `(,(car sxml) (rawcode ,@(cdr sxml))) env))
 
 (define (expand-macro sxml env)
   (expand-procedure sxml env))
@@ -464,30 +468,42 @@
 (define (get-contents x)
   (if (null? x)
       '()
-      (let ((d (caar x)))
+      (let lp ((ls (cdr x))
-        (let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '()))
+               (depth (caar x))
+               (parent (cadr (car x)))
+               (kids '())
+               (res '()))
         (define (collect)
           (cons `(li ,parent ,(get-contents (reverse kids))) res))
         ;; take a span of all sub-headers, recurse and repeat on next span
         (cond
          ((null? ls)
           `(ol ,@(reverse (collect))))
-           ((> (caar ls) d)
+         ((> (caar ls) depth)
-            (lp (cdr ls) parent (cons (car ls) kids) res))
+          (lp (cdr ls) depth parent (cons (car ls) kids) res))
          (else
-            (lp (cdr ls) (car (cdar ls)) '() (collect))))))))
+          (lp (cdr ls) (caar ls) (cadr (car ls)) '() (collect)))))))
 
 (define (fix-header x)
-  `(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
+  `((!DOCTYPE html)
+    (html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
                         (else '()))
                 "\n"
+                (meta (@ (charset . "UTF-8")))
                 (style (@ (type . "text/css"))
                   "
-body {color: #000; background-color: #FFF}
+body {color: #000; background-color: #FFFFF8;}
-div#menu  {font-size: smaller; position: absolute; top: 50px; left: 0; width: 190px; height: 100%}
+div#menu  {font-size: smaller; position: absolute; top: 50px; left: 0; width: 250px; height: 100%}
-div#main  {position: absolute; top: 0; left: 200px; width: 540px; height: 100%}
+div#menu a:link {text-decoration: none}
-div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;}
+div#main  {font-size: large; position: absolute; top: 0; left: 260px; max-width: 590px; height: 100%}
+div#notes {position: relative; top: 2em; left: 620px; width: 200px; height: 0px; font-size: smaller;}
 div#footer {padding-bottom: 50px}
+div#menu ol {list-style-position:inside; padding-left: 5px; margin-left: 5px}
+div#menu ol ol {list-style: lower-alpha; padding-left: 15px; margin-left: 15px}
+div#menu ol ol ol {list-style: decimal; padding-left: 5px; margin-left: 5px}
+h2 { color: #888888; border-top: 3px solid #4588ba; }
+h3 { color: #666666; border-top: 2px solid #4588ba; }
+h4 { color: #222288; border-top: 1px solid #4588ba; }
 .result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
 .output { color: #000; background-color: beige; width: 100%; padding: 3px}
 .error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px}
@@ -509,7 +525,7 @@ div#footer {padding-bottom: 50px}
                              (cons 'h1 (cdr x))
                              x))
                        x)
-               (div (@ (id . "footer")))))))
+                (div (@ (id . "footer"))))))))
 
 (define (fix-paragraphs x)
   (let lp ((ls x) (p '()) (res '()))
@@ -679,8 +695,6 @@ div#footer {padding-bottom: 50px}
     (('begin body0 ... body) (get-value-signature mod id proc name body))
     (else (get-procedure-signature mod id proc))))
 
-;; TODO: analyze and match on AST instead of making assumptions about
-;; bindings
 (define (get-signature mod id proc source form)
   (match form
     (('define (name args ...) . body)
@@ -694,7 +708,11 @@ div#footer {padding-bottom: 50px}
      (map (lambda (x) (cons name (cdr x)))
           (filter external-clause? clause)))
     (else
-     (get-procedure-signature mod id proc))))
+     (cond
+      ((procedure-analysis proc mod)
+       => (lambda (lam) (list (cons (lambda-name lam) (lambda-params lam)))))
+      (else
+       (get-procedure-signature mod id proc))))))
 
 (define (get-ffi-signatures form)
   (match form
@@ -707,6 +725,8 @@ div#footer {padding-bottom: 50px}
                               args)))))
     (('define-c-const type (or (name _) name))
      (list (list 'const: type name)))
+    (('cond-expand (test . clauses) . rest)
+     (append-map get-ffi-signatures clauses))
     (((or 'define-c-struct 'define-c-class 'define-c-type) name . rest)
      (let lp ((ls rest) (res '()))
        (cond
@@ -735,7 +755,7 @@ div#footer {padding-bottom: 50px}
   (let ((sections '(section subsection subsubsection subsubsubsection)))
     (lambda (x)
       (cond ((memq x sections) => length)
-            ((memq x '(procedure macro)) (section-number 'subsection))
+            ((memq x '(procedure macro)) (section-number 'subsubsection))
             (else 0)))))
 
 (define (section>=? x n)
@@ -793,9 +813,10 @@ div#footer {padding-bottom: 50px}
       (write-to-string sig)))
 
 (define (insert-signature orig-ls name sig)
+  (let ((sig (if (pair? sig) sig (and name (list name)))))
     (cond
     ((not (pair? sig))
-    orig-ls)
+     '())
     (else
      (let ((name
             (cond
@@ -806,15 +827,16 @@ div#footer {padding-bottom: 50px}
        (let lp ((ls orig-ls) (rev-pre '()))
          (cond
           ((or (null? ls)
-              (section>=? (car ls) (section-number 'subsection)))
+               (section>=? (car ls) (section-number 'subsubsection)))
            `(,@(reverse rev-pre)
              ,@(if (and (pair? ls)
                         (section-describes?
-                        (extract-sxml '(subsection procedure macro)
+                         (extract-sxml
+                          '(subsubsection procedure macro)
                           (car ls))
                          name))
                    '()
-                  `((subsection
+                   `((subsubsection
                       tag: ,(write-to-string name)
                       (rawcode
                        ,@(if (and (pair? (car sig)) (eq? 'const: (caar sig)))
@@ -823,7 +845,7 @@ div#footer {padding-bottom: 50px}
                              (intersperse (map write-signature sig) '(br)))))))
              ,@ls))
           (else
-          (lp (cdr ls) (cons (car ls) rev-pre)))))))))
+           (lp (cdr ls) (cons (car ls) rev-pre))))))))))
 
 ;;> Extract inline Scribble documentation (with the ;;> prefix) from
 ;;> the source file \var{file}, associating any signatures from the
@@ -831,17 +853,22 @@ div#footer {padding-bottom: 50px}
 
 (define (extract-file-docs mod file all-defs strict? . o)
   ;; extract (<file> . <line>) macro source or
-  ;; (<offset> <file . <line>>) procedure source
+  ;; (<offset> <file . <line>) procedure source or
+  ;; ((<offset> <file . <line>) ...) bytecode sources
   (define (source-line source)
     (and (pair? source)
-         (if (string? (car source))
+         (cond
+          ((string? (car source))
            (and (equal? file (car source))
                 (number? (cdr source))
-                  (cdr source))
+                (cdr source)))
+          ((pair? (car source))
+           (source-line (car source)))
+          (else
            (and (number? (car source))
                 (pair? (cdr source))
                 (equal? file (cadr source))
-                  (cddr source)))))
+                (cddr source))))))
   (define (read-to-paren in)
     (let lp1 ((res '()))
       (let ((ch (peek-char in)))
@@ -1014,7 +1041,8 @@ div#footer {padding-bottom: 50px}
 (define (extract-module-docs-from-files mod srcs includes stubs strict? exports . o)
   (let ((dir (or (and (pair? o) (car o)) (module-dir mod)))
         (defs (map (lambda (x)
-                     (let ((val (and mod (module-ref mod x))))
+                     (let ((val (and mod (protect (exn (else #f))
+                                           (module-ref mod x)))))
                        `(,x ,val ,(object-source val))))
                    exports)))
     (define (resolve-file file)

lib/chibi/equiv.scm

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

lib/chibi/filesystem.scm

@@ -104,7 +104,9 @@
 (define (with-directory dir thunk)
   (let ((pwd (current-directory)))
     (dynamic-wind
-      (lambda () (change-directory dir))
+      (lambda ()
+        (if (not (change-directory dir))
+            (error "couldn't change directory" dir)))
       thunk
       (lambda () (change-directory pwd)))))
 

lib/chibi/highlight.scm

@@ -121,10 +121,6 @@
     (cond
      ((eof-object? c) (reverse-list->string ls))
      ((eqv? c term) (reverse-list->string (cons c ls)))
-     ((eqv? c #\<) (read-escaped in term `(#\; #\t #\l #\& ,@ls)))
-     ;;((eqv? c #\>) (read-escaped in term `(#\; #\t #\g #\& ,@ls)))
-     ((eqv? c #\&) (read-escaped in term `(#\; #\p #\m #\a #\& ,@ls)))
-     ((eqv? c #\\) (read-escaped in term (cons (read-char in) (cons c ls))))
      (else (read-escaped in term (cons c ls))))))
 
 (define (read-to-eol in ls)
@@ -134,9 +130,6 @@
      ((eqv? c #\newline) (reverse-list->string (cons c ls)))
      (else (read-to-eol in (cons c ls))))))
 
-(define (html-escape str)
-  (call-with-input-string str (lambda (in) (read-escaped in #f '()))))
-
 (define (collect str res)
   (if (pair? str) (cons (reverse-list->string str) res) res))
 

lib/chibi/io-test.sld

@@ -134,6 +134,20 @@
             (read-string 4096 in)
             (read-line in)))
 
+      (let ((bv (string->utf8 "日本語")))
+        (test #\日 (utf8-ref bv 0))
+        (test #\本 (utf8-ref bv 3))
+        (test #\語 (utf8-ref bv 6))
+        (test 3 (utf8-next bv 0 9))
+        (test 6 (utf8-next bv 3 9))
+        (test 9 (utf8-next bv 6 9))
+        (test #f (utf8-next bv 9 9))
+        (test 6 (utf8-prev bv 9 0))
+        (test 3 (utf8-prev bv 6 0))
+        (test 0 (utf8-prev bv 3 0))
+        (test #f (utf8-prev bv 0 0))
+        )
+
       (test #u8(0 1 2)
         (let ((in (bytevectors->input-port (list #u8(0 1 2)))))
           (read-bytevector 3 in)))

lib/chibi/io.sld

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

lib/chibi/io/io.scm

@@ -9,25 +9,10 @@
   (call-with-input-string " "
     (lambda (in) (read-char in) (read-char in))))
 
-;; Copy whole characters from the given cursor positions.
-;; Return the src cursor position of the next unwritten char,
-;; which may be before `to' if the char would overflow.
-;; Now provided as a primitive from (chibi ast).
-;; (define (string-cursor-copy! dst start src from to)
-;;   (let lp ((i from)
-;;            (j (string-cursor->index dst start)))
-;;     (let ((i2 (string-cursor-next src i)))
-;;       (cond ((> i2 to) i)
-;;             (else
-;;              (string-set! dst j (string-cursor-ref src i))
-;;              (lp i2 (+ j 1)))))))
-
 (define (utf8->string vec . o)
-  (if (pair? o)
+  (let ((start (if (pair? o) (car o) 0))
-      (let ((start (car o))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (bytevector-length vec))))
-            (end (if (pair? (cdr o)) (cadr o) (bytevector-length vec))))
+    (string-copy (utf8->string! vec start end))))
-        (utf8->string (subbytes vec start end)))
-      (string-copy (utf8->string! vec))))
 
 (define (string->utf8 str . o)
   (if (pair? o)

lib/chibi/io/io.stub

@@ -50,8 +50,19 @@
   ((value ctx sexp) (value self sexp) sexp sexp sexp (default NULL sexp)))
 (define-c sexp (%string->utf8 "sexp_string_to_utf8")
   ((value ctx sexp) (value self sexp) sexp))
-(define-c sexp (utf8->string! "sexp_utf8_to_string_x")
+(define-c sexp (string->utf8! "sexp_string_to_utf8_x")
   ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (string-offset "sexp_string_offset_op")
+  ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (utf8->string! "sexp_utf8_to_string_x")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+
+(define-c sexp (utf8-ref "sexp_utf8_ref")
+  ((value ctx sexp) (value self sexp) sexp sexp))
+(define-c sexp (utf8-next "sexp_utf8_next")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+(define-c sexp (utf8-prev "sexp_utf8_prev")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
 
 (define-c sexp (write-u8 "sexp_write_u8")
   ((value ctx sexp) (value self sexp) sexp (default (current-output-port) sexp)))

lib/chibi/io/port.c

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

lib/chibi/iset-test.sld

@@ -243,4 +243,17 @@
         (test-assert (iset-contains? (iset-union a b) 119))
         (test-assert (iset-contains? (iset-union b a) 119)))
 
+      (let* ((elts '(0 1 5 27 42 113 114 256))
+             (is (list->iset elts)))
+        (test (iota (length elts))
+            (map (lambda (elt) (iset-rank is elt)) elts))
+        (test elts
+            (map (lambda (i) (iset-select is i)) (iota (length elts)))))
+
+      (let* ((elts '(903 595 694 581 91 628 648 152 188 29 347 876 381 945 508 890 816 654 871 228 200 397 116 952 60 878 361 205 691 318 87 998 35 886 580 787 856 535 964 133 245 314 711 598 180 984 458 235 599 692 568 1 740 514 995 930 625 638 881 997 412 151 195 512 857 948 956 750 896 813 988 40 85 426 740 83 294 249 235 45 20 784 837 640 56 519 211 780 771 684 408 510 677 773 574 114 537 934 477 136))
+             (is (list->iset elts)))
+        (test elts
+            (map (lambda (i) (iset-select is i))
+                 (map (lambda (elt) (iset-rank is elt)) elts))))
+
       (test-end))))

lib/chibi/iset.sld

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

lib/chibi/iset/iterators.scm

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

lib/chibi/iset/iterators.sld

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

lib/chibi/json-test.sld

@@ -9,6 +9,8 @@
       (test 1 (string->json "1"))
       (test 1.5 (string->json "1.5"))
       (test 1000.0 (string->json "1e3"))
+      (test 'null (string->json "null"))
+      (test '((null . 3)) (string->json "{\"null\": 3}"))
       (test "á" (string->json "\"\\u00e1\""))
       (test "𐐷" (string->json "\"\\uD801\\uDC37\""))
       (test "😐" (string->json "\"\\uD83D\\uDE10\""))
@@ -119,6 +121,8 @@
       (test "1" (json->string 1))
       (test "1.5" (json->string 1.5))
       (test "1000" (json->string 1E3))
+      (test "null" (json->string 'null))
+      (test "{\"null\":3}" (json->string  '((null . 3))))
       (test  "\"\\u00E1\"" (json->string "á"))
       (test  "\"\\uD801\\uDC37\"" (json->string "𐐷"))
       (test  "\"\\uD83D\\uDE10\"" (json->string "😐"))

lib/chibi/json.c

@@ -65,7 +65,7 @@ sexp json_read_number (sexp ctx, sexp self, sexp in) {
     res *= pow(10.0, scale_sign * scale);
   }
   if (ch != EOF) sexp_push_char(ctx, ch, in);
-  return (inexactp || fabs(res) > SEXP_MAX_FIXNUM) ?
+  return (inexactp || fabs(res) > (double)SEXP_MAX_FIXNUM) ?
     sexp_make_flonum(ctx, sign * res) :
     sexp_make_fixnum(sign * res);  /* always return inexact? */
 }
@@ -293,7 +293,7 @@ sexp json_read (sexp ctx, sexp self, sexp in) {
     res = json_read_number(ctx, self, in);
     break;
   case 'n': case 'N':
-    res = json_read_literal(ctx, self, in, "null", SEXP_VOID);
+    res = json_read_literal(ctx, self, in, "null", sexp_intern(ctx, "null", -1));
     break;
   case 't': case 'T':
     res = json_read_literal(ctx, self, in, "true", SEXP_TRUE);
@@ -406,30 +406,43 @@ sexp json_write_array(sexp ctx, sexp self, const sexp obj, sexp out) {
 }
 
 sexp json_write_object(sexp ctx, sexp self, const sexp obj, sexp out) {
-  sexp ls, cur, key, val, tmp;
+  sexp ls, cur, key, val;
+  sexp_gc_var2(tmp, res);
   if (sexp_length(ctx, obj) == SEXP_FALSE)
-    return sexp_json_write_exception(ctx, self, "unable to encode circular list", obj);
+     sexp_json_write_exception(ctx, self, "unable to encode circular list", obj);
+  sexp_gc_preserve2(ctx, tmp, res);
+  res = SEXP_VOID;
   sexp_write_char(ctx, '{', out);
   for (ls = obj; sexp_pairp(ls); ls = sexp_cdr(ls)) {
     if (ls != obj)
       sexp_write_char(ctx, ',', out);
     cur = sexp_car(ls);
-    if (!sexp_pairp(cur))
+    if (!sexp_pairp(cur)) {
-      return sexp_json_write_exception(ctx, self, "unable to encode key-value pair: not a pair", obj);
+      res = sexp_json_write_exception(ctx, self, "unable to encode key-value pair: not a pair", obj);
+      break;
+    }
     key = sexp_car(cur);
-    if (!sexp_symbolp(key))
+    if (!sexp_symbolp(key)) {
-      return sexp_json_write_exception(ctx, self, "unable to encode key: not a symbol", key);
+      res = sexp_json_write_exception(ctx, self, "unable to encode key: not a symbol", key);
-    tmp = json_write(ctx, self, key, out);
+      break;
-    if (sexp_exceptionp(tmp))
+    }
-      return tmp;
+    tmp = sexp_symbol_to_string(ctx, key);
+    tmp = json_write(ctx, self, tmp, out);
+    if (sexp_exceptionp(tmp)) {
+      res = tmp;
+      break;
+    }
     sexp_write_char(ctx, ':', out);
     val = sexp_cdr(cur);
     tmp = json_write(ctx, self, val, out);
-    if (sexp_exceptionp(tmp))
+    if (sexp_exceptionp(tmp)) {
-      return tmp;
+      res = tmp;
+      break;
+    }
   }
   sexp_write_char(ctx, '}', out);
-  return SEXP_VOID;
+  sexp_gc_release2(ctx);
+  return res;
 }
 
 sexp json_write (sexp ctx, sexp self, const sexp obj, sexp out) {
@@ -437,8 +450,7 @@ sexp json_write (sexp ctx, sexp self, const sexp obj, sexp out) {
   sexp_gc_preserve1(ctx, res);
   res = SEXP_VOID;
   if (sexp_symbolp(obj)) {
-    res = sexp_symbol_to_string(ctx, obj);
+    res = sexp_write(ctx, obj, out);
-    res = json_write_string(ctx, self, res, out);
   } else if (sexp_stringp(obj)) {
     res = json_write_string(ctx, self, obj, out);
   } else if (sexp_listp(ctx, obj) == SEXP_TRUE) {

lib/chibi/log-test.sld

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

lib/chibi/loop.sld

@@ -2,7 +2,7 @@
 (define-library (chibi loop)
   (export loop for in-list in-lists in-port in-file up-from down-from
           listing listing-reverse appending appending-reverse
-          summing multiplying in-string in-string-reverse
+          summing multiplying in-string in-string-reverse in-substrings
           in-vector in-vector-reverse)
   (import (chibi))
   (include "loop/loop.scm"))

lib/chibi/loop/loop.scm

@@ -268,6 +268,26 @@
        . rest))
     ))
 
+;;> \macro{(for substr (in-substrings k str))}
+
+(define (string-cursor-forward str cursor n)
+  (if (positive? n)
+      (string-cursor-forward str (string-cursor-next str cursor) (- n 1))
+      cursor))
+
+(define-syntax in-substrings
+  (syntax-rules ()
+    ((in-substrings ((ch) (k str)) next . rest)
+     (next ((tmp str) (end (string-cursor-end tmp)))
+           ((sc1 (string-cursor-start tmp)
+                 (string-cursor-next tmp sc1))
+            (sc2 (string-cursor-forward tmp (string-cursor-start tmp) k)
+                 (string-cursor-next tmp sc2)))
+           ((string-cursor>? sc2 end))
+           ((ch (substring-cursor tmp sc1 sc2)))
+           ()
+       . rest))))
+
 ;;> \macro{(for ch (in-port [input-port [reader [eof?]]]))}
 
 (define-syntax in-port
@@ -368,14 +388,14 @@
      (accumulating (kons final i) ((var cursor) x) n . rest))
     ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
      (n ((tmp-kons kons))
-        ((cursor '() (if check (tmp-kons expr cursor) cursor)))
+        ((cursor init (if check (tmp-kons expr cursor) cursor)))
         ()
         ()
         ((var (final cursor)))
         . rest))
     ((accumulating (kons final init) ((var cursor) (expr)) n . rest)
      (n ((tmp-kons kons))
-        ((cursor '() (tmp-kons expr cursor)))
+        ((cursor init (tmp-kons expr cursor)))
         ()
         ()
         ((var (final cursor)))

lib/chibi/match-test.sld

@@ -31,19 +31,36 @@
       (test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
       (test "or single" 'ok (match 'ok ((or x) 'ok)))
       (test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
+      (test "or unbalanced" 1  (match 1 ((or (and 1 x) (and 2 y)) x)))
       (test "not" 'ok (match 28 ((not (a . b)) 'ok)))
+      (test "not fail" 'bad (match 28 ((not a) 'ok) (else 'bad)))
+      (test "not and" #t (match 1 ((and (not 2)) #t)))
       (test "pred" 'ok (match 28 ((? number?) 'ok)))
       (test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
 
       (test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
       (test "duplicate symbols fail" 'ok
         (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
+      (test "duplicate symbols fail 2" 'ok
+        (match '(ok bad) ((x x) 'bad) (else 'ok)))
       (test "duplicate symbols samth" 'ok
         (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
       (test "duplicate symbols bound" 3
         (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f))))
       (test "duplicate quasiquote" 'ok
         (match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ #f)))
+      (test "duplicate before ellipsis" #f
+        (match '(1 2) ((a a ...) a) (else #f)))
+      (test "duplicate ellipsis pass" '(1 2)
+        (match '((1 2) (1 2)) (((x ...) (x ...)) x) (else #f)))
+      (test "duplicate ellipsis fail" #f
+        (match '((1 2) (1 2 3)) (((x ...) (x ...)) x) (else #f)))
+      (test "duplicate ellipsis trailing" '(1 2)
+        (match '((1 2 3) (1 2 3)) (((x ... 3) (x ... 3)) x) (else #f)))
+      (test "duplicate ellipsis trailing fail" #f
+        (match '((1 2 3) (1 1 3)) (((x ... 3) (x ... 3)) x) (else #f)))
+      (test "duplicate ellipsis fail trailing" #f
+        (match '((1 2 3) (1 2 4)) (((x ... 3) (x ... 3)) x) (else #f)))
 
       (test "ellipses" '((a b c) (1 2 3))
         (match '((a . 1) (b . 2) (c . 3))
@@ -62,6 +79,9 @@
           (((? odd? n) ___) n)
           (((? number? n) ___) n)))
 
+      (test "ellipsis trailing" '(3 1 2)
+        (match '(1 2 3) ((x ... y) (cons y x)) (else #f)))
+
       (test "failure continuation" 'ok
         (match '(1 2)
           ((a . b) (=> next) (if (even? a) 'fail (next)))
@@ -105,6 +125,9 @@
         (match '((a . 1) (b . 2) 3)
           (((x . y) ... last) (list x y last))))
 
+      (test "single duplicate tail" #f
+        (match '(1 2) ((foo ... foo) foo) (_ #f)))
+
       (test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
         (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
           (((x . y) ... u v w) (list x y u v w))))
@@ -178,50 +201,50 @@
       (test "joined tail" '(1 2)
         (match '(1 2 3) ((and (a ... b) x) a)))
 
-      (test "list ..1" '(a b c)
+      (test "list **1" '(a b c)
-        (match '(a b c) ((x ..1) x)))
+        (match '(a b c) ((x **1) x)))
 
-      (test "list ..1 failed" #f
+      (test "list **1 failed" #f
         (match '()
-          ((x ..1) x)
+          ((x **1) x)
           (else #f)))
 
-      (test "list ..1 with predicate" '(a b c)
+      (test "list **1 with predicate" '(a b c)
         (match '(a b c)
-          (((and x (? symbol?)) ..1) x)))
+          (((and x (? symbol?)) **1) x)))
 
-      (test "list ..1 with failed predicate" #f
+      (test "list **1 with failed predicate" #f
         (match '(a b 3)
-          (((and x (? symbol?)) ..1) x)
+          (((and x (? symbol?)) **1) x)
           (else #f)))
 
-      (test "list ..= too few" #f
+      (test "list =.. too few" #f
-        (match (list 1 2) ((a b ..= 2) b) (else #f)))
+        (match (list 1 2) ((a b =.. 2) b) (else #f)))
-      (test "list ..=" '(2 3)
+      (test "list =.." '(2 3)
-        (match (list 1 2 3) ((a b ..= 2) b) (else #f)))
+        (match (list 1 2 3) ((a b =.. 2) b) (else #f)))
-      (test "list ..= too many" #f
+      (test "list =.. too many" #f
-        (match (list 1 2 3 4) ((a b ..= 2) b) (else #f)))
+        (match (list 1 2 3 4) ((a b =.. 2) b) (else #f)))
-      (test "list ..= tail" 4
+      (test "list =.. tail" 4
-        (match (list 1 2 3 4) ((a b ..= 2 c) c) (else #f)))
+        (match (list 1 2 3 4) ((a b =.. 2 c) c) (else #f)))
-      (test "list ..= tail fail" #f
+      (test "list =.. tail fail" #f
-        (match (list 1 2 3 4 5 6) ((a b ..= 2 c) c) (else #f)))
+        (match (list 1 2 3 4 5 6) ((a b =.. 2 c) c) (else #f)))
 
-      (test "list ..* too few" #f
+      (test "list *.. too few" #f
-        (match (list 1 2) ((a b ..* 2 4) b) (else #f)))
+        (match (list 1 2) ((a b *.. 2 4) b) (else #f)))
-      (test "list ..* lo" '(2 3)
+      (test "list *.. lo" '(2 3)
-        (match (list 1 2 3) ((a b ..* 2 4) b) (else #f)))
+        (match (list 1 2 3) ((a b *.. 2 4) b) (else #f)))
-      (test "list ..* hi" '(2 3 4 5)
+      (test "list *.. hi" '(2 3 4 5)
-        (match (list 1 2 3 4 5) ((a b ..* 2 4) b) (else #f)))
+        (match (list 1 2 3 4 5) ((a b *.. 2 4) b) (else #f)))
-      (test "list ..* too many" #f
+      (test "list *.. too many" #f
-        (match (list 1 2 3 4 5 6) ((a b ..* 2 4) b) (else #f)))
+        (match (list 1 2 3 4 5 6) ((a b *.. 2 4) b) (else #f)))
-      (test "list ..* tail" 4
+      (test "list *.. tail" 4
-        (match (list 1 2 3 4) ((a b ..* 2 4 c) c) (else #f)))
+        (match (list 1 2 3 4) ((a b *.. 2 4 c) c) (else #f)))
-      (test "list ..* tail 2" 5
+      (test "list *.. tail 2" 5
-        (match (list 1 2 3 4 5) ((a b ..* 2 4 c d) d) (else #f)))
+        (match (list 1 2 3 4 5) ((a b *.. 2 4 c d) d) (else #f)))
-      (test "list ..* tail" 6
+      (test "list *.. tail" 6
-        (match (list 1 2 3 4 5 6) ((a b ..* 2 4 c) c) (else #f)))
+        (match (list 1 2 3 4 5 6) ((a b *.. 2 4 c) c) (else #f)))
-      (test "list ..* tail fail" #f
+      (test "list *.. tail fail" #f
-        (match (list 1 2 3 4 5 6 7) ((a b ..* 2 4 c) c) (else #f)))
+        (match (list 1 2 3 4 5 6 7) ((a b *.. 2 4 c) c) (else #f)))
 
       (test "match-named-let" 6
         (match-let loop (((x . rest) '(1 2 3))
@@ -231,10 +254,20 @@
                 sum
                 (loop rest sum)))))
 
-      '(test "match-letrec" '(2 1 1 2)
+      (test "match-letrec" '(2 1 1 2)
           (match-letrec (((x y) (list 1 (lambda () (list a x))))
                          ((a b) (list 2 (lambda () (list x a)))))
                         (append (y) (b))))
+      (test "match-letrec quote" #t
+        (match-letrec (((x 'x) (list #t 'x))) x))
+      (let-syntax
+        ((foo
+          (syntax-rules ()
+            ((foo x)
+             (match-letrec (((x y) (list 1 (lambda () (list a x))))
+                            ((a b) (list 2 (lambda () (list x a)))))
+                           (append (y) (b)))))))
+        (test "match-letrec mnieper" '(2 1 1 2) (foo a)))
 
       (cond-expand
        (chibi

lib/chibi/match/match.scm

@@ -32,6 +32,11 @@
 
 ;;> If no patterns match an error is signalled.
 
+;;> Note there is no \scheme{else} clause.  \scheme{else} is sometimes
+;;> used descriptively for the last pattern, since an identifier used
+;;> only once matches anything, but it's preferred to use \scheme{_}
+;;> described below.
+
 ;;> Identifiers will match anything, and make the corresponding
 ;;> binding available in the body.
 
@@ -86,19 +91,26 @@
 ;;> \scheme{___} is provided as an alias for \scheme{...} when it is
 ;;> inconvenient to use the ellipsis (as in a syntax-rules template).
 
-;;> The \scheme{..1} syntax is exactly like the \scheme{...} except
+;;> The \scheme{**1} syntax is exactly like the \scheme{...} except
 ;;> that it matches one or more repetitions (like a regexp "+").
 
-;;> \example{(match (list 1 2) ((a b c ..1) c))}
+;;> \example{(match (list 1 2) ((a b c **1) c))}
-;;> \example{(match (list 1 2 3) ((a b c ..1) c))}
+;;> \example{(match (list 1 2 3) ((a b c **1) c))}
 
-;;> The \scheme{..=} syntax is like \scheme{...} except that it takes
+;;> The \scheme{*..} syntax is like \scheme{...} except that it takes
-;;> a tailing integer \scheme{<n>} and requires the pattern to match
+;;> two trailing integers \scheme{<n>} and \scheme{<m>}, and requires
-;;> exactly \scheme{<n>} times.
+;;> the pattern to match from \scheme{<n>} times.
 
-;;> \example{(match (list 1 2) ((a b ..= 2) b))}
+;;> \example{(match (list 1 2 3) ((a b *.. 2 4) b))}
-;;> \example{(match (list 1 2 3) ((a b ..= 2) b))}
+;;> \example{(match (list 1 2 3 4 5 6) ((a b *.. 2 4) b))}
-;;> \example{(match (list 1 2 3 4) ((a b ..= 2) b))}
+;;> \example{(match (list 1 2 3 4) ((a b *.. 2 4 c) c))}
+
+;;> The \scheme{(<expr> =.. <n>)} syntax is a shorthand for
+;;> \scheme{(<expr> *.. <n> <n>)}.
+
+;;> \example{(match (list 1 2) ((a b =.. 2) b))}
+;;> \example{(match (list 1 2 3) ((a b =.. 2) b))}
+;;> \example{(match (list 1 2 3 4) ((a b =.. 2) b))}
 
 ;;> The boolean operators \scheme{and}, \scheme{or} and \scheme{not}
 ;;> can be used to group and negate patterns analogously to their
@@ -121,7 +133,7 @@
 ;;> are bound if the \scheme{or} operator matches, but the binding is
 ;;> only defined for identifiers from the subpattern which matched.
 
-;;> \example{(match 1 ((or) #t) (else #f))}
+;;> \example{(match 1 ((or) #t) (_ #f))}
 ;;> \example{(match 1 ((or x) x))}
 ;;> \example{(match 1 ((or x 2) x))}
 
@@ -235,7 +247,11 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
-;; 2020/07/06 - adding `..=' and `..*' patterns; fixing ,@ patterns
+;; 2021/06/21 - fix for `(a ...)' patterns where `a' is already bound
+;;              (thanks to Andy Wingo)
+;; 2020/09/04 - perf fix for `not`; rename `..=', `..=', `..1' per SRFI 204
+;; 2020/08/21 - fixing match-letrec with unhygienic insertion
+;; 2020/07/06 - adding `..=' and `..=' patterns; fixing ,@ patterns
 ;; 2016/10/05 - treat keywords as literals, not identifiers, in Chicken
 ;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe)
 ;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns
@@ -265,7 +281,7 @@
 
 (define-syntax match-syntax-error
   (syntax-rules ()
-    ((_) (match-syntax-error "invalid match-syntax-error usage"))))
+    ((_) (syntax-error "invalid match-syntax-error usage"))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -361,7 +377,7 @@
 ;; pattern so far.
 
 (define-syntax match-two
-  (syntax-rules (_ ___ ..1 ..= ..* *** quote quasiquote ? $ struct @ object = and or not set! get!)
+  (syntax-rules (_ ___ **1 =.. *.. *** quote quasiquote ? $ struct @ object = and or not set! get!)
     ((match-two v () g+s (sk ...) fk i)
      (if (null? v) (sk ... i) fk))
     ((match-two v (quote p) g+s (sk ...) fk i)
@@ -377,7 +393,8 @@
     ((match-two v (or p ...) g+s sk fk i)
      (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
     ((match-two v (not p) g+s (sk ...) fk i)
-     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
+     (let ((fk2 (lambda () (sk ... i))))
+       (match-one v p g+s (match-drop-ids fk) (fk2) i)))
     ((match-two v (get! getter) (g s) (sk ...) fk i)
      (let ((getter (lambda () g))) (sk ... i)))
     ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
@@ -397,15 +414,15 @@
      (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
     ((match-two v (p *** . q) g+s sk fk i)
      (match-syntax-error "invalid use of ***" (p *** . q)))
-    ((match-two v (p ..1) g+s sk fk i)
+    ((match-two v (p **1) g+s sk fk i)
      (if (pair? v)
          (match-one v (p ___) g+s sk fk i)
          fk))
-    ((match-two v (p ..= n . r) g+s sk fk i)
+    ((match-two v (p =.. n . r) g+s sk fk i)
      (match-extract-vars
       p
       (match-gen-ellipsis/range n n v p r g+s sk fk i) i ()))
-    ((match-two v (p ..* n m . r) g+s sk fk i)
+    ((match-two v (p *.. n m . r) g+s sk fk i)
      (match-extract-vars
       p
       (match-gen-ellipsis/range n m v p r g+s sk fk i) i ()))
@@ -523,7 +540,8 @@
 (define-syntax match-gen-or
   (syntax-rules ()
     ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
-     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
+     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))
+           (id (if #f #f)) ...)
        (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
 
 (define-syntax match-gen-or-step
@@ -553,12 +571,13 @@
 
 (define-syntax match-gen-ellipsis
   (syntax-rules ()
+    ;; TODO: restore fast path when p is not already bound
     ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
      (match-check-identifier p
-       ;; simplest case equivalent to (p ...), just bind the list
+       ;; simplest case equivalent to (p ...), just match the list
-       (let ((p v))
+       (let ((w v))
-         (if (list? p)
+         (if (list? w)
-             (sk ... i)
+             (match-one w p g+s (sk ...) fk i)
              fk))
        ;; simple case, match all elements of the list
        (let loop ((ls v) (id-ls '()) ...)
@@ -572,11 +591,28 @@
                          fk i)))
            (else
             fk)))))
-    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
+    ((_ v p r g+s sk fk (i ...) ((id id-ls) ...))
-     ;; general case, trailing patterns to match, keep track of the
-     ;; remaining list length so we don't need any backtracking
      (match-verify-no-ellipsis
       r
+      (match-bound-identifier-memv
+       p
+       (i ...)
+       ;; p is bound, match the list up to the known length, then
+       ;; match the trailing patterns
+       (let loop ((ls v) (expect p))
+         (cond
+          ((null? expect)
+           (match-one ls r (#f #f) sk fk (i ...)))
+          ((pair? ls)
+           (let ((w (car ls))
+                 (e (car expect)))
+             (if (equal? (car ls) (car expect))
+                 (match-drop-ids (loop (cdr ls) (cdr expect)))
+                 fk)))
+          (else
+           fk)))
+       ;; general case, trailing patterns to match, keep track of
+       ;; the remaining list length so we don't need any backtracking
        (let* ((tail-len (length 'r))
               (ls v)
               (len (and (list? ls) (length ls))))
@@ -586,22 +622,23 @@
                (cond
                 ((= n tail-len)
                  (let ((id (reverse id-ls)) ...)
-                   (match-one ls r (#f #f) (sk ...) fk i)))
+                   (match-one ls r (#f #f) sk fk (i ... id ...))))
                 ((pair? ls)
                  (let ((w (car ls)))
                    (match-one w p ((car ls) (set-car! ls))
                               (match-drop-ids
                                (loop (cdr ls) (- n 1) (cons id id-ls) ...))
                               fk
-                              i)))
+                              (i ...))))
                 (else
-                 fk)))))))))
+                 fk)))
+           )))))))
 
 ;; Variant of the above where the rest pattern is in a quasiquote.
 
 (define-syntax match-gen-ellipsis/qq
   (syntax-rules ()
-    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
+    ((_ v p r g+s (sk ...) fk (i ...) ((id id-ls) ...))
      (match-verify-no-ellipsis
       r
       (let* ((tail-len (length 'r))
@@ -613,14 +650,14 @@
               (cond
                ((= n tail-len)
                 (let ((id (reverse id-ls)) ...)
-                  (match-quasiquote ls r g+s (sk ...) fk i)))
+                  (match-quasiquote ls r g+s (sk ...) fk (i ... id ...))))
                ((pair? ls)
                 (let ((w (car ls)))
                   (match-one w p ((car ls) (set-car! ls))
                              (match-drop-ids
                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
                              fk
-                             i)))
+                             (i ...))))
                (else
                 fk)))))))))
 
@@ -630,7 +667,7 @@
 
 (define-syntax match-gen-ellipsis/range
   (syntax-rules ()
-    ((_ %lo %hi v p r g+s (sk ...) fk i ((id id-ls) ...))
+    ((_ %lo %hi v p r g+s (sk ...) fk (i ...) ((id id-ls) ...))
      ;; general case, trailing patterns to match, keep track of the
      ;; remaining list length so we don't need any backtracking
      (match-verify-no-ellipsis
@@ -645,14 +682,14 @@
               (cond
                 ((= j len)
                  (let ((id (reverse id-ls)) ...)
-                   (match-one ls r (#f #f) (sk ...) fk i)))
+                   (match-one ls r (#f #f) (sk ...) fk (i ... id ...))))
                 ((pair? ls)
                  (let ((w (car ls)))
                    (match-one w p ((car ls) (set-car! ls))
                               (match-drop-ids
                                (loop (cdr ls) (+ j 1) (cons id id-ls) ...))
                               fk
-                              i)))
+                              (i ...))))
                 (else
                  fk)))
             fk))))))
@@ -822,7 +859,7 @@
 ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
 
 (define-syntax match-extract-vars
-  (syntax-rules (_ ___ ..1 ..= ..* *** ? $ struct @ object = quote quasiquote and or not get! set!)
+  (syntax-rules (_ ___ **1 =.. *.. *** ? $ struct @ object = quote quasiquote and or not get! set!)
     ((match-extract-vars (? pred . p) . x)
      (match-extract-vars p . x))
     ((match-extract-vars ($ rec . p) . x)
@@ -859,9 +896,9 @@
     ((match-extract-vars _ (k ...) i v)    (k ... v))
     ((match-extract-vars ___ (k ...) i v)  (k ... v))
     ((match-extract-vars *** (k ...) i v)  (k ... v))
-    ((match-extract-vars ..1 (k ...) i v)  (k ... v))
+    ((match-extract-vars **1 (k ...) i v)  (k ... v))
-    ((match-extract-vars ..= (k ...) i v)  (k ... v))
+    ((match-extract-vars =.. (k ...) i v)  (k ... v))
-    ((match-extract-vars ..* (k ...) i v)  (k ... v))
+    ((match-extract-vars *.. (k ...) i v)  (k ... v))
     ;; This is the main part, the only place where we might add a new
     ;; var if it's an unbound symbol.
     ((match-extract-vars p (k ...) (i ...) v)
@@ -939,34 +976,24 @@
 (define-syntax match-let
   (syntax-rules ()
     ((_ ((var value) ...) . body)
-     (match-let/helper let () () ((var value) ...) . body))
+     (match-let/aux () () ((var value) ...) . body))
     ((_ loop ((var init) ...) . body)
      (match-named-let loop () ((var init) ...) . body))))
 
-;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec}
+(define-syntax match-let/aux
-;;> matches and binds the variables with all match variables in scope.
-
-(define-syntax match-letrec
   (syntax-rules ()
-    ((_ ((var value) ...) . body)
+    ((_ ((var expr) ...) () () . body)
-     (match-let/helper letrec () () ((var value) ...) . body))))
-
-(define-syntax match-let/helper
-  (syntax-rules ()
-    ((_ let ((var expr) ...) () () . body)
      (let ((var expr) ...) . body))
-    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
+    ((_ ((var expr) ...) ((pat tmp) ...) () . body)
      (let ((var expr) ...)
        (match-let* ((pat tmp) ...)
          . body)))
-    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
+    ((_ (v ...) (p ...) (((a . b) expr) . rest) . body)
-     (match-let/helper
+     (match-let/aux (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
-      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
+    ((_ (v ...) (p ...) ((#(a ...) expr) . rest) . body)
-    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
+     (match-let/aux (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
-     (match-let/helper
+    ((_ (v ...) (p ...) ((a expr) . rest) . body)
-      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
+     (match-let/aux (v ... (a expr)) (p ...) rest . body))))
-    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
-     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
 
 (define-syntax match-named-let
   (syntax-rules ()
@@ -990,6 +1017,87 @@
     ((_ ((pat expr) . rest) . body)
      (match expr (pat (match-let* rest . body))))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Challenge stage - unhygienic insertion.
+;;
+;; It's possible to implement match-letrec without unhygienic
+;; insertion by building the let+set! logic directly into the match
+;; code above (passing a parameter to distinguish let vs letrec).
+;; However, it makes the code much more complicated, so we religate
+;; the complexity here.
+
+;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec}
+;;> matches and binds the variables with all match variables in scope.
+
+(define-syntax match-letrec
+  (syntax-rules ()
+    ((_ ((pat val) ...) . body)
+     (match-letrec-one (pat ...) (((pat val) ...) . body) ()))))
+
+;; 1: extract all ids in all patterns
+(define-syntax match-letrec-one
+  (syntax-rules ()
+    ((_ (pat . rest) expr ((id tmp) ...))
+     (match-extract-vars
+      pat (match-letrec-one rest expr) (id ...) ((id tmp) ...)))
+    ((_ () expr ((id tmp) ...))
+     (match-letrec-two expr () ((id tmp) ...)))))
+
+;; 2: rewrite ids
+(define-syntax match-letrec-two
+  (syntax-rules ()
+    ((_ (() . body) ((var2 val2) ...) ((id tmp) ...))
+     ;; We know the ids, their tmp names, and the renamed patterns
+     ;; with the tmp names - expand to the classic letrec pattern of
+     ;; let+set!.  That is, we bind the original identifiers written
+     ;; in the source with let, run match on their renamed versions,
+     ;; then set! the originals to the matched values.
+     (let ((id (if #f #f)) ...)
+       (match-let ((var2 val2) ...)
+          (set! id tmp) ...
+          . body)))
+    ((_ (((var val) . rest) . body) ((var2 val2) ...) ids)
+     (match-rewrite
+      var
+      ids
+      (match-letrec-two-step (rest . body) ((var2 val2) ...) ids val)))))
+
+(define-syntax match-letrec-two-step
+  (syntax-rules ()
+    ((_ next (rewrites ...) ids val var)
+     (match-letrec-two next (rewrites ... (var val)) ids))))
+
+;; This is where the work is done.  To rewrite all occurrences of any
+;; id with its tmp, we need to walk the expression, using CPS to
+;; restore the original structure.  We also need to be careful to pass
+;; the tmp directly to the macro doing the insertion so that it
+;; doesn't get renamed.  This trick was originally found by Al*
+;; Petrofsky in a message titled "How to write seemingly unhygienic
+;; macros using syntax-rules" sent to comp.lang.scheme in Nov 2001.
+
+(define-syntax match-rewrite
+  (syntax-rules (quote)
+    ((match-rewrite (quote x) ids (k ...))
+     (k ... (quote x)))
+    ((match-rewrite (p . q) ids k)
+     (match-rewrite p ids (match-rewrite2 q ids (match-cons k))))
+    ((match-rewrite () ids (k ...))
+     (k ... ()))
+    ((match-rewrite p () (k ...))
+     (k ... p))
+    ((match-rewrite p ((id tmp) . rest) (k ...))
+     (match-bound-identifier=? p id (k ... tmp) (match-rewrite p rest (k ...))))
+    ))
+
+(define-syntax match-rewrite2
+  (syntax-rules ()
+    ((match-rewrite2 q ids (k ...) p)
+     (match-rewrite q ids (k ... p)))))
+
+(define-syntax match-cons
+  (syntax-rules ()
+    ((match-cons (k ...) p q)
+     (k ... (p . q)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Otherwise COND-EXPANDed bits.
@@ -1007,7 +1115,19 @@
      (lambda (expr rename compare)
        (if (identifier? (cadr expr))
            (car (cddr expr))
-           (cadr (cddr expr)))))))
+           (cadr (cddr expr))))))
+  (define-syntax match-bound-identifier=?
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (if (eq? (cadr expr) (car (cddr expr)))
+           (cadr (cddr expr))
+           (car (cddr (cddr expr)))))))
+  (define-syntax match-bound-identifier-memv
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (if (memv (cadr expr) (car (cddr expr)))
+           (cadr (cddr expr))
+           (car (cddr (cddr expr))))))))
 
  (chicken
   (define-syntax match-check-ellipsis
@@ -1021,7 +1141,19 @@
      (lambda (expr rename compare)
        (if (and (symbol? (cadr expr)) (not (keyword? (cadr expr))))
            (car (cddr expr))
-           (cadr (cddr expr)))))))
+           (cadr (cddr expr))))))
+  (define-syntax match-bound-identifier=?
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (if (eq? (cadr expr) (car (cddr expr)))
+           (cadr (cddr expr))
+           (car (cddr (cddr expr)))))))
+  (define-syntax match-bound-identifier-memv
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (if (memv (cadr expr) (car (cddr expr)))
+           (cadr (cddr expr))
+           (car (cddr (cddr expr))))))))
 
  (else
   ;; Portable versions
@@ -1070,4 +1202,30 @@
                ((sym? x sk fk) sk)
                ;; otherwise x is a non-symbol datum
                ((sym? y sk fk) fk))))
-         (sym? abracadabra success-k failure-k)))))))
+         (sym? abracadabra success-k failure-k)))))
+
+  ;; This check is inlined in some cases above, but included here for
+  ;; the convenience of match-rewrite.
+  (define-syntax match-bound-identifier=?
+    (syntax-rules ()
+      ((match-bound-identifier=? a b sk fk)
+       (let-syntax ((b (syntax-rules ())))
+         (let-syntax ((eq (syntax-rules (b)
+                            ((eq b) sk)
+                            ((eq _) fk))))
+           (eq a))))))
+
+  ;; Variant of above for a list of ids.
+  (define-syntax match-bound-identifier-memv
+    (syntax-rules ()
+      ((match-bound-identifier-memv a (id ...) sk fk)
+       (match-check-identifier
+        a
+        (let-syntax
+            ((memv?
+              (syntax-rules (id ...)
+                ((memv? a sk2 fk2) fk2)
+                ((memv? anything-else sk2 fk2) sk2))))
+          (memv? random-sym-to-match sk fk))
+        fk))))
+  ))

lib/chibi/math/prime-test.sld

@@ -32,9 +32,22 @@
       (test 1009 (nth-prime 168))
       (test 1013 (nth-prime 169))
 
+      (test 2 (prime-above 1))
+      (test 3 (prime-above 2))
+      (test 5 (prime-above 3))
+      (test 5 (prime-above 4))
+      (test 7 (prime-above 5))
       (test 907 (prime-above 888))
+      (test 911 (prime-above 907))
+      (test-not (prime-below 2))
+      (test 2 (prime-below 3))
+      (test 3 (prime-below 4))
+      (test 3 (prime-below 5))
+      (test 5 (prime-below 6))
+      (test 5 (prime-below 7))
       (test 797 (prime-below 808))
 
+      (test 1 (totient 1))
       (test 1 (totient 2))
       (test 2 (totient 3))
       (test 2 (totient 4))
@@ -44,6 +57,7 @@
       (test 4 (totient 8))
       (test 6 (totient 9))
       (test 4 (totient 10))
+      (test-error (totient 0))
 
       (test #f (perfect? 1))
       (test #f (perfect? 2))
@@ -59,7 +73,7 @@
       (test #t (perfect? 496))
       (test #t (perfect? 8128))
 
-      (test '(1) (factor 1))
+      (test '() (factor 1))
       (test '(2) (factor 2))
       (test '(3) (factor 3))
       (test '(2 2) (factor 4))
@@ -74,8 +88,16 @@
       (test '(2 3 3) (factor 18))
       (test '(2 2 2 3 3) (factor 72))
       (test '(3 3 3 5 7) (factor 945))
+      (test-error (factor 0))
 
+      (test '() (factor-alist 1))
+      (test '((2 . 3) (3 . 2)) (factor-alist 72))
+      (test '((3 . 3) (5 . 1) (7 . 1)) (factor-alist 945))
+      (test-error (factor-alist 0))
+
+      (test 0 (aliquot 1))
       (test 975 (aliquot 945))
+      (test-error (aliquot 0))
 
       (do ((i 3 (+ i 2)))
           ((>= i 101))
@@ -95,4 +117,7 @@
                         5772301760555853353
                         (* 2936546443 3213384203)))
 
+      (test "Miller-Rabin vs. Carmichael prime"
+            #t (miller-rabin-composite? 118901521))
+
       (test-end))))

lib/chibi/math/prime.scm

@@ -4,12 +4,13 @@
 
 ;;> Prime and number theoretic utilities.
 
-;;> Returns a pair whose car is the power of 2 in the factorization of
+;; Given \var{n} and a continuation \var{return},
-;;> n, and whose cdr is the product of all remaining primes.
+;; returns (\var{return} \var{k2} \var{n2}) where
-(define (factor-twos n)
+;; \var{k2} is the power of 2 in the factorization of \var{n}, and
-  (do ((p 0 (+ p 1))
+;; \var{n2} is product of all other prime powers dividing \var{n}
-       (r n (arithmetic-shift r -1)))
+(define (factor-twos n return)
-      ((odd? r) (cons p r))))
+  (let ((b (first-set-bit n)))
+    (return b (arithmetic-shift n (- b)))))
 
 ;;> Returns the multiplicative inverse of \var{a} modulo \var{b}.
 (define (modular-inverse a b)
@@ -73,22 +74,36 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Probable primes.
 
-(define (modular-root-of-one? twos odd a n neg1)
+;; Given \var{n}, return a predicate that tests whether
-  ;; Returns true iff any (modular-expt a odd*2^i n) for i=0..twos-1
+;; its argument \var{a} is a witness for \var{n} not being prime,
-  ;; returns 1 modulo n.
+;; either (1) because \var{a}^(\var{n}-1)≠1 mod \var{n}
+;; \em{or} (2) because \var{a}'s powers include
+;; a third square root of 1 beyond {1, -1}
+(define (miller-rabin-witnesser n)
+  (let ((neg1 (- n 1)))
+    (factor-twos neg1
+     (lambda (twos odd)
+       (lambda (a)
          (let ((b (modular-expt a odd n)))
            (let lp ((i 0) (b b))
-      (cond ((or (= b 1) (= b neg1)))  ; in (= b 1) case we could factor
+             (cond ((= b neg1)
-            ((>= i twos) #f)
+                    ;; found -1 (expected sqrt(1))
-            (else (lp (+ i 1) (remainder (* b b) n)))))))
+                    #f)
+                   ((= b 1)
+                    ;; !! (previous b)^2=1 and was not 1 or -1
+                    (not (zero? i)))
+                   ((>= i twos)
+                    ;; !! a^(n-1)!=1 mod n
+                    )
+                   (else
+                    (lp (+ i 1) (remainder (* b b) n)))))))))))
 
-;;> Returns true if we can show \var{n} to be composite by finding an
+;;> Returns true if we can show \var{n} to be composite
-;;> exception to the Miller Rabin lemma.
+;;> using the Miller-Rabin test (i.e., finding a witness \var{a}
+;;> where \var{a}^(\var{n}-1)≠1 mod \var{n} or \var{a} reveals
+;;> the existence of a 3rd square root of 1 in \b{Z}/(n))
 (define (miller-rabin-composite? n)
-  (let* ((neg1 (- n 1))
+  (let* ((witness? (miller-rabin-witnesser n))
-         (factors (factor-twos neg1))
-         (twos (car factors))
-         (odd (cdr factors))
          ;; Each iteration of Miller Rabin reduces the odds by 1/4, so
          ;; this is a 1 in 2^40 probability of false positive,
          ;; assuming good randomness from SRFI 27 and no bugs, further
@@ -97,11 +112,10 @@
          (rand-limit (if (< n 341550071728321) fixed-limit 20)))
     (let try ((i 0))
       (and (< i rand-limit)
-           (let ((a (if (< i fixed-limit)
+           (or (witness? (if (< i fixed-limit)
                              (vector-ref prime-table i)
-                        (+ (random-integer (- n 3)) 2))))
+                             (+ (random-integer (- n 3)) 2)))
-             (or (not (modular-root-of-one? twos odd a n neg1))
+               (try (+ i 1)))))))
-                 (try (+ i 1))))))))
 
 ;;> Returns true if \var{n} has a very high probability (enough that
 ;;> you can assume a false positive will never occur in your lifetime)
@@ -146,72 +160,113 @@
 ;;> Returns the first prime less than or equal to \var{n}, or #f if
 ;;> there are no such primes.
 (define (prime-below n)
-  (and (>= n 3)
+  (cond
-       (let lp ((n (if (even? n) (- n 1) n)))
+   ((> n 3)
-         (if (prime? n) n (lp (- n 2))))))
+    (let lp ((n (if (even? n) (- n 1) (- n 2))))
+      (if (prime? n) n (lp (- n 2)))))
+   ((= n 3)
+    2)
+   (else
+    #f)))
 
 ;;> Returns the first prime greater than or equal to \var{n}.  If the
 ;;> optional \var{limit} is given and not false, returns \scheme{#f}
 ;;> if no such primes exist below \var{limit}.
 (define (prime-above n . o)
   (let ((limit (and (pair? o) (car o))))
-    (let lp ((n (if (even? n) (+ n 1) n)))
     (cond
-       ((and limit (>= n limit)) #f)
+     ((< n 2)
+      2)
+     (limit
+      (let lp ((n (if (even? n) (+ n 1) (+ n 2))))
+        (cond
+         ((>= n limit) #f)
          ((prime? n) n)
-       (else (lp (+ n 2)))))))
+         (else (lp (+ n 2))))))
+     (else
+      (let lp ((n (if (even? n) (+ n 1) (+ n 2))))
+        (cond
+         ((prime? n) n)
+         (else (lp (+ n 2)))))))))
+
+;; Given an initial value \var{r1} representing the (empty)
+;; factorization of 1 and a procedure \var{put}
+;; (called as \scheme{(\var{put} \var{r} \var{p} \var{k})})
+;; that, given prior representation \var{r},
+;; adds a prime factor \var{p} of multiplicity \var{k},
+;; returns a factorization function which returns the factorization
+;; of its non-zero integer argument \var{n} in this representation.
+;; The optional 3rd and 4th arguments, if provided, specialize \var{put}
+;; for particular primes:
+;; \var{put2}  for \var{p}=2,  called as \scheme{(\var{put2} \var{r} \var{k})})
+;; \var{put-1} for \var{p}=-1, called as \scheme{(\var{put-1} \var{r})}).
+(define (make-factorizer r1 put . o)
+  (let-optionals o ((put2  (lambda (r k) (put r  2 k)))
+                    (put-1 (lambda (r)   (put r -1 1))))
+    (lambda (n)
+      (when (zero? n)
+        (error "cannot factor 0"))
+      (factor-twos
+       n
+       (lambda (k2 n)
+         (let lp ((i 3) (ii 9)
+                  (n (abs n))
+                  (res (let ((res (if (negative? n) (put-1 r1) r1)))
+                         (if (zero? k2) res (put2 res k2)))))
+           (let next-i ((i i) (ii ii))
+             (cond ((> ii n)
+                    (if (= n 1) res (put res n 1)))
+                   ((not (zero? (remainder n i)))
+                    (next-i (+ i 2) (+ ii (* (+ i 1) 4))))
+                   (else
+                    (let rest ((n (quotient n i))
+                               (k 1))
+                      (if (zero? (remainder n i))
+                          (rest (quotient n i) (+ k 1))
+                          (lp (+ i 2) (+ ii (* (+ i 1) 4))
+                              n (put res i k)))))))))))))
+
+;;> Returns the factorization of \var{n} as a list of
+;;> elements of the form \scheme{(\var{p} . \var{k})},
+;;> where \var{p} is a prime factor
+;;> and \var{k} is its multiplicity.
+(define factor-alist
+  (let ((rfactor (make-factorizer '()
+                  (lambda (l p k) (cons (cons p k) l)))))
+    (lambda (n) (reverse (rfactor n)))))
 
 ;;> Returns the factorization of \var{n} as a monotonically
 ;;> increasing list of primes.
-(define (factor n)
+(define factor
-  (cond
+  (let ((rfactor (make-factorizer '()
-   ((negative? n)
+                  (lambda (l p k) (cons (make-list k p) l)))))
-    (cons -1 (factor (- n))))
+    (lambda (n) (concatenate! (reverse (rfactor n))))))
-   ((<= n 2)
-    (list n))
-   (else
-    (let lp ((n n)
-             (res (list)))
-      (cond
-       ((even? n)
-        (lp (quotient n 2) (cons 2 res)))
-       ((= n 1)
-        (reverse res))
-       (else
-        (let lp ((i 3) (n n) (limit (exact (ceiling (sqrt n)))) (res res))
-          (cond
-           ((= n 1)
-            (reverse res))
-           ((> i limit)
-            (reverse (cons n res)))
-           ((zero? (remainder n i))
-            (lp i (quotient n i) limit (cons i res)))
-           (else
-            (lp (+ i 2) n limit res))))))))))
 
-;;> Returns the Euler totient function, the number of positive
+;;> The Euler totient φ(\var{n}) is the number of positive
-;;> integers less than \var{n} that are relatively prime to \var{n}.
+;;> integers less than or equal to \var{n} that are
-(define (totient n)
+;;> relatively prime to \var{n}.
-  (let ((limit (exact (ceiling (sqrt n)))))
+(define totient
-    (let lp ((i 2) (count 1))
+  (make-factorizer 1
-      (cond ((> i limit)
+   (lambda (tot p k)
-             (if (= count (- i 1))
+     (* tot (- p 1) (expt p (- k 1))))
-                 (- n 1)                ; shortcut for prime
+   (lambda (tot k)
-                 (let lp ((i i) (count count))
+     (arithmetic-shift tot (- k 1)))
-                   (cond ((>= i n) count)
+   (lambda (_)
-                         ((= 1 (gcd n i)) (lp (+ i 1) (+ count 1)))
+     (error "totient of negative number?"))))
-                         (else (lp (+ i 1) count))))))
+
-            ((= 1 (gcd n i)) (lp (+ i 1) (+ count 1)))
+;;> The aliquot sum s(\var{n}) is
-            (else (lp (+ i 1) count))))))
+;;> the sum of proper divisors of a positive integer \var{n}.
+(define aliquot
+  (let ((aliquot+n
+         (make-factorizer 1
+          (lambda (aliq p k)
+            (* aliq (quotient (- (expt p (+ k 1)) 1) (- p 1))))
+          (lambda (aliq k)
+            (- (arithmetic-shift aliq (+ k 1)) aliq))
+          (lambda (_)
+            (error "aliquot of negative number?")))))
+    (lambda (n) (- (aliquot+n n) n))))
 
-;;> The aliquot sum s(n), equal to the sum of proper divisors of an
-;;> integer n.
-(define (aliquot n)
-  (let ((limit (+ 1 (quotient n 2))))
-    (let lp ((i 2) (sum 1))
-      (cond ((> i limit) sum)
-            ((zero? (remainder n i)) (lp (+ i 1) (+ sum i)))
-            (else (lp (+ i 1) sum))))))
 
 ;;> Returns true iff \var{n} is a perfect number, i.e. the sum of its
 ;;> divisors other than itself equals itself.

lib/chibi/math/prime.sld

@@ -1,11 +1,12 @@
 
 (define-library (chibi math prime)
-  (import (scheme base) (scheme inexact) (srfi 27))
+  (import (scheme base) (scheme inexact) (chibi optional) (srfi 1) (srfi 27))
   (cond-expand
    ((library (srfi 151)) (import (srfi 151)))
    ((library (srfi 33)) (import (srfi 33)))
    (else (import (srfi 60))))
-  (export prime? nth-prime prime-above prime-below factor perfect?
+  (export prime? nth-prime prime-above prime-below
+          factor factor-alist perfect?
           totient aliquot
           provable-prime? probable-prime?
           random-prime random-prime-distinct-from

lib/chibi/memoize-test.sld

@@ -1,6 +1,13 @@
 (define-library (chibi memoize-test)
   (export run-tests)
-  (import (scheme base) (scheme file) (chibi memoize) (chibi test))
+  (import (scheme base)
+          (scheme file)
+          (chibi filesystem)
+          (chibi memoize)
+          (chibi pathname)
+          (chibi process)
+          (chibi temp-file)
+          (chibi test))
   (begin
     (define (run-tests)
       (test-begin "memoize")
@@ -39,13 +46,44 @@
           (test 9 (f 3))
           (test 1 n)))
 
+      (let ((calls 0))
         (letrec ((fib (lambda (n)
+                        (set! calls (+ calls 1))
                         (if (<= n 1)
                             1
                             (+ (fib (- n 1)) (fib (- n 2)))))))
-        (let ((f (memoize-to-file fib 'memo-dir: "/tmp/memo.d/")))
+         (call-with-temp-dir
+          "memo.d"
+          (lambda (dir preserve)
+            (let ((f (memoize-to-file fib 'memo-dir: dir)))
               (test 89 (f 10))
-          (test-assert (file-exists? "/tmp/memo.d/10.memo"))
+              (test 177 calls)
-          (test 89 (f 10))))
+              ;; (test-assert (file-exists? (make-path dir "%2810%29.memo")))
+              (test 89 (f 10))
+              (test 177 calls))))))
+
+      (call-with-temp-file
+       "tmp-file"
+       (lambda (tmp-file out preserve)
+         (write-string "123" out)
+         (close-output-port out)
+         (let ((calls 0))
+           (let ((fast-file-size
+                 (memoize-file-loader
+                  (lambda (file)
+                    (set! calls (+ calls 1))
+                    (file-size file)))))
+             (test 3 (fast-file-size tmp-file))
+             (test 1 calls)
+             (test 3 (fast-file-size tmp-file))
+             (test 1 calls)
+             (sleep 1)
+             (call-with-output-file tmp-file
+               (lambda (out) (write-string "1234" out)))
+             (test 4 (fast-file-size tmp-file))
+             (test 2 calls)
+             (test 4 (fast-file-size tmp-file))
+             (test 2 calls)
+             ))))
 
       (test-end))))

lib/chibi/mime.scm

@@ -24,15 +24,25 @@
 ;; most of these are plain text for easier viewing in the browser
 (define (mime-type-from-extension ext)
   (assq-ref
-   '((htm . "text/html; charset=utf-8")
+   '((c . "text/plain; charset=utf-8")
+     (css . "text/css; charset=utf-8")
+     (gif . "image/gif")
+     (h . "text/plain; charset=utf-8")
+     (htm . "text/html; charset=utf-8")
      (html . "text/html; charset=utf-8")
+     (jpeg . "image/jpeg")
+     (jpg . "image/jpeg")
+     (js . "application/javascript; charset=utf-8")
+     (json . "application/json; charset=utf-8")
+     (md . "text/plain; charset=utf-8")
+     (mp3 . "audio/mpeg")
+     (org . "text/plain; charset=utf-8")
+     (pdf . "application/pdf")
+     (png . "image/png")
      (scm . "text/plain; charset=utf-8")
      (sld . "text/plain; charset=utf-8")
-     (c . "text/plain; charset=utf-8")
+     (svg . "image/svg+xml")
-     (h . "text/plain; charset=utf-8")
+     (txt . "text/plain; charset=utf-8"))
-     (txt . "text/plain; charset=utf-8")
-     (org . "text/plain; charset=utf-8")
-     (md . "text/plain; charset=utf-8"))
    (and (string? ext) (string->symbol ext))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

lib/chibi/modules.scm

@@ -117,6 +117,12 @@
            (lp (append (map include-source (cdar ls)) (cdr ls)) res))
           ((include-library-declarations)
            (lp (append (append-map file->sexp-list (map resolve-file (cdar ls))) (cdr ls)) res))
+          ((include-shared include-shared-optionally)
+           (for-each
+            (lambda (file)
+              (let ((f (string-append file *shared-object-extension*)))
+                (cond ((find-module-file f) => (lambda (path) (load path env))))))
+            (cdar ls)))
           ((begin body)
            (let lp2 ((ls2 (cdar ls)) (res res))
              (cond

lib/chibi/net/http-server.scm

@@ -33,6 +33,7 @@
 
 (define (run-http-server listener-or-addr servlet . o)
   (let ((cfg (if (pair? o) (car o) (make-conf '() #f #f #f))))
+    (set-signal-action! signal/pipe #f)
     (run-net-server
      listener-or-addr
      (command-handler
@@ -40,18 +41,31 @@
         (cond
          ((= 2 (length ls))
           (let ((request
-                 (make-request command (car ls) (cadr ls) in out sock addr)))
+                 (protect
+                     (exn
+                      (else
+                       ;; error parsing headers, can't use servlet-respond
+                       (log-error "request error: " exn ls
+                                  (sockaddr-name (address-info-address addr)))
+                       (servlet-write-status out 500 "Internal server error")
+                       (mime-write-headers `((Status . "500")) out)
+                       (display "\r\n" out)
+                       #f))
+                   (make-request command (car ls) (cadr ls) in out sock addr))))
+            (cond
+             (request
+              (if (not (conf-get cfg 'quiet?))
                   (log-info `(request: ,command ,(car ls) ,(cadr ls)
-                                 ,(request-headers request)))
+                                       ,(request-headers request))))
               (protect (exn
                         (else
                          (log-error "internal error: " exn)
                          (print-stack-trace exn)
                          (servlet-respond request 500 "Internal server error")))
                 (let restart ((request request))
-                (servlet cfg request servlet-bad-request restart)))))
+                  (servlet cfg request servlet-bad-request restart)))))))
          (else
-          (let ((request (make-request command #f #f in out sock addr)))
+          (let ((request (make-request command "" #f in out sock addr)))
             (servlet-respond request 400 "bad request")))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -133,7 +147,7 @@
            (cond
             ((mime-type-from-extension (path-extension path))
              => (lambda (type) `((Content-Type . ,type))))
-            (else '()))))
+            (else '((Content-Type . "application/octet-stream"))))))
       (servlet-respond request 200 "OK" headers)
       (send-file path (request-out request))))
    (else
@@ -511,7 +525,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Sample main.  In chibi-scheme you can run:
 ;;
-;; chibi-scheme -Rchibi.net.http-config-server -- [<cfg-file-or-directory>]
+;; chibi-scheme -Rchibi.net.http-server -- [<cfg-file-or-directory>]
 ;;
 ;; which defaults to serving the current directory on port 8000.
 
@@ -537,7 +551,8 @@
     (@
      ((port integer)
       (doc-root string)
-      (verbose? boolean (#\v "verbose"))))
+      (verbose? boolean (#\v "verbose"))
+      (quiet? boolean (#\q "quiet"))))
     ,run-app))
 
 (define (main args) (run-application app-spec))

lib/chibi/net/http-server.sld

@@ -8,11 +8,13 @@
    http-file-servlet http-procedure-servlet http-ext-servlet
    http-regexp-servlet http-path-regexp-servlet http-uri-regexp-servlet
    http-host-regexp-servlet http-redirect-servlet http-rewrite-servlet
-   http-cgi-bin-dir-servlet http-scheme-script-dir-servlet)
+   http-cgi-bin-dir-servlet http-scheme-script-dir-servlet
-  (import (scheme time) (srfi 39) (srfi 95)
+   http-send-file)
+  (import
+   (scheme time) (srfi 39) (srfi 95)
    (chibi) (chibi mime) (chibi regexp) (chibi pathname) (chibi uri)
    (chibi filesystem) (chibi io) (chibi string) (chibi process)
-          (chibi net server) (chibi net server-util) (chibi net servlet)
+   (chibi net) (chibi net server) (chibi net server-util) (chibi net servlet)
    (chibi app) (chibi ast) (chibi config) (chibi log) (chibi memoize)
    (chibi temp-file))
   (include "http-server.scm"))

lib/chibi/net/servlet.scm

@@ -158,6 +158,10 @@
     (request-status-set! request status)
     (let* ((out (request-out request))
            (headers (if (pair? o) (car o) '()))
+           (headers (if (assq 'Content-Type headers)
+                        headers
+                        `((Content-Type . "text/html; charset=UTF-8")
+                          ,@headers)))
            (headers
             (cond
              ;; Socket bound, not CGI, send normal status.

lib/chibi/net/servlet.sld

@@ -17,7 +17,7 @@
    request-uri-string request-with-uri request-path
    copy-request make-request make-cgi-request
    ;; servlets
-   servlet-write servlet-respond servlet-parse-body!
+   servlet-write servlet-write-status servlet-respond servlet-parse-body!
    make-status-servlet servlet-handler servlet-run
    servlet-bad-request)
   (import

lib/chibi/numeric-test.sld

@@ -311,6 +311,9 @@
           (- 340282366920938463463374607431768211456
              340282366920938463426481119284349108225))
 
+      (test '(2147483647 4294967294)
+          (call-with-values (lambda () (exact-integer-sqrt (- (expt 2 62) 1)))
+            list))
       (test '(10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 0)
           (call-with-values (lambda () (exact-integer-sqrt (expt 10 308)))
             list))

lib/chibi/optional-test.sld

@@ -1,6 +1,37 @@
 
 (define-library (chibi optional-test)
-  (import (scheme base) (chibi optional) (chibi test))
+  (import (scheme base) (chibi optional))
+  (cond-expand
+   (chibi (import (chibi test)))
+   (else
+    (import (scheme write))
+    ;; inline (chibi test) to avoid circular dependencies in snow
+    ;; installations
+    (begin
+      (define-syntax test
+       (syntax-rules ()
+         ((test expect expr)
+          (test 'expr expect expr))
+         ((test name expect expr)
+          (guard (exn (else (display "!\nERROR: ") (write name) (newline)
+                            (write exn) (newline)))
+            (let* ((res expr)
+                   (pass? (equal? expect expr)))
+              (display (if pass? "." "x"))
+              (cond
+               ((not pass?)
+                (display "\nFAIL: ") (write name) (newline))))))))
+      (define-syntax test-assert
+        (syntax-rules ()
+          ((test-assert expr) (test #t expr))))
+      (define-syntax test-error
+        (syntax-rules ()
+          ((test-error expr)
+           (test-assert (guard (exn (else #t)) expr #f)))))
+      (define (test-begin name)
+        (display name))
+      (define (test-end)
+        (newline)))))
   (export run-tests)
   (begin
     (define (run-tests)
@@ -16,19 +47,67 @@
           ((opt-lambda (a (b 11) (c 12))
              (list a b c))
            0))
+      (test '(0 11 2)
+          (let ((b 1))
+            ((opt-lambda (a (b 11) (c (* b 2)))
+               (list a b c))
+             0)))
+      (test '(0 11 22)
+          (let ((b 1))
+            ((opt-lambda* (a (b 11) (c (* b 2)))
+               (list a b c))
+             0)))
       (test '(0 1 (2 3 4))
           (let-optionals* '(0 1 2 3 4) ((a 10) (b 11) . c)
             (list a b c)))
       (test '(0 1 (2 3 4))
           (let-optionals '(0 1 2 3 4) ((a 10) (b 11) . c)
             (list a b c)))
-      (test-error '(0 11 12)
+      (test '(0 1 (2 3 4))
+          (let-optionals* '(0 1 2 3 4) (a (b 11) . c)
+            (list a b c)))
+      (test '(0 1 (2 3 4))
+          (let-optionals '(0 1 2 3 4) (a (b 11) . c)
+            (list a b c)))
+      (let ((ls '()))
+        (let-optionals* ls ((a (begin (set! ls '(a b)) 'default-a))
+                            (b 'default-b))
+          (test '(default-a default-b) (list a b))))
+      (let ((ls (list 0 1 2)))
+        (let-optionals ls (a . b)
+          (set-car! (cdr ls) 3)
+          (test '(0 3 2) ls)
+          (test '(0 1 2) (cons a b))))
+      (test 5 (keyword-ref '(a: b: b: 5) 'b: #f))
+      (test 5 (keyword-ref* '(a: b: b: 5) 'b: #f))
+      (test '(1 2 0 (other: 9))
+          (let-keywords '(b: 2 a: 1 other: 9)
+              ((a 0) (b 0) (c 0) rest)
+            (list a b c rest)))
+      ;; a: is not in a keyword position, and the 3 is dropped
+      (test '(1 (2 a:))
+          (let-keywords '(2 a: 3) ((a a: 1) rest) (list a rest)))
+      ;; a: is in a keyword position, and the 3 is dropped
+      (test '(2 ())
+          (let-keywords '(a: 2 3) ((a a: 1) rest) (list a rest)))
+      ;; a: is in a keyword position, 3->5 is a kv, 4 is dropped
+      (test '(2 (3 5))
+          (let-keywords '(3 5 a: 2 4) ((a a: 1) rest) (list a rest)))
+      ;; a: is in a keyword position, 3->5 and 4->6 are kvs
+      (test '(2 (3 5 4 6))
+          (let-keywords '(3 5 a: 2 4 6) ((a a: 1) rest) (list a rest)))
+      (cond-expand
+       (gauche)     ; gauche detects this at compile-time, can't catch
+       (else (test-error '(0 11 12)
                          ((opt-lambda (a (b 11) (c 12))
-             (list a b c))))
+                            (list a b c))))))
       (let ()
         (define-opt (f a (b 11) (c 12))
           (list a b c))
-        (test-error (f))
+        (cond-expand
+         (gauche)
+         (else
+          (test-error (f))))
         (test '(0 11 12) (f 0))
         (test '(0 1 12) (f 0 1))
         (test '(0 1 2) (f 0 1 2))

lib/chibi/optional.scm

@@ -9,9 +9,11 @@
 (define-syntax let*-to-let
   (syntax-rules ()
     ((let*-to-let letstar ls (vars ...) ((v . d) . rest) . body)
-     (let*-to-let letstar ls (vars ... (v tmp . d)) rest . body))
+     (let*-to-let letstar ls (vars ... (v tmp (tmp . d))) rest . body))
-    ((let*-to-let letstar ls ((var tmp . d) ...) rest . body)
+    ((let*-to-let letstar ls (vars ...) (v . rest) . body)
-     (letstar ls ((tmp . d) ... . rest)
+     (let*-to-let letstar ls (vars ... (v tmp tmp)) rest . body))
+    ((let*-to-let letstar ls ((var tmp bind) ...) rest . body)
+     (letstar ls (bind ... . rest)
        (let ((var tmp) ...) . body)))))
 
 ;;> \macro{(let-optionals ls ((var default) ... [rest]) body ...)}
@@ -28,6 +30,9 @@
 ;;> elements of \var{ls} beyond the length of \var{ls}, otherwise any
 ;;> extra values are unused.
 ;;>
+;;> \var{ls} is evaluated only once.  It is an error if any
+;;> \var{default} mutates \var{ls}.
+;;>
 ;;> Typically used on the dotted rest list at the start of a lambda,
 ;;> \scheme{let-optionals} is more concise and more efficient than
 ;;> \scheme{case-lambda} for simple optional argument uses.
@@ -51,8 +56,8 @@
 
 (define-syntax let-optionals
   (syntax-rules ()
-    ((let-optionals ls ((var default) ... . rest) body ...)
+    ((let-optionals ls (var&default ... . rest) body ...)
-     (let*-to-let let-optionals* ls () ((var default) ... . rest) body ...))))
+     (let*-to-let let-optionals* ls () (var&default ... . rest) body ...))))
 
 ;;> \macro{(let-optionals* ls ((var default) ... [rest]) body ...)}
 ;;>
@@ -71,18 +76,17 @@
 (define-syntax opt-lambda
   (syntax-rules ()
     ((opt-lambda vars . body)
-     (opt-lambda/aux () vars . body))))
+     (lambda args (let-optionals args vars . body)))))
 
-(define-syntax opt-lambda/aux
+;;> \macro{(opt-lambda* ((var default) ... [rest]) body ...)}
+;;>
+;;> Variant of \scheme{opt-lambda} which binds using
+;;> \scheme{let-optionals*}.
+
+(define-syntax opt-lambda*
   (syntax-rules ()
-    ((opt-lambda/aux (args ...) ((var . default) . vars) . body)
+    ((opt-lambda* vars . body)
-     (lambda (args ... . o)
+     (lambda args (let-optionals* args vars . body)))))
-       (let-optionals o ((var . default) . vars) . body)))
-    ((opt-lambda/aux (args ...) (var . vars) . body)
-     (opt-lambda/aux (args ... var) vars . body))
-    ((opt-lambda/aux (args ...) () . body)
-     (lambda (args ... . o)
-       . body))))
 
 ;;> \macro{(define-opt (name (var default) ... [rest]) body ...)}
 ;;>
@@ -95,6 +99,24 @@
     ((define-opt (name . vars) . body)
      (define name (opt-lambda vars . body)))))
 
+;;> \macro{(define-opt* (name (var default) ... [rest]) body ...)}
+;;>
+;;> Shorthand for
+;;> \schemeblock{
+;;> (define name (opt-lambda* (var default) ... [rest]) body ...)}
+
+(define-syntax define-opt*
+  (syntax-rules ()
+    ((define-opt* (name . vars) . body)
+     (define name (opt-lambda* vars . body)))))
+
+(define (mem-key key ls)
+  (and (pair? ls)
+       (pair? (cdr ls))
+       (if (eq? key (car ls))
+           ls
+           (mem-key key (cddr ls)))))
+
 ;;> \procedure{(keyword-ref ls key [default])}
 ;;>
 ;;> Search for the identifier \var{key} in the list \var{ls}, treating
@@ -103,12 +125,8 @@
 ;;> \var{default}, or \scheme{#f}.
 
 (define (keyword-ref ls key . o)
-  (let lp ((ls ls))
+  (cond ((mem-key key ls) => (lambda (cell) (cadr cell)))
-    (if (and (pair? ls) (pair? (cdr ls)))
+        (else (and (pair? o) (car o)))))
-        (if (eq? key (car ls))
-            (cadr ls)
-            (lp (cddr ls)))
-        (and (pair? o) (car o)))))
 
 ;;> \macro{(keyword-ref* ls key default)}
 ;;>
@@ -118,7 +136,7 @@
 (define-syntax keyword-ref*
   (syntax-rules ()
     ((keyword-ref* ls key default)
-     (cond ((memq key ls) => cadr) (else default)))))
+     (cond ((mem-key key ls) => cadr) (else default)))))
 
 (define (symbol->keyword sym)
   (string->symbol (string-append (symbol->string sym) ":")))
@@ -144,13 +162,21 @@
 ;;> is not found, \var{var} is bound to \var{default}, even if unused
 ;;> names remain in \var{ls}.
 ;;>
+;;> Keyword arguments have precedence in CommonLisp, DSSSL, and SRFI
+;;> 89.  However, unlike these systems you cannot mix optional and
+;;> keyword arguments.
+;;>
 ;;> If an optional trailing identifier \var{rest} is provided, it is
 ;;> bound to the list of unused arguments not bound to any \var{var}.
+;;> This is useful for chaining together keyword argument procedures -
+;;> you can extract just the arguments you need and pass on the rest
+;;> to another procedure.  The \var{rest} usage is similar to Python's
+;;> \code{**args} (again predated by CommonLisp and DSSSL).
 ;;>
 ;;> Note R7RS does not have a disjoint keyword type or auto-quoting
-;;> syntax for keywords - they are simply identifiers.  Thus when
+;;> syntax for keywords - they are simply identifiers (though no type
-;;> passing keyword arguments they must be quoted (or otherwise
+;;> checking is performed).  Thus when passing keyword arguments they
-;;> dynamically evaluated).
+;;> must be quoted (or otherwise dynamically evaluated).
 ;;>
 ;;> \emph{Example:}
 ;;> \example{
@@ -171,12 +197,27 @@
 ;;>     ((a 0) (b 0) (c 0) rest)
 ;;>   (list a b c rest))
 ;;> }
+;;>
+;;> \emph{Example:}
+;;> \example{
+;;> (define (auth-wrapper proc)
+;;>   (lambda o
+;;>     (let-keywords o ((user #f)
+;;>                      (password #f)
+;;>                      rest)
+;;>       (if (authenticate? user password)
+;;>           (apply proc rest)
+;;>           (error "access denied")))))
+;;>
+;;> ((auth-wrapper make-payment) 'user: "bob" 'password: "5ecret" 'amount: 50)
+;;> }
 
 (define-syntax let-keywords
   (syntax-rules ()
     ((let-keywords ls vars . body)
      (let-key*-to-let ls () vars . body))))
 
+;; Returns the plist ls filtering out key-values found in keywords.
 (define (remove-keywords ls keywords)
   (let lp ((ls ls) (res '()))
     (if (and (pair? ls) (pair? (cdr ls)))
@@ -185,6 +226,8 @@
             (lp (cddr ls) (cons (cadr ls) (cons (car ls) res))))
         (reverse res))))
 
+;; Extracts the known keywords from a let-keyword spec and removes
+;; them from the opt-ls.
 (define-syntax remove-keywords*
   (syntax-rules ()
     ((remove-keywords* opt-ls (keys ...) ((var key default) . rest))
@@ -196,7 +239,7 @@
 
 ;;> \macro{(let-keywords* ls ((var [keyword] default) ... [rest]) body ...)}
 ;;>
-;;> \scheme{let*} equivalent to \scheme{let-keywords*}.  Any required
+;;> \scheme{let*} equivalent to \scheme{let-keywords}.  Any required
 ;;> \var{default} values are evaluated in left-to-right order, with
 ;;> all preceding \var{var}s in scope.
 ;;>

lib/chibi/optional.sld

@@ -1,7 +1,10 @@
 
 (define-library (chibi optional)
-  (export let-optionals let-optionals* opt-lambda define-opt
+  (export let-optionals let-optionals*
-          let-keywords let-keywords* keyword-ref keyword-ref*)
+          opt-lambda opt-lambda*
+          define-opt define-opt*
+          let-keywords let-keywords*
+          keyword-ref keyword-ref*)
   (cond-expand
    (chibi
     (import (chibi))
@@ -29,11 +32,11 @@
            (let ((tmp (op . args)))
              (let-optionals* tmp vars . body)))
           ((let-optionals* tmp ((var default) . rest) . body)
-           (let ((var (if (pair? tmp) (car tmp) default))
+           (let* ((tmp2 (if (pair? tmp) (cdr tmp) '()))
-                 (tmp2 (if (pair? tmp) (cdr tmp) '())))
+                  (var (if (pair? tmp) (car tmp) default)))
              (let-optionals* tmp2 rest . body)))
           ((let-optionals* tmp tail . body)
-           (let ((tail tmp)) . body))))
+           (let ((tail (list-copy tmp))) . body))))
       (define-syntax symbol->keyword*
         (syntax-rules ()
           ((symbol->keyword* sym)

lib/chibi/parse-test.sld

@@ -21,6 +21,7 @@
 
       (test-not (parse parse-nothing ""))
       (test-not (parse parse-nothing "a"))
+      (test-error (parse-fully parse-nothing ""))
 
       (test-not (parse (parse-char #\a) ""))
       (test-assert (parse-fully (parse-char #\a) "a"))
@@ -53,6 +54,15 @@
         (test-assert (parse f "aab"))
         (test-error (parse-fully f "aab")))
 
+      (let ((f (parse-seq (parse-char #\a)
+                          (parse-ignore (parse-char #\b)))))
+        (test '(#\a) (parse f "ab")))
+
+      (let ((f (parse-seq (parse-char #\a)
+                          (parse-ignore (parse-char #\b))
+                          (parse-char #\c))))
+        (test '(#\a #\c) (parse f "abc")))
+
       ;; grammars
 
       (let ()

lib/chibi/parse/parse.scm

@@ -167,8 +167,11 @@
   ;; location
   (if (%parse-stream-tail s)
       (parse-stream-debug-info (%parse-stream-tail s) i)
+      (let ((max-char (parse-stream-max-char s)))
+        (if (< max-char 0)
+            (list 0 0 "")
             (let* ((line-info
-              (parse-stream-count-lines s (parse-stream-max-char s)))
+                    (parse-stream-count-lines s max-char))
                    (line (+ (parse-stream-line s) (car line-info)))
                    (col (if (zero? (car line-info))
                             (+ (parse-stream-column s) (cadr line-info))
@@ -176,7 +179,7 @@
                    (from (car (cddr line-info)))
                    (to (parse-stream-end-of-line s (+ from 1)))
                    (str (parse-stream-substring s from s to)))
-        (list line col str))))
+              (list line col str))))))
 
 (define (parse-stream-next-source source i)
   (if (>= (+ i 1) (vector-length (parse-stream-buffer source)))
@@ -399,7 +402,9 @@
    ((null? (cdr o))
     (let ((f (car o)))
       (lambda (s i sk fk)
-        (f s i (lambda (r s i fk) (sk (list r) s i fk)) fk))))
+        (f s i (lambda (r s i fk)
+                 (sk (if (eq? r ignored-value) '() (list r)) s i fk))
+           fk))))
    (else
     (let* ((f (car o))
            (o (cdr o))
@@ -408,7 +413,10 @@
            (g (if (pair? o)
                   (apply parse-seq g o)
                   (lambda (s i sk fk)
-                    (g s i (lambda (r s i fk) (sk (list r) s i fk)) fk)))))
+                    (g s i (lambda (r s i fk)
+                             (sk (if (eq? r ignored-value) '() (list r))
+                                 s i fk))
+                       fk)))))
       (lambda (source index sk fk)
         (f source
            index
@@ -515,10 +523,15 @@
 
 ;;> Parse with \var{f} once, keep the first result, and commit to the
 ;;> current parse path, discarding any prior backtracking options.
+;;> Since prior backtracking options are discarded, prior failure
+;;> continuations are also not used. By default, \scheme{#f} is
+;;> returned on failure, a custom failure continuation can be passed
+;;> as the second argument.
 
-(define (parse-commit f)
+(define (parse-commit f . o)
+  (let ((commit-fk (if (pair? o) (car o) (lambda (s i r) #f))))
     (lambda (source index sk fk)
-    (f source index (lambda (res s i fk) (sk res s i (lambda (s i r) #f))) fk)))
+      (f source index (lambda (res s i fk) (sk res s i commit-fk)) fk))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -658,7 +671,7 @@
 (define (parse-string str)
   (parse-map (parse-with-failure-reason
               (parse-seq-list (map parse-char (string->list str)))
-              `(expected ,str))
+              (string-append "expected '" str "'"))
              list->string))
 
 ;;> Parse a sequence of characters matching \var{x} as with

lib/chibi/process.scm

@@ -1,20 +1,29 @@
+(define unwind #f)
+
+((call/cc
+    (lambda (k)
+      (set! unwind k)
+      (lambda () #f))))
 
 (cond-expand
  (plan9
-  (define (exit . o)
+  (define (emergency-exit . o)
     (%exit (if (pair? o)
                (if (string? (car o))
                    (car o)
                    (if (eq? #t (car o)) "" "chibi error"))
                ""))))
  (else
-  (define (exit . o)
+  (define (emergency-exit . o)
     (%exit (if (pair? o)
                (if (integer? (car o))
                    (inexact->exact (car o))
                    (if (eq? #t (car o)) 0 1))
                0)))))
 
+(define (exit . o)
+  (unwind (lambda () (apply emergency-exit o))))
+
 (cond-expand
  (bsd
   (define (process-command-line pid)
@@ -123,8 +132,11 @@
 ;;> \var{stdout} and \var{stderr} of the subprocess.  \var{command}
 ;;> should be a list beginning with the program name followed by any
 ;;> args, which may be symbols or numbers for convenience as with
-;;> \scheme{system}, or a string which is split on white-space.
+;;> \scheme{system}, or a string which is split on white-space.  If
-(define (call-with-process-io command proc)
+;;> provided, the optional \var{child-proc} is called in the child
+;;> process, after ports have been duplicated but before the command
+;;> is executed, to allow for actions such as port remapping.
+(define (call-with-process-io command proc . o)
   (define (set-non-blocking! fd)
     (cond-expand
      (threads
@@ -133,7 +145,8 @@
        (bitwise-ior open/non-block (get-file-descriptor-status fd))))
      (else
       #f)))
-  (let ((command-ls (if (string? command) (string-split command) command))
+  (let ((child-proc (and (pair? o) (car o)))
+        (command-ls (if (string? command) (string-split command) command))
         (in-pipe (open-pipe))
         (out-pipe (open-pipe))
         (err-pipe (open-pipe)))
@@ -152,6 +165,7 @@
              (close-file-descriptor (car in-pipe))
              (close-file-descriptor (cadr out-pipe))
              (close-file-descriptor (cadr err-pipe))
+             (if child-proc (child-proc))
              (execute (car command-ls) command-ls)
              (execute-returned command-ls))
             (else         ;; parent
@@ -175,6 +189,8 @@
      (close-output-port in)
      (let ((res (port->bytevector out)))
        (waitpid pid 0)
+       (close-input-port out)
+       (close-input-port err)
        res))))
 
 ;;> Utility to run \var{command} and return the accumulated output as
@@ -186,6 +202,8 @@
      (close-output-port in)
      (let ((res (port->string out)))
        (waitpid pid 0)
+       (close-input-port out)
+       (close-input-port err)
        res))))
 
 ;;> Utility to run \var{command} and return the accumulated output as
@@ -201,10 +219,12 @@
    command
    (lambda (pid in out err)
      (close-output-port in)
-     (let* ((out (port->string out))
+     (let* ((outs (port->string out))
-            (err (port->string err))
+            (errs (port->string err))
             (res (waitpid pid 0)))
-       (list out err (cadr res))))))
+       (close-input-port out)
+       (close-input-port err)
+       (list outs errs (cadr res))))))
 
 ;;> Utility to run \var{command} and return a list of two values:
 ;;> the accumulated output as a string, the error output as a string.
@@ -221,4 +241,6 @@
      (close-output-port in)
      (let ((res (port->string-list out)))
        (waitpid pid 0)
+       (close-input-port out)
+       (close-input-port err)
        res))))

lib/chibi/process.sld

@@ -1,6 +1,7 @@
 
 (define-library (chibi process)
-  (export exit sleep alarm %fork fork kill execute waitpid system system?
+  (export exit emergency-exit sleep alarm
+          %fork fork kill execute waitpid system system?
           process-command-line process-running?
           set-signal-action! make-signal-set
           signal-set? signal-set-contains?
@@ -17,7 +18,7 @@
           call-with-process-io process->bytevector
           process->string process->sexp process->string-list
           process->output+error process->output+error+status)
-  (import (chibi) (chibi io) (chibi string) (chibi filesystem))
+  (import (chibi) (chibi io) (chibi string) (chibi filesystem) (only (scheme base) call/cc))
   (cond-expand (threads (import (srfi 18) (srfi 151))) (else #f))
   (cond-expand ((not windows) (include-shared "process")))
   (include "process.scm"))

lib/chibi/regexp-test.sld

@@ -151,6 +151,9 @@
       (test-re '("abc  " "")
                '(: ($ (*? alpha)) (* any))
                "abc  ")
+      ;; (test-re-search '("a-z")
+      ;;                 '(: "a" (*? any) "z")
+      ;;                 "a-z-z")
       (test-re '("<em>Hello World</em>" "em>Hello World</em")
                '(: "<" ($ (* any)) ">" (* any))
                "<em>Hello World</em>")
@@ -161,6 +164,32 @@
       (test-re-search #f '(: nwb "foo" nwb) " foo ")
       (test-re-search '("foo") '(: nwb "foo" nwb) "xfoox")
 
+      (test-re '("regular expression" "expression")
+               '(: "regular" (look-ahead " expression") (* space ) ($ word))
+               "regular expression")
+      (test-re #f
+               '(: "regular" (look-ahead "expression") (* space ) ($ word))
+               "regular expression")
+      (test-re '("regular expression" "regular")
+               '(: ($ word) (* space ) (look-behind "regular ") "expression")
+               "regular expression")
+      (test-re #f
+               '(: ($ word) (* space ) (look-behind "regular") "expression")
+               "regular expression")
+
+      (test-re #f
+               '(: "regular" (neg-look-ahead " expression") (* space ) ($ word))
+               "regular expression")
+      (test-re '("regular expression" "expression")
+               '(: "regular" (neg-look-ahead "expression") (* space ) ($ word))
+               "regular expression")
+      (test-re #f
+               '(: ($ word) (* space ) (neg-look-behind "regular ") "expression")
+               "regular expression")
+      (test-re '("regular expression" "regular")
+               '(: ($ word) (* space ) (neg-look-behind "regular") "expression")
+               "regular expression")
+
       (test-re '("beef")
                '(* (/"af"))
                "beef")

lib/chibi/regexp.scm

@@ -30,8 +30,9 @@
   (accept? state-accept? state-accept?-set!)
   ;; A char or char-set indicating when we can transition.
   ;; Alternately, #f indicates an epsilon transition, while a
-  ;; procedure of the form (lambda (ch i matches) ...) is a predicate
+  ;; procedure is a guarded epsilon transition which advances
-  ;; which should return #t if the char matches.
+  ;; only if the procedure returns a true value.  The signature
+  ;; is of the form (proc str i ch start end matches).
   (chars state-chars state-chars-set!)
   ;; A single integer indicating the match position to record.
   (match state-match state-match-set!)
@@ -300,11 +301,9 @@
     (if (not (eq? m (searcher-matches sr1)))
         (searcher-matches-set! sr1 (copy-regexp-match m)))))
 
-(define (searcher-max sr1 sr2)
+(define (searcher>=? sr1 sr2)
-  (if (or (not (searcher? sr2))
+  (or (not (searcher? sr2))
-          (regexp-match>=? (searcher-matches sr1) (searcher-matches sr2)))
+      (regexp-match>=? (searcher-matches sr1) (searcher-matches sr2))))
-      sr1
-      sr2))
 
 (define (searcher-start-match sr)
   (regexp-match-ref (searcher-matches sr) 0))
@@ -344,6 +343,26 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Execution
 
+;; The intermediate state of a regexp search. Differs from a match in that a
+;; match has not necessarily occurred, and includes additional information
+;; needed to resume searching.
+
+(define-record-type Regexp-State
+  (%make-regexp-state searchers accept string)
+  regexp-state?
+  (searchers regexp-state-searchers regexp-state-searchers-set!)
+  (accept regexp-state-accept regexp-state-accept-set!)
+  (string regexp-state-string regexp-state-string-set!))
+
+(define (make-regexp-state . o)
+  (let ((searchers (if (pair? o) (car o) (posse)))
+        (accept (and (pair? o) (pair? (cdr o)) (cadr o))))
+    (%make-regexp-state searchers accept #f)))
+
+(define (regexp-state-matches state)
+  (cond ((regexp-state-accept state) => searcher-matches)
+        (else #f)))
+
 ;; A transition which doesn't advance the index.
 
 (define (epsilon-state? st)
@@ -370,7 +389,7 @@
 ;; Advance epsilons together - if the State is newly added to the
 ;; group and is an epsilon state, recursively add the transition.
 
-(define (posse-advance! new seen accept sr str i start end)
+(define (posse-advance! new seen state sr str i start end)
   (let advance! ((sr sr))
     (let ((st (searcher-state sr)))
       ;; Update match data.
@@ -394,7 +413,10 @@
       ;; Follow transitions.
       (cond
        ((state-accept? st)
-        (set-cdr! accept (searcher-max sr (cdr accept))))
+        (cond
+         ((searcher>=? sr (regexp-state-accept state))
+          (regexp-state-accept-set! state sr)
+          (regexp-state-string-set! state str))))
        ((posse-ref seen sr)
         => (lambda (sr-prev) (searcher-merge! sr-prev sr)))
        ((epsilon-state? st)
@@ -406,8 +428,7 @@
             (posse-add! seen sr)
             (let* ((next1 (state-next1 st))
                    (next2 (state-next2 st))
-                   (matches
+                   (matches (and next2 (searcher-matches sr))))
-                    (and next2 (searcher-matches sr))))
               (cond
                (next1
                 (searcher-state-set! sr next1)
@@ -424,27 +445,27 @@
         ;; Add new searcher.
         (posse-add! new sr))))))
 
-;; Run so long as there is more to match.
+;;> Advances the search until an optimal match is found or the end of the string
-
+;;> is reached, and returns the resulting regexp state.
-(define (regexp-run-offsets search? rx str start end)
+(define (regexp-advance! search? init? rx str start end . o)
   (let ((rx (regexp rx))
-        (epsilons (posse))
+        (state (if (pair? o) (car o) (make-regexp-state)))
-        (accept (list #f)))
+        (epsilons (posse)))
     (let lp ((i start)
              (searchers1 (posse))
              (searchers2 (posse)))
       ;; Advance initial epsilons once from the first index, or every
       ;; time when searching.
       (cond
-       ((or search? (string-cursor=? i start))
+       ((or search? (and init? (string-cursor=? i start)))
-        (posse-advance! searchers1 epsilons accept (make-start-searcher rx str)
+        (posse-advance! searchers1 epsilons state (make-start-searcher rx str)
                         str i start end)
         (posse-clear! epsilons)))
       (cond
        ((or (string-cursor>=? i end)
             (and search?
-                 (searcher? (cdr accept))
+                 (searcher? (regexp-state-accept state))
-                 (let ((accept-start (searcher-start-match (cdr accept))))
+                 (let ((accept-start (searcher-start-match (regexp-state-accept state))))
                    (posse-every
                     (lambda (searcher)
                       (string-cursor>? (searcher-start-match searcher)
@@ -452,16 +473,14 @@
                     searchers1)))
             (and (not search?)
                  (posse-empty? searchers1)))
-        ;; Terminate when the string is done or there are no more
+        ;; Terminate when the string is done or there are no more searchers or
-        ;; searchers.  If we terminate prematurely and are not
+        ;; we've found an accept state which started before any pending matches.
-        ;; searching, return false.
+        ;; If we terminate prematurely and are not searching, return false.
-        (and (searcher? (cdr accept))
+        (regexp-state-searchers-set! state searchers1)
-             (let ((matches (searcher-matches (cdr accept))))
+        state)
-               (and (or search? (string-cursor>=? (regexp-match-ref matches 1)
-                                                  end))
-                    (searcher-matches (cdr accept))))))
        (else
-        ;; Otherwise advance normally.
+        ;; Otherwise advance normally from searchers1, storing the new state in
+        ;; searchers2, and recurse swapping the two (to reduce garbage).
         (let ((ch (string-cursor-ref str i))
               (i2 (string-cursor-next str i)))
           (posse-for-each ;; NOTE: non-deterministic from hash order
@@ -471,12 +490,21 @@
                                start end (searcher-matches sr))
                (searcher-state-set! sr (state-next1 (searcher-state sr)))
                ;; Epsilons are considered at the next position.
-               (posse-advance! searchers2 epsilons accept sr str i2 start end)
+               (posse-advance! searchers2 epsilons state sr str i2 start end)
                (posse-clear! epsilons))))
            searchers1)
           (posse-clear! searchers1)
           (lp i2 searchers2 searchers1)))))))
 
+;; Run so long as there is more to match.
+
+(define (regexp-run-offsets search? rx str start end)
+  (let ((state (regexp-advance! search? #t rx str start end)))
+    (and (searcher? (regexp-state-accept state))
+         (let ((matches (searcher-matches (regexp-state-accept state))))
+           (and (or search? (string-cursor>=? (regexp-match-ref matches 1) end))
+                matches)))))
+
 ;; Wrapper to determine start and end offsets.
 
 (define (regexp-run search? rx str . o)
@@ -569,6 +597,28 @@
                   (m (regexp-search re:grapheme str sci sce)))
              (and m (<= (regexp-match-submatch-end m 0) sci))))))
 
+(define (match/look-ahead sres)
+  (let ((rx (regexp `(seq bos ,@sres))))
+    (lambda (str i ch start end matches)
+      (and (regexp-run-offsets #t rx str i end)
+           #t))))
+
+(define (match/look-behind sres)
+  (let ((rx (regexp `(seq ,@sres eos))))
+    (lambda (str i ch start end matches)
+      (and (regexp-run-offsets #t rx str start i)
+           #t))))
+
+(define (match/neg-look-ahead sres)
+  (let ((rx (regexp `(seq bos ,@sres))))
+    (lambda (str i ch start end matches)
+      (not (regexp-run-offsets #t rx str i end)))))
+
+(define (match/neg-look-behind sres)
+  (let ((rx (regexp `(seq ,@sres eos))))
+    (lambda (str i ch start end matches)
+      (not (regexp-run-offsets #t rx str start i)))))
+
 (define (lookup-char-set name flags)
   (cond
    ((flag-set? flags ~ascii?)
@@ -924,6 +974,24 @@
                                (sre->char-set `(or ,@(cdr sre)) flags)))))
                flags
                next))
+        ;; TODO: The look-around assertions are O(n^d) where d is the
+        ;; nesting depth of the assertions, i.e. quadratic for one
+        ;; look-ahead, cubic for a look-behind inside a look-ahead,
+        ;; etc.  We could consider instead advancing the look-aheads
+        ;; together from the current position (and advancing the
+        ;; look-behinds from the beginning) and checking if the
+        ;; corresponding state matches.  The trick is the look-aheads
+        ;; don't necessarily have the same length - we have to keep
+        ;; advancing until they resolve and keep or prune the
+        ;; corresponding non-look-ahead states accordingly.
+        ((look-ahead)
+         (make-char-state (match/look-ahead (cdr sre)) flags next (next-id)))
+        ((look-behind)
+         (make-char-state (match/look-behind (cdr sre)) flags next (next-id)))
+        ((neg-look-ahead)
+         (make-char-state (match/neg-look-ahead (cdr sre)) flags next (next-id)))
+        ((neg-look-behind)
+         (make-char-state (match/neg-look-behind (cdr sre)) flags next (next-id)))
         ((w/case)
          (->rx `(: ,@(cdr sre)) (flag-clear flags ~ci?) next))
         ((w/nocase)

lib/chibi/regexp.sld

@@ -10,7 +10,13 @@
           regexp-match? regexp-match-count
           regexp-match-submatch regexp-match-submatch/list
           regexp-match-submatch-start regexp-match-submatch-end
-          regexp-match->list regexp-match->sexp)
+          regexp-match->list regexp-match->sexp
+          ;; low-level
+          regexp-advance! regexp-state?
+          make-regexp-state regexp-state-accept
+          regexp-state-searchers regexp-state-matches
+          regexp-match-ref
+          )
   (import (srfi 69))
   ;; Chibi's char-set library is more factored than SRFI-14.
   (cond-expand

lib/chibi/repl.scm

@@ -1,5 +1,5 @@
 ;; repl.scm - friendlier repl with line editing and signal handling
-;; Copyright (c) 2012-2013 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2012-2024 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;;> A user-friendly REPL with line editing and signal handling.  The
@@ -296,6 +296,8 @@
          (pair? (exception-irritants exn)))
     (let ((name (car (exception-irritants exn))))
       (cond
+       ((and (identifier? name) (not (env-parent (current-environment))))
+        (display "Did you forget to import a language? e.g. (import (scheme base))\n" out))
        ((identifier? name)
         (display "Searching for modules exporting " out)
         (display name out)
@@ -400,17 +402,26 @@
         ((= (length value) 1) (push-history-value! (car value)))
         (else (push-history-value! value))))
 
+(define-generic repl-print)
+
+(define-method (repl-print obj (out output-port?))
+  (write/ss obj out))
+
+(define-generic repl-print-exception)
+
+(define-method (repl-print-exception obj (out output-port?))
+  (print-exception obj out))
+
 (define (repl/eval rp expr-list)
-  (let ((out (repl-out rp)))
+  (let ((thread (current-thread))
-    (protect (exn (else (print-exception exn out)))
+        (out (repl-out rp)))
-      (let ((thread
+    (with-signal-handler
-             (make-thread
+     signal/interrupt
+     (lambda (n) (thread-interrupt! thread))
      (lambda ()
-                ;; The inner protect in the child thread catches errors
-                ;; from eval.
        (protect (exn
                  (else
-                           (print-exception exn out)
+                  (repl-print-exception exn out)
                   (repl-advise-exception exn (current-error-port))))
          (for-each
           (lambda (expr)
@@ -421,28 +432,19 @@
                           (null? expr))
                       (eval expr (repl-env rp))
                       expr))
-                       (lambda res-list
+              (lambda res-values
                 (cond
-                          ((not (or (null? res-list)
+                 ((not (or (null? res-values)
-                                    (equal? res-list (list (if #f #f)))))
+                           (equal? res-values (list undefined-value))))
-                           (push-history-value-maybe! res-list)
+                  (push-history-value-maybe! res-values)
-                           (write/ss (car res-list) out)
+                  (repl-print (car res-values) out)
                   (for-each
                    (lambda (res)
                      (write-char #\space out)
-                              (write/ss res out))
+                     (repl-print res out))
-                            (cdr res-list))
+                   (cdr res-values))
                   (newline out))))))
           expr-list))))))
-        ;; If an interrupt occurs while the child thread is
-        ;; still running, terminate it, otherwise wait for it
-        ;; to complete.
-        (with-signal-handler
-         signal/interrupt
-         (lambda (n)
-           (display "\nInterrupt\n" out)
-           (thread-terminate! thread))
-         (lambda () (thread-join! (thread-start! thread))))))))
 
 (define (repl/eval-string rp str)
   (repl/eval

lib/chibi/repl.sld

@@ -1,9 +1,15 @@
 
 (define-library (chibi repl)
-  (export repl $0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
+  (export repl repl-print repl-print-exception
+          $0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
   (import (chibi) (only (meta) load-module module-name->file)
-          (chibi ast) (chibi modules) (chibi doc)
+          (chibi ast) (chibi modules) (chibi doc) (chibi generic)
           (chibi string) (chibi io) (chibi optional)
           (chibi process) (chibi term edit-line)
-          (srfi 1) (srfi 9) (srfi 18) (srfi 38) (srfi 95) (srfi 98))
+          (srfi 1)
+          (srfi 9)
+          (only (srfi 18) current-thread)
+          (srfi 38)
+          (srfi 95)
+          (srfi 98))
   (include "repl.scm"))

lib/chibi/scribble-test.sld

@@ -15,6 +15,9 @@
       (test-scribble '((foo "blah \"blah\" (`blah'?)")) "\\foo{blah \"blah\" (`blah'?)}")
       (test-scribble '((foo 1 2 "3 4")) "\\foo[1 2]{3 4}")
       (test-scribble '((foo 1 2 3 4)) "\\foo[1 2 3 4]")
+      (test-scribble '(123.456) "\\123.456")
+      (test-scribble '((123.456)) "\\(123.456)")
+      (test-scribble '((123.456)) "\\(123.456 )")
       (test-scribble '((foo width: 2 "blah blah")) "\\foo[width: 2]{blah blah}")
       (test-scribble '((foo "blah blah" "\n" "     yada yada")) "\\foo{blah blah
      yada yada}")

lib/chibi/scribble.scm

@@ -53,9 +53,11 @@
 
 (define (read-float-tail in acc)
   (let lp ((res acc) (k 0.1))
-    (let ((ch (read-char in)))
+    (let ((ch (peek-char in)))
       (cond ((or (eof-object? ch) (char-delimiter? ch)) res)
-            ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1)))
+            ((char-numeric? ch)
+             (read-char in)
+             (lp (+ res (* k (char-digit ch))) (* k 0.1)))
             (else (error "invalid numeric syntax"))))))
 
 (define (read-number in acc base)
@@ -67,7 +69,7 @@
        ((eqv? #\. ch)
         (read-char in)
         (if (= base 10)
-            (begin (read-char in) (read-float-tail in (inexact acc)))
+            (read-float-tail in (inexact acc))
             (error "non-base-10 floating point")))
        (else (error "invalid numeric syntax"))))))
 

lib/chibi/shell-test.sld

@@ -0,0 +1,47 @@
+
+(define-library (chibi shell-test)
+  (import (scheme base) (chibi shell) (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests)
+      (test-begin "(chibi shell)")
+      (test "hello\n"
+          (shell->string (echo "hello")))
+      (test "world\n"
+          (shell->string (echo "world")))
+      (test "HELLO\n"
+          (shell->string
+           ,(shell-pipe
+             '(echo "hello")
+             '(tr "a-z" "A-Z"))))
+      (test "OLLEH\n"
+          (shell->string
+           ,(shell-pipe
+             '(echo "hello")
+             '(tr "a-z" "A-Z")
+             'rev)))
+      (test "OLLEH\n"
+          (shell->string (echo "hello") (tr "a-z" "A-Z") rev))
+      (test "pass\n"
+          (shell->string ,(shell-if 'true '(echo "pass") '(echo "fail"))))
+      (test "fail\n"
+          (shell->string ,(shell-if 'false '(echo "pass") '(echo "fail"))))
+      (test "hello\nworld\n"
+          (shell->string ,(shell-do '(echo "hello") '(echo "world"))))
+      (test "hello\n"
+          (shell->string
+           ,(shell-and 'true '(echo "hello") 'false '(echo "world"))))
+      (test "hello\n"
+          (shell->string
+           ,(shell-or 'false '(echo "hello") '(echo "world"))))
+      (test "hello\n"
+          (shell->string (or false (echo "hello") (echo "world"))))
+      (test '("hello" "world")
+          (shell->string-list (do (echo "hello") (echo "world"))))
+      (test '(hello world)
+          (shell->sexp-list (do (echo "hello") (echo "world"))))
+      (test "HELLO"
+          (shell->string (cat) (<< hello) (tr "a-z" "A-Z")))
+      (test "HELLO"
+          (shell->string (>< (cat) (tr "a-z" "A-Z")) (<< hello)))
+      (test-end))))

lib/chibi/shell.scm

@@ -0,0 +1,525 @@
+
+;;> \section{Process Combinators}
+;;>
+;;> Running a command in a subprocess basically amounts to fork+exec.
+;;> What becomes interesting is combining together multiple commands,
+;;> conditionally based on exit codes and/or connecting their inputs
+;;> and outputs.  More generally a variety of parameters or resources
+;;> of the subprocess may be configured before the command is executed,
+;;> including:
+;;>
+;;> \itemlist[
+;;> \item{fileno configuration }
+;;> \item{environment variables }
+;;> \item{signal masks }
+;;> \item{running user }
+;;> \item{process groups }
+;;> \item{resource limits (CPU, memory, disk I/O, network) }
+;;> \item{prioritization }
+;;> \item{namespace isolation }
+;;> \item{virtual filesystems }
+;;> ]
+;;>
+;;> Some of these can be specified by posix_spawn(3), but the more
+;;> general features come from cgroups.
+;;>
+;;> We can build process combinators by abstracting this configuration
+;;> from the execution.  The most basic case is a single command:
+;;>
+;;> \scheme{(shell-command (list <command> <args> ...))}
+;;>
+;;> This returns a procedure of two arguments, both thunks to run in
+;;> the child process after the fork but before exec (one for input and
+;;> one for output).  For example,
+;;>
+;;> \scheme{((shell-command '("ls")) (lambda () #t) (lambda () #t))}
+;;>
+;;> would run the ls command in a subprocess with no changes from the
+;;> parent process, i.e. it would write to the parent process' stdout.
+;;>
+;;> Redirecting stdio to or from files is achieved by opening the file
+;;> in the child process and calling dup() to match to the appropriate
+;;> stdio fileno:
+;;>
+;;> \schemeblock{
+;;> ((shell-command '("ls"))
+;;>  (lambda () #t)
+;;>  (lambda ()
+;;>    (duplicate-file-descriptor-to
+;;>     (open "out" (bitwise-ior open/write open/create open/truncate))
+;;>     1)))}
+;;>
+;;> \schemeblock{
+;;> ((shell-command '("grep" "define"))
+;;>  (lambda ()
+;;>    (duplicate-file-descriptor-to
+;;>     (open "shell.scm" open/read)
+;;>     0))
+;;>  (lambda () #t))}
+;;>
+;;> This looks like a common pattern, so let's provide some utilities:
+;;>
+;;> \schemeblock{
+;;> (define (redirect file mode fileno)
+;;>   (duplicate-file-descriptor-to (open file mode) fileno))}
+;;>
+;;> \schemeblock{
+;;> (define (in< file) (redirect file open/read 0))
+;;> (define (out> file)
+;;>   (redirect file (bitwise-ior open/write open/create open/truncate) 1))
+;;> (define (err> file)
+;;>   (redirect file (bitwise-ior open/write open/create open/truncate) 2))}
+;;>
+;;> so we can rewrite the examples as:
+;;>
+;;> \schemeblock{
+;;> ((shell-command '("ls")) (lambda () #t) (lambda () (out> "out")))
+;;> ((shell-command '("grep" "define"))
+;;>  (lambda () (in< "shell.scm")) (lambda () #t))}
+;;>
+;;> We can use these combinators for more than I/O redirection.  For
+;;> example, we can change the current working directory.  The
+;;> semantics of many commands depends on the current working
+;;> directory, so much so that some commands provide options to change
+;;> the directory on startup (e.g. -C for git and make).  For commands
+;;> which don't offer this convenience we can use process combinators
+;;> to change directory only in the child without invoking extra
+;;> processes:
+;;>
+;;> \schemeblock{
+;;> ((shell-command '("cmake"))
+;;>  (lambda () (change-directory project-dir))
+;;>  (lambda () #t))}
+;;>
+;;> Another resource we may want to change is the user, e.g. via
+;;> setuid.  Since we control the order of resource changes we can do
+;;> things like the following example.  Here we run as root, providing
+;;> access to the secret data in /etc/shadow, but extract only the row
+;;> relevant to a specific user and write to a file owned by them:
+;;>
+;;> \schemeblock{
+;;> (let ((user "alice"))
+;;>   ((shell-command (list "grep" (string-append "^" user ":")))
+;;>    (lambda ()
+;;>      (in< "/etc/shadow")   ; read as root
+;;>      (set-current-user-id! (user-id (user-information user))))
+;;>    (lambda ()
+;;>      (out> "my-shadow")))) ; written as user}
+;;>
+;;> This is already something not possible in bash (or posix_spawn)
+;;> without resorting to additional subprocesses.
+;;>
+;;> We can in a similar manner also modify priority with nice, the
+;;> filesystem with chroot, and change the cgroup, which otherwise is
+;;> generally done with a wrapper script.
+;;>
+;;> Things get more interesting when we want to combine multiple
+;;> commands.  We can connect the output of one process as the input
+;;> to another with a pipe.  The following pipes the output of echo to
+;;> tr, outputting "HELLO" to stdout:
+;;>
+;;> \schemeblock{
+;;> ((shell-pipe (shell-command '(echo "hello"))
+;;>              (shell-command '(tr "a-z" "A-Z")))
+;;>  (lambda () #t)
+;;>  (lambda () #t))}
+;;>
+;;> We can continue to build on these combinators, but for practical
+;;> use a concise syntax is handy.  We provide the syntax
+;;> \scheme{shell}, similar to SCSH's \scheme{run}, except that a
+;;> single top-level pipe is implied.  The above becomes:
+;;>
+;;> \schemeblock{(shell (echo "hello") (tr "a-z" "A-Z"))}
+;;>
+;;> A command without any arguments can be written as a single symbol
+;;> without a list:
+;;>
+;;> \schemeblock{(shell (echo "hello") rev)} => "olleh\n"
+;;>
+;;> You can chain together any number of commands, implicitly joined
+;;> in a pipe.  I/O redirection works by putting the redirection
+;;> operator after the command it modifies:
+;;>
+;;> \schemeblock{(shell cat (< "input.txt") (tr "a-z" "A-Z") (> "out"))}
+;;>
+;;> for the following operators:
+;;>
+;;> \itemlist[
+;;> \item{ \scheme{(< input)}: redirect stdin from the file input }
+;;> \item{ \scheme{(<< obj)}: redirect stdin from the displayed output of obj }
+;;> \item{ \scheme{(> output)}: redirect stdout to the file output }
+;;> \item{ \scheme{(>> output)}: append stdout to the file output }
+;;> \item{ \scheme{(err> output)}: redirect stderr to the file output }
+;;> \item{ \scheme{(err>> output)}: append stderr to the file output }
+;;>  ]
+;;>
+;;> Commands can also be combined logically with several operators:
+;;>
+;;> \itemlist[
+;;> \item{ \scheme{(do cmd1 cmd2 ...)}: run the commands in sequence }
+;;> \item{ \scheme{(and cmd1 cmd2 ...)}: run the commands in sequence until the first fails }
+;;> \item{ \scheme{(or cmd1 cmd2 ...)}: run the commands in sequence until the first succeeds }
+;;> \item{ \scheme{(>< cmd1 cmd2 ...)}: pipe the output of each command to the input of the next }
+;;> \item{ \scheme{(if test pass fail)}: if test succeeds run pass, else fail }
+;;>  ]
+;;>
+;;> Note although piping is implicit in the \scheme{shell} syntax
+;;> itself, the \scheme{><} operator can be useful for nested
+;;> pipelines, or to structure a pipeline in one expression so you can
+;;> group all I/O modifiers for it as a whole, e.g.
+;;>
+;;> \schemeblock{(shell (< x) cat rev (> y))}
+;;>
+;;> could also be written as
+;;>
+;;> \schemeblock{(shell (>< cat rev) (< x) (> y))}
+;;>
+;;> As a convenience, to collect the output to a string we have
+;;> \scheme{shell->string};
+;;>
+;;> \schemeblock{(shell->string (echo "hello") (tr "a-z" "A-Z")) => "HELLO"}
+;;>
+;;> Similarly, the following variants are provided:
+;;>
+;;> \scheme{shell->string-list}: returns a list of one string per line
+;;> \scheme{shell->sexp}: returns the output parsed as a sexp
+;;> \scheme{shell->sexp-list}: returns a list of one sexp per line
+
+(define-auxiliary-syntax ><)
+(define-auxiliary-syntax <<)
+(define-auxiliary-syntax >>)
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (get-output-string out)))
+
+(define (close-file-descriptors-in-range lo hi)
+  (cond
+   ((find file-directory? '("/proc/self/fd" "/dev/fd"))
+    => (lambda (dir)
+         (for-each
+          (lambda (file)
+            (cond ((string->number file)
+                   => (lambda (fd)
+                        (when (<= lo fd hi)
+                          (close-file-descriptor fd))))))
+          (directory-files dir))))))
+
+(define (shell-object->string x)
+  (if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
+
+(define (shell-command cmd)
+  (cond
+   ((procedure? cmd)
+    cmd)
+   ((not (pair? cmd))
+    (shell-command (list cmd)))
+   (else
+    (lambda (child-in child-out)
+      (let ((pid (shell-fork)))
+        (cond
+         ((not pid)
+          (error "couldn't fork"))
+         ((zero? pid)                   ; child
+          (child-in)
+          (child-out)
+          (let ((ls (map shell-object->string cmd)))
+            (shell-exec (car ls) ls)
+            (exit 0)))
+         (else                          ; parent
+          (list pid))))))))
+
+(define (shell-scheme-command proc)
+  (lambda (child-in child-out)
+    (let ((pid (shell-fork)))
+      (cond
+       ((not pid)
+        (error "couldn't fork"))
+       ((zero? pid)                     ; child
+        (child-in)
+        (child-out)
+        (proc)
+        (exit 0))
+       (else                            ; parent
+        (list pid))))))
+
+(define (shell-stdout-to-pipe pipe . o)
+  (let ((fileno (if (pair? o) (car o) 1)))
+    (close-file-descriptor (car pipe))
+    (duplicate-file-descriptor-to (cdr pipe) fileno)
+    (close-file-descriptor (cdr pipe))))
+
+(define (shell-stderr-to-pipe pipe . o)
+  (let ((fileno (if (pair? o) (car o) 2)))
+    (close-file-descriptor (car pipe))
+    (duplicate-file-descriptor-to (cdr pipe) fileno)
+    (close-file-descriptor (cdr pipe))))
+
+(define (shell-stdin-from-pipe pipe . o)
+  (let ((fileno (if (pair? o) (car o) 0)))
+    (close-file-descriptor (cdr pipe))
+    (duplicate-file-descriptor-to (car pipe) fileno)
+    (close-file-descriptor (car pipe))))
+
+(define (shell-pipe cmd . cmds)
+  (let ((cmd1 (shell-command cmd)))
+    (if (null? cmds)
+        cmd1
+        (let ((cmd2 (apply shell-pipe cmds)))
+          (lambda (child-in child-out)
+            (cmd2
+             (lambda ()
+               (let ((pipe (shell-create-pipe)))
+                 (let* ((pids
+                         (cmd1
+                          child-in
+                          (lambda ()
+                            (shell-stdout-to-pipe pipe)
+                            (close-file-descriptors-in-range 3 +inf.0)))))
+                   (shell-stdin-from-pipe pipe))))
+             (lambda ()
+               (child-out)
+               (close-file-descriptors-in-range 3 +inf.0))))))))
+
+;;;; variant starting the input process first
+;; (define (shell-pipe cmd1 . cmds)
+;;   (let ((cmd1 (shell-command cmd1)))
+;;     (if (null? cmds)
+;;         cmd1
+;;         (let ((cmd2 (apply shell-pipe cmds)))
+;;           (lambda (child-in child-out)
+;;             (cmd1
+;;              child-in
+;;              (lambda ()
+;;                (let ((pipe (shell-create-pipe)))
+;;                  (let* ((pids
+;;                          (cmd2
+;;                           (lambda () (shell-stdin-from-pipe pipe))
+;;                           (lambda ()
+;;                             (child-out)
+;;                             (close-file-descriptors-in-range 3 +inf.0)))))
+;;                    (shell-stdout-to-pipe pipe)
+;;                    (close-file-descriptors-in-range 3 +inf.0))))))))))
+
+;;;; variant creating the pipe in the parent
+;; (define (shell-pipe cmd1 . cmds)
+;;   (let ((cmd1 (shell-command cmd1)))
+;;     (if (null? cmds)
+;;         cmd1
+;;         (let ((cmd2 (apply shell-pipe cmds)))
+;;           (lambda (child-in child-out)
+;;             (let* ((pipe (shell-create-pipe))
+;;                    (pid1
+;;                     (cmd1 child-in
+;;                           (lambda ()
+;;                             (shell-stdout-to-pipe pipe)
+;;                             (close-file-descriptors-in-range 3 +inf.0))))
+;;                    (pid2
+;;                     (cmd2 (lambda ()
+;;                             (shell-stdin-from-pipe pipe))
+;;                           (lambda ()
+;;                             (child-out)
+;;                             (close-file-descriptors-in-range 3 +inf.0)))))
+;;               (close-file-descriptor (car pipe))
+;;               (close-file-descriptor (cdr pipe))
+;;               (append pid1 pid2)))))))
+
+(define (shell-wait pid)
+  (waitpid pid 0))
+
+(define (shell-if test pass . o)
+  (let ((fail (and (pair? o) (shell-command (car o)))))
+    (lambda (child-in child-out)
+      (let ((pids ((shell-command test) child-in child-out)))
+        (if (every (lambda (pid) (zero? (cadr (shell-wait pid)))) pids)
+            ((shell-command pass) child-in child-out)
+            (if fail (fail child-in child-out) '()))))))
+
+(define (shell-seq pred cmd . cmds)
+  (lambda (child-in child-out)
+    (let lp ((cmds (map shell-command (cons cmd cmds))))
+      (cond
+       ((null? cmds)
+        '())
+       ((null? (cdr cmds))
+        ((car cmds) child-in child-out))
+       (else
+        (let ((pids ((car cmds) child-in child-out)))
+          (if (pred (every (lambda (pid) (zero? (cadr (shell-wait pid)))) pids))
+              (lp (cdr cmds))
+              '())))))))
+
+(define (shell-and cmd . cmds)
+  (apply shell-seq values cmd cmds))
+
+(define (shell-or cmd . cmds)
+  (apply shell-seq not cmd cmds))
+
+(define (shell-do cmd . cmds)
+  (apply shell-seq (lambda (res) #t) cmd cmds))
+
+(define (redirect file mode fileno)
+  (duplicate-file-descriptor-to (open file mode) fileno))
+
+(define (in< file) (redirect file open/read 0))
+(define (out> file)
+  (redirect file (bitwise-ior open/write open/create open/truncate) 1))
+(define (out>> file)
+  (redirect file (bitwise-ior open/write open/create open/append) 1))
+(define (err> file)
+  (redirect file (bitwise-ior open/write open/create open/truncate) 2))
+(define (err>> file)
+  (redirect file (bitwise-ior open/write open/create open/append) 2))
+
+(define (with-in< file cmd)
+  (lambda (in out)
+    (cmd (lambda () (in) (in< file)) out)))
+(define (with-out> file cmd)
+  (lambda (in out)
+    (cmd in (lambda () (out) (out> file)))))
+(define (with-out>> file cmd)
+  (lambda (in out)
+    (cmd in (lambda () (out) (out>> file)))))
+(define (with-err> file cmd)
+  (lambda (in out)
+    (cmd in (lambda () (out) (err> file)))))
+(define (with-err>> file cmd)
+  (lambda (in out)
+    (cmd in (lambda () (out) (err>> file)))))
+
+(define (shell&* cmd)
+  ((shell-command cmd) (lambda () #f) (lambda () #f)))
+
+(define (call-with-shell-io cmd proc)
+  (let ((cmd (if (procedure? cmd) cmd (apply shell-command cmd)))
+        (in-pipe (shell-create-pipe))
+        (out-pipe (shell-create-pipe))
+        (err-pipe (shell-create-pipe)))
+    (let ((pids
+           (cmd (lambda ()
+                  (shell-stdin-from-pipe in-pipe))
+                (lambda ()
+                  (shell-stdout-to-pipe out-pipe)
+                  (shell-stderr-to-pipe err-pipe)))))
+      (close-file-descriptor (car in-pipe))
+      (close-file-descriptor (cdr out-pipe))
+      (close-file-descriptor (cdr err-pipe))
+      (let ((res (proc pids
+                       (open-output-file-descriptor (cdr in-pipe))
+                       (open-input-file-descriptor (car out-pipe))
+                       (open-input-file-descriptor (car err-pipe)))))
+        (for-each shell-wait pids)
+        res))))
+
+(define (shell-with-output cmd proc)
+  (call-with-shell-io cmd (lambda (pids in out err) (proc out))))
+
+(define-syntax shell-analyze
+  (syntax-rules (< << > >> err> err>>)
+    ;; I/O operators before any commands - accumulate in cur.
+    ((shell-analyze join ((< file) . rest) () (cur ...))
+     (shell-analyze join rest () (cur ... (< file))))
+    ((shell-analyze join ((<< str) . rest) () (cur ...))
+     (shell-analyze join rest () (cur ... (<< str))))
+    ((shell-analyze join ((> file) . rest) () (cur ...))
+     (shell-analyze join rest () (cur ... (> file))))
+    ((shell-analyze join ((>> file) . rest) () (cur ...))
+     (shell-analyze join rest () (cur ... (>> file))))
+    ((shell-analyze join ((err> file) . rest) () (cur ...))
+     (shell-analyze join rest () (cur ... (err> file))))
+    ((shell-analyze join ((err>> file) . rest) () (cur ...))
+     (shell-analyze join rest () (cur ... (err>> file))))
+
+    ;; I/O operators after a command - append to the last command.
+    ((shell-analyze join ((< file) . rest) (cmds ... (cmd ...)) x)
+     (shell-analyze join rest (cmds ... (cmd ... (< file))) x))
+    ((shell-analyze join ((<< str) . rest) (cmds ... cmd) x)
+     (shell-analyze join rest (cmds ... ((apply (lambda () (display `str)))) cmd) x))
+    ((shell-analyze join ((> file) . rest) (cmds ... (cmd ...)) x)
+     (shell-analyze join rest (cmds ... (cmd ... (> file))) x))
+    ((shell-analyze join ((>> file) . rest) (cmds ... (cmd ...)) x)
+     (shell-analyze join rest (cmds ... (cmd ... (>> file))) x))
+    ((shell-analyze join ((err> file) . rest) (cmds ... (cmd ...)) x)
+     (shell-analyze join rest (cmds ... (cmd ... (err> file))) x))
+    ((shell-analyze join ((err>> file) . rest) (cmds ... (cmd ...)) x)
+     (shell-analyze join rest (cmds ... (cmd ... (err>> file))) x))
+
+    ;; Anything but an I/O operator is a normal command.
+    ((shell-analyze join (cmd . rest) (cmds ...) (cur ...))
+     (shell-analyze join rest (cmds ... (cmd cur ...)) ()))
+
+    ;; Join the analyzed results.
+    ((shell-analyze join () ((cmd . ops) ...) x)
+     (join (shell-analyze-io (shell-analyze-one cmd) ops) ...))
+    ))
+
+(define-syntax shell-analyze-one
+  (syntax-rules (>< do and or if apply)
+    ((shell-analyze-one (do cmds ...))
+     (shell-analyze shell-do (cmds ...) () ()))
+    ((shell-analyze-one (if cmds ...))
+     (shell-analyze shell-if (cmds ...) () ()))
+    ((shell-analyze-one (and cmds ...))
+     (shell-analyze shell-and (cmds ...) () ()))
+    ((shell-analyze-one (or cmds ...))
+     (shell-analyze shell-or (cmds ...) () ()))
+    ((shell-analyze-one (>< cmds ...))
+     (shell-analyze shell-pipe (cmds ...) () ()))
+    ((shell-analyze-one (apply proc))
+     (shell-scheme-command proc))
+    ((shell-analyze-one cmd)
+     (shell-command `cmd))
+    ))
+
+(define-syntax shell-analyze-io
+  (syntax-rules (< > >> err> err>>)
+    ((shell-analyze-io cmd ((< file) . rest))
+     (shell-analyze-io (with-in< (shell-object->string `file) cmd) rest))
+    ((shell-analyze-io cmd ((> file) . rest))
+     (shell-analyze-io (with-out> (shell-object->string `file) cmd) rest))
+    ((shell-analyze-io cmd ((>> file) . rest))
+     (shell-analyze-io (with-out>> (shell-object->string `file) cmd) rest))
+    ((shell-analyze-io cmd ((err> file) . rest))
+     (shell-analyze-io (with-err> (shell-object->string `file) cmd) rest))
+    ((shell-analyze-io cmd ((err>> file) . rest))
+     (shell-analyze-io (with-err>> (shell-object->string `file) cmd) rest))
+    ((shell-analyze-io cmd ())
+     cmd)))
+
+(define-syntax shell&
+  (syntax-rules ()
+    ((shell& cmd ...)
+     ((shell-analyze shell-pipe (cmd ...) () ())
+      (lambda () #f)
+      (lambda () #f)))))
+
+;;> Returns the exit status of the last command in the pipeline.
+(define-syntax shell
+  (syntax-rules ()
+    ((shell cmd ...)
+     (map shell-wait (shell& cmd ...)))))
+
+(define-syntax shell->string
+  (syntax-rules ()
+    ((shell->string cmd ...)
+     (shell-with-output (shell-analyze shell-pipe (cmd ...) () ())
+                        port->string))))
+
+(define-syntax shell->string-list
+  (syntax-rules ()
+    ((shell->string cmd ...)
+     (shell-with-output (shell-analyze shell-pipe (cmd ...) () ())
+                        port->string-list))))
+
+(define-syntax shell->sexp
+  (syntax-rules ()
+    ((shell->string cmd ...)
+     (shell-with-output (shell-analyze shell-pipe (cmd ...) () ())
+                        read))))
+
+(define-syntax shell->sexp-list
+  (syntax-rules ()
+    ((shell->string cmd ...)
+     (shell-with-output (shell-analyze shell-pipe (cmd ...) () ())
+                        port->sexp-list))))

lib/chibi/shell.sld

@@ -0,0 +1,29 @@
+
+(define-library (chibi shell)
+  (import (scheme base) (scheme bitwise) (scheme char) (scheme cxr)
+          (scheme list) (scheme write) (srfi 130)
+          (chibi io) (chibi filesystem) (chibi process)
+          (only (chibi) port-fileno define-auxiliary-syntax))
+  (export shell shell& shell-pipe call-with-shell-io
+          shell->string shell->string-list
+          shell->sexp shell->sexp-list
+          shell-if shell-and shell-or shell-do
+          in< out> err> out>> err>> >< >> <<)
+  (begin
+    (define shell-fork fork)
+    (define shell-exec execute)
+    (define shell-exit exit)
+    (define (shell-wait pid)
+      (cadr (waitpid pid 0)))
+    (define (shell-create-pipe) (apply cons (open-pipe)))
+    (define shell-dup duplicate-file-descriptor-to)
+    (define shell-open-input open-input-file-descriptor)
+    (define shell-open-output open-output-file-descriptor)
+    (define shell-close close-file-descriptor)
+    (define (shell-port->fd port)
+      (port-fileno port))
+    (define (shell-fd->input-port fd)
+      (open-input-file-descriptor fd))
+    (define (shell-fd->output-port fd)
+      (open-output-file-descriptor fd)))
+  (include "shell.scm"))

lib/chibi/show/c.scm

@@ -7,7 +7,7 @@
     ((define-state-variables var ...)
      (begin
        (define var
-         (make-computation-environment-variable 'var #f #f))
+         (make-state-variable 'var #f #f))
        ...))))
 
 (define-state-variables
@@ -398,6 +398,11 @@
         ((null? x) #f)
         (else x)))
 
+(define (list-without-dot x)
+  (let lp ((ls x) (res '()))
+    (cond ((pair? ls) (lp (cdr ls) (cons (car ls) res)))
+          (else (reverse res)))))
+
 (define (replace-tree from to x)
   (let replace ((x x))
     (cond ((eq? x from) to)
@@ -422,7 +427,9 @@
                                (in-macro? (pair? x))
                                (macro-vars
                                 (map (lambda (v) (if (pair? v) (cadr v) v))
-                                     (if (pair? x) x (list x))))
+                                     (if (pair? x)
+                                         (list-without-dot x)
+                                         (list x))))
                                (op 'zero))
                           (c-in-expr (apply c-begin body)))))
                 "")))

lib/chibi/show/c.sld

@@ -21,5 +21,5 @@
    cpp-error cpp-warning cpp-stringify cpp-sym-cat
    c-comment c-block-comment c-attribute)
   (import (chibi) (chibi string) (chibi show) (chibi show pretty)
-          (srfi 1) (srfi 165) (scheme cxr))
+          (srfi 1) (scheme cxr))
   (include "c.scm"))