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,73 +118,171 @@ 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)
-list(REMOVE_ITEM slds ${chibi-scheme-exclude-modules})
+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
 #
 
-string(REPLACE ";" "\n" genstatic-input "${slds}")
+if (NOT BUILD_SHARED_LIBS)
-set(clibin ${CMAKE_CURRENT_BINARY_DIR}/clib-in.txt)
+    string(REPLACE ";" "\n" genstatic-input "${slds}")
-set(clibout ${CMAKE_CURRENT_BINARY_DIR}/clib.c)
+    set(clibin ${CMAKE_CURRENT_BINARY_DIR}/clib-in.txt)
-set(genstatic-helper 
+    set(clibout ${CMAKE_CURRENT_BINARY_DIR}/clib.c)
+    set(genstatic-helper
         ${CMAKE_CURRENT_LIST_DIR}/contrib/chibi-genstatic-helper.cmake)
-file(WRITE ${clibin} "${genstatic-input}")
+    file(WRITE ${clibin} "${genstatic-input}")
 
-add_custom_command(OUTPUT ${clibout}
+    add_custom_command(OUTPUT ${clibout}
         COMMAND
         ${CMAKE_COMMAND}
         -DEXEC=$<TARGET_FILE:chibi-scheme-bootstrap>
@@ -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

@@ -46,13 +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 assert 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 \
 	optional parse pathname process repl scribble string stty sxml system \
 	temp-file test time trace type-inference uri weak monad/environment \
-	crypto/sha2
+	crypto/sha2 shell
 
 IMAGE_FILES = lib/chibi.img lib/red.img lib/snow.img
 
@@ -90,13 +91,22 @@ chibi-scheme-emscripten: VERSION
 	$(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 $@ $<
 
@@ -138,7 +148,11 @@ chibi-scheme-ulimit$(EXE): main.o $(SEXP_ULIMIT_OBJS) $(EVAL_OBJS)
 	$(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
@@ -207,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 > $@
 
@@ -261,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
 
@@ -301,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 $(DESTDIR)$(MODDIR)/srfi/179 
+	$(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/
@@ -323,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/
@@ -351,12 +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/
@@ -391,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"
-	-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.repl -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
-	-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 -mchibi.repl -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
-	-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:
@@ -438,6 +460,7 @@ uninstall:
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(BINMODDIR)/chibi/snow
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/text $(DESTDIR)$(BINMODDIR)/chibi/text
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/time $(DESTDIR)$(BINMODDIR)/scheme/time
@@ -468,6 +491,8 @@ uninstall:
 	-$(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

Makefile.detect

@@ -52,6 +52,10 @@ endif
 endif
 endif
 
+ifndef ARCH
+ARCH = $(shell uname -m)
+endif
+
 ########################################################################
 # Set default variables for the platform.
 

Makefile.libs

@@ -67,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
@@ -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,9 +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`.
+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 @@
-neon
+sodium

VERSION

@@ -1 +1 @@
-0.10.0
+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.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
@@ -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}}
@@ -1249,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}}
@@ -1285,6 +1311,12 @@ snow-fort):
 \item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-166.html"]{(srfi 166) - monadic formatting}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-179/srfi-179.html"]{(srfi 179) - nonempty intervals and generalized arrays}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-188/srfi-188.html"]{(srfi 188) - splicing binding constructs for syntactic keywords}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-193/srfi-193.html"]{(srfi 193) - command-line}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-211/srfi-211.html"]{(srfi 211) - scheme macro libaries}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-219/srfi-219.html"]{(srfi 219) - define higher-order lambda}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-227/srfi-227.html"]{(srfi 227) - optional arguments}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-229/srfi-229.html"]{(srfi 229) - tagged procedures}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-231/srfi-231.html"]{(srfi 231) - intervals and generalized arrays}}
 
 ]
 
@@ -1301,6 +1333,8 @@ namespace.
 
 \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}}
@@ -1367,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)}}
@@ -1583,7 +1621,7 @@ 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}

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);
   }
@@ -624,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))
@@ -664,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))
@@ -764,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);
@@ -783,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)) {
@@ -805,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;
 }
 
@@ -900,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);
@@ -1062,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)) {
@@ -1075,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:
@@ -1106,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));
@@ -1145,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))) {
@@ -1330,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
@@ -1623,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);
@@ -1664,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);
     }
   }
@@ -1863,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 {
@@ -1963,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)) {
@@ -1974,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) {
@@ -1985,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))
@@ -2199,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) {
@@ -2492,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

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

@@ -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 */
@@ -177,6 +188,10 @@
 /* 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. */
@@ -252,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 */
@@ -280,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 */
@@ -324,6 +345,15 @@
 #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            */
 /************************************************************************/
@@ -448,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
@@ -656,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
@@ -680,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/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
@@ -270,6 +270,7 @@ 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
@@ -394,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;
 };
 
@@ -441,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];
@@ -459,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;
@@ -476,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;
@@ -510,7 +511,6 @@ struct sexp_struct {
     struct {
       signed char sign;
       sexp_uint_t length;
-      sexp_uint_t data SEXP_FLEXIBLE_ARRAY;
     } bignum;
     struct {
       sexp numerator, denominator;
@@ -522,7 +522,6 @@ struct sexp_struct {
       sexp parent;
       sexp_uint_t length;
       void *value;
-      char body SEXP_FLEXIBLE_ARRAY;
     } cpointer;
     /* runtime types */
     struct {
@@ -534,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 {
@@ -578,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,
@@ -777,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)
@@ -794,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
@@ -879,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)
@@ -894,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))
@@ -1046,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 &&                    \
@@ -1072,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
@@ -1110,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
@@ -1128,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))
@@ -1143,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,
@@ -1169,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))
@@ -1188,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
@@ -1206,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))
@@ -1253,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))
@@ -1263,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)
 
@@ -1353,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))
@@ -1498,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 ****************************/
 
@@ -1672,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);
@@ -1748,6 +1790,7 @@ 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, ...);
@@ -1755,6 +1798,7 @@ 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);
@@ -1783,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))

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/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) {
@@ -651,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);
@@ -689,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);
@@ -735,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);

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

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

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

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

@@ -267,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
@@ -1039,7 +1041,8 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
 (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/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

lib/chibi/match-test.sld

@@ -51,6 +51,16 @@
         (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))
@@ -69,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)))

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.
 
@@ -128,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))}
 
@@ -242,6 +247,8 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
+;; 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
@@ -565,30 +572,47 @@
 (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) ...))
+    ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
-    ;;  (match-check-identifier p
+     (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))
+             fk))
-    ;;    ;; simple case, match all elements of the list
+       ;; simple case, match all elements of the list
-    ;;    (let loop ((ls v) (id-ls '()) ...)
+       (let loop ((ls v) (id-ls '()) ...)
-    ;;      (cond
+         (cond
-    ;;        ((null? ls)
+           ((null? ls)
-    ;;         (let ((id (reverse id-ls)) ...) (sk ... i)))
+            (let ((id (reverse id-ls)) ...) (sk ... i)))
-    ;;        ((pair? ls)
+           ((pair? ls)
-    ;;         (let ((w (car ls)))
+            (let ((w (car ls)))
-    ;;           (match-one w p ((car ls) (set-car! ls))
+              (match-one w p ((car ls) (set-car! ls))
-    ;;                      (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
+                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
-    ;;                      fk i)))
+                         fk i)))
-    ;;        (else
+           (else
-    ;;         fk)))))
+            fk)))))
     ((_ 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))))
@@ -607,7 +631,8 @@
                               fk
                               (i ...))))
                 (else
-                 fk)))))))))
+                 fk)))
+           )))))))
 
 ;; Variant of the above where the rest pattern is in a quasiquote.
 
@@ -1095,6 +1120,12 @@
     (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))))))))
 
@@ -1115,6 +1146,12 @@
     (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))))))))
 
@@ -1177,4 +1214,18 @@
                             ((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

@@ -47,6 +47,7 @@
       (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))
@@ -56,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))
@@ -71,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))
@@ -86,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))
@@ -107,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)
@@ -175,57 +189,84 @@
          ((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/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
@@ -53,8 +54,9 @@
                    (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)
@@ -63,7 +65,7 @@
                 (let restart ((request request))
                   (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")))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -145,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
@@ -523,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.
 
@@ -549,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,7 +8,8 @@
    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
+   http-send-file)
   (import
    (scheme time) (srfi 39) (srfi 95)
    (chibi) (chibi mime) (chibi regexp) (chibi pathname) (chibi uri)

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

@@ -47,12 +47,55 @@
           ((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 '(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)

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

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,6 +402,16 @@
         ((= (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 ((thread (current-thread))
         (out (repl-out rp)))
@@ -409,7 +421,7 @@
      (lambda ()
        (protect (exn
                  (else
-                  (print-exception exn out)
+                  (repl-print-exception exn out)
                   (repl-advise-exception exn (current-error-port))))
          (for-each
           (lambda (expr)
@@ -420,17 +432,17 @@
                           (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))))))
 

lib/chibi/repl.sld

@@ -1,8 +1,9 @@
 
 (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)

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

@@ -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/snow/commands.scm

@@ -772,7 +772,9 @@
                              => (lambda (y)
                                   `("-F" ,(string-append
                                            (display-to-string (car x)) "="
-                                           (display-to-string (cdr y))))))
+                                           (write-to-string
+                                            (display-to-string (cdr y)))
+                                           "\""))))
                             ((and (pair? (cdr x)) (assq 'file (cdr x)))
                              => (lambda (y)
                                   `("-F" ,(string-append
@@ -781,7 +783,8 @@
                             (else
                              `("-F" ,(string-append
                                       (display-to-string (car x)) "="
-                                      (display-to-string (cdr x)))))))
+                                      (write-to-string
+                                       (display-to-string (cdr x))))))))
                          params)
                       ,(uri->string uri))))
       (open-input-bytevector (process->bytevector cmd))))
@@ -791,10 +794,18 @@
     (http-post uri params))))
 
 (define (remote-command cfg name path params)
-  (let ((uri (remote-uri cfg name path)))
+  (let* ((uri (remote-uri cfg name path))
-    (sxml-display-as-text
+         (response
-     (read (snow-post cfg uri (cons '(fmt . "sexp") params))))
+          (port->string (snow-post cfg uri (cons '(fmt . "sexp") params)))))
+    (guard (exn (else
+                 (display "ERROR: couldn't display sxml response: ")
+                 (write response)
                  (newline)))
+      (let ((sxml (call-with-input-string response read)))
+        (if (null? sxml)
+            (display "WARN: () response from server")
+            (sxml-display-as-text sxml))
+        (newline)))))
 
 (define (command/reg-key cfg spec)
   (let* ((keys (call-with-input-file
@@ -1004,7 +1015,11 @@
          (let ((dir (make-path (get-install-source-dir impl cfg) path)))
            (if (and (file-directory? dir)
                     (= 2 (length (directory-files dir))))
-               (remove-directory cfg dir)))))))
+               (remove-directory cfg dir)))
+         (when (eq? impl 'guile)
+           (let ((go-file (string-append (make-path (get-install-library-dir impl cfg) path)
+                                         ".go")))
+             (warn-delete-file cfg go-file)))))))
 
 (define (command/remove cfg spec . args)
   (let* ((impls (conf-selected-implementations cfg))
@@ -1159,9 +1174,9 @@
                    `(,(car repo) (url ,repo-uri) ,@(cdr repo))))))
     (cond
      ((not (valid-repository? repo))
-      (warn "not a valid repository: " repo-uri repo))
+      (warn "not a valid repository" repo-uri repo))
      ((not (create-directory* local-dir))
-      (warn "can't create directory: " local-dir))
+      (warn "can't create directory" local-dir))
      (else
       (guard (exn (else (die 2 "couldn't write repository")))
         (call-with-output-file local-tmp
@@ -1194,10 +1209,17 @@
 
 ;; returns the single repo as a sexp, updated as needed
 (define (maybe-update-repository cfg repo-uri)
-  (or (guard (exn (else #f))
+  (or (guard (exn
+              (else
+               (warn "error updating remote repository: "
+                     repo-uri " error: " exn)
+               #f))
         (and (should-update-repository? cfg repo-uri)
              (update-repository cfg repo-uri)))
-      (guard (exn (else '(repository)))
+      (guard (exn
+              (else
+               (warn "error reading local repository: " exn)
+               '(repository)))
         (call-with-input-file (repository-local-path cfg repo-uri)
           read))))
 
@@ -1249,7 +1271,8 @@
             (lp (cdr ls) seen res)
             (let* ((repo (maybe-update-repository cfg uri))
                    (siblings
-                    (if (and repo (conf-get cfg 'follow-siblings? #t))
+                    (if (and (valid-repository? repo)
+                             (conf-get cfg 'follow-siblings? #t))
                         (let ((uri-base
                                (if (string-suffix? "/" uri)
                                    uri
@@ -1311,6 +1334,12 @@
           '(csi -R chicken.platform -p "(car (repository-path))")))
      char-whitespace?)))
 
+(define (get-guile-site-dir)
+  (process->string '(guile -c "(display (%site-dir))")))
+
+(define (get-guile-site-ccache-dir)
+  (process->string '(guile -c "(display (%site-ccache-dir))")))
+
 (define (get-install-dirs impl cfg)
   (define (guile-eval expr)
     (guard (exn (else #f))
@@ -1383,7 +1412,10 @@
                (chibi (eval '(current-module-path) (environment '(chibi))))
                (else (process->sexp
                       '(chibi-scheme -q -p "(current-module-path)"))))))
-            (lib-dir (find (lambda (d) (string-contains d "/lib")) dirs)))
+            (lib-dir (find (lambda (d)
+                             (and (equal? (string-ref d 0) #\/)
+                                  (string-contains d "/lib")))
+                           dirs)))
        (if lib-dir
            (cons lib-dir (delete lib-dir dirs))
            dirs)))
@@ -1563,7 +1595,7 @@
        (lambda (file acc)
          (cond
           ((and (equal? "meta" (path-extension file))
-                (guard (exn (else #f))
+                (guard (exn (else (warn "read meta failed" exn) #f))
                   (let ((pkg (call-with-input-file file read)))
                     (and (package? pkg)
                          (every file-exists? (package-installed-files pkg))
@@ -1588,6 +1620,9 @@
 (define native-srfi-support
   '((foment 60)
     (gauche 0 1 4 5 7 9 11 13 14 19 26 27 29 31 37 42 43 55)
+    (guile 0 1 2 4 6 8 9 10 11 13 14 16 17 18 19 23 26 27 28 30 31 34
+           35 37 38 39 41 42 43 45 46 55 60 61 62 64 67 69 71 87 88
+           98 105 111 171)
     (kawa 1 2 13 14 34 37 60 69 95)
     (larceny 0 1 2 4 5 6 7 8 9 11 13 14 16 17 19 22 23 25 26 27 28 29
              30 31 37 38 39 41 42 43 45 48 51 54 56 59 60 61 62 63 64
@@ -1644,10 +1679,11 @@
   (cond
    ((eq? impl 'chicken) (get-install-library-dir impl cfg))
    ((eq? impl 'cyclone) (get-install-library-dir impl cfg))
+   ((eq? impl 'guile) (get-guile-site-dir))
    ((conf-get cfg 'install-source-dir))
    ((conf-get cfg 'install-prefix)
     => (lambda (prefix) (make-path prefix "share/snow" impl)))
-   (else (car (get-install-dirs impl cfg)))))
+   (else snow-module-directory)))
 
 (define (get-install-data-dir impl cfg)
   (cond
@@ -1656,7 +1692,7 @@
    ((conf-get cfg 'install-data-dir))
    ((conf-get cfg 'install-prefix)
     => (lambda (prefix) (make-path prefix "share/snow" impl)))
-   (else (car (get-install-dirs impl cfg)))))
+   (else snow-module-directory)))
 
 (define (get-install-library-dir impl cfg)
   (cond
@@ -1670,9 +1706,11 @@
            (car (get-install-dirs impl cfg)))))
    ((eq? impl 'cyclone)
     (car (get-install-dirs impl cfg)))
+   ((eq? impl 'guile)
+    (get-guile-site-ccache-dir))
    ((conf-get cfg 'install-prefix)
     => (lambda (prefix) (make-path prefix "lib" impl)))
-   (else (car (get-install-library-dirs impl cfg)))))
+   (else snow-binary-module-directory)))
 
 (define (get-install-binary-dir impl cfg)
   (cond
@@ -1832,17 +1870,60 @@
           (cons dest-so-path
                 (default-installer impl cfg library dir)))))
 
+(define (guile-installer impl cfg library dir)
+  (let* ((source-scm-file (get-library-file cfg library))
+         (source-go-file (string-append
+                          (library->path cfg library) ".go"))
+         (dest-scm-file
+          (string-append (library->path cfg library) ".scm"))
+         (dest-go-file
+          (string-append (library->path cfg library) ".go"))
+         (include-files
+          (library-include-files impl cfg (make-path dir source-scm-file)))
+         (install-dir (get-install-source-dir impl cfg))
+         (install-lib-dir (get-install-library-dir impl cfg)))
+    (let ((scm-path (make-path install-dir dest-scm-file))
+          (go-path (make-path install-lib-dir dest-go-file)))
+      (install-directory cfg (path-directory scm-path))
+      (install-directory cfg (path-directory go-path))
+      (install-file cfg (make-path dir source-scm-file) scm-path)
+      (install-file cfg (make-path dir source-go-file) go-path)
+      ;; install any includes
+      (cons
+       scm-path
+       (append
+        (map
+         (lambda (x)
+           (let ((dest-file (make-path install-dir (path-relative x dir))))
+             (install-directory cfg (path-directory dest-file))
+             (install-file cfg x dest-file)
+             dest-file))
+         include-files)
+        (map
+         (lambda (x)
+           (let* ((so-file (string-append x (cond-expand (macosx ".dylib")
+                                                         (else ".so"))))
+                  (dest-file (make-path install-lib-dir
+                                        (path-relative so-file dir))))
+             (install-directory cfg (path-directory dest-file))
+             (install-file cfg so-file dest-file)
+             dest-file))
+         (library-shared-include-files
+          impl cfg (make-path dir source-scm-file))))))))
+
 ;; installers should return the list of installed files
 (define (lookup-installer installer)
   (case installer
     ((chicken) chicken-installer)
     ((cyclone) cyclone-installer)
+    ((guile) guile-installer)
     (else default-installer)))
 
 (define (installer-for-implementation impl cfg)
   (case impl
     ((chicken) 'chicken)
     ((cyclone) 'cyclone)
+    ((guile) 'guile)
     (else 'default)))
 
 (define (install-library impl cfg library dir)
@@ -2007,16 +2088,33 @@
                               " - install anyway?"))
               library))))))
 
+(define (guile-builder impl cfg library dir)
+  (let* ((library-file (get-library-file cfg library))
+         (src-library-file (make-path dir library-file))
+         (library-dir (path-directory src-library-file))
+         (dest-library-file
+          (string-append (library->path cfg library) ".go"))
+         (dest-dir
+          (path-directory (make-path dir dest-library-file))))
+    ;; ensure the build directory exists
+    (create-directory* dest-dir)
+    (with-directory
+     dir
+     (lambda ()
+       (and (system 'guild 'compile '-O0 '--r7rs '-o dest-library-file src-library-file)
+            library)))))
+
 (define (lookup-builder builder)
   (case builder
     ((chibi) chibi-builder)
     ((chicken) chicken-builder)
     ((cyclone) cyclone-builder)
+    ((guile) guile-builder)
     (else default-builder)))
 
 (define (builder-for-implementation impl cfg)
   (case impl
-    ((chibi chicken cyclone) impl)
+    ((chibi chicken cyclone guile) impl)
     (else 'default)))
 
 (define (build-library impl cfg library dir)
@@ -2112,7 +2210,8 @@
          (install-dir (get-install-data-dir impl cfg))
          (dest (path-resolve dest0 install-dir)))
     (create-directory* (path-directory dest))
-    (install-file cfg (make-path dir src) dest)))
+    (install-file cfg (make-path dir src) dest)
+    dest))
 
 (define (fetch-package cfg url)
   (resource->bytevector cfg url))

lib/chibi/snow/commands.sld

@@ -59,4 +59,11 @@
    ((library (srfi 151)) (import (srfi 151)))
    ((library (srfi 33)) (import (srfi 33)))
    (else (import (srfi 60))))
+  (cond-expand
+   ((library (chibi snow install))
+    (import (chibi snow install)))
+   (else
+    (begin
+      (define snow-module-directory "/usr/local/share/snow")
+      (define snow-binary-module-directory "/usr/local/lib/snow"))))
   (include "commands.scm"))

lib/chibi/snow/fort.scm

@@ -102,11 +102,11 @@
          (key (guard (exn (else #f)) (call-with-input-file key-file read))))
     (and (pair? key) (assoc-get key 'password))))
 
-(define (package-dir email pkg)
+(define (package-dir email pkg . o)
   (make-path
    (email->path email)
    (string-join (map escape-path (map x->string (package-name pkg))) "/")
-   (escape-path (package-version pkg))))
+   (escape-path (if (pair? o) (car o) (package-version pkg)))))
 
 ;; Simplistic pretty printing for package/repository/config declarations.
 (define (write-simple-pretty pkg out)
@@ -257,6 +257,76 @@
                            (value . "Search Libraries"))))))
      ,body)))
 
+(define (dependency-url cfg dep . o)
+  (if (and (eq? 'srfi (car dep))
+           (pair? (cdr dep))
+           (integer? (cadr dep))
+           (null? (cddr dep)))
+      (string-append "https://srfi.schemers.org/srfi-"
+                     (number->string (cadr dep))
+                     "/")
+      ;; TODO: alternative impls
+      (let* ((repo (if (pair? o) (car o) (current-repo cfg)))
+             (pkg (find (lambda (p)
+                          (and (package? p)
+                               (any (lambda (m) (equal? dep (library-name m)))
+                                    (package-libraries p))))
+                        (cdr repo))))
+        (and pkg
+             (make-path "/s" (package-dir (package-email pkg) pkg "latest"))))))
+
+(define (package-page pkg files . o)
+  (let* ((cfg (if (pair? o) (car o) (make-conf '() #f #f 0)))
+         (repo (if (and (pair? o) (pair? (cdr o)))
+                   (cadr o)
+                   (current-repo cfg))))
+    `(div
+      (div "☃ " (b ,(package-name pkg)) " - " (i ,(package-version pkg)))
+      (div ,(or (assoc-get pkg 'description) ""))
+      ,(let ((auth (package-author '() pkg))
+             (maint (package-maintainer '() pkg)))
+         `(div ,auth
+               ,@(if (and maint (not (equal? maint auth)))
+                     `((" (" ,maint ")"))
+                     '())
+               ,(cond ((assoc-get pkg 'license)
+                       => (lambda (x)
+                            (string-append " - " (write-to-string x))))
+                      (else ""))))
+      ,@(cond
+         ((assq 'manual (cdr pkg))
+          => (lambda (ls)
+               (if (and (pair? ls) (pair? (cdr ls)))
+                   (if (or (string-prefix? "http:" (cadr ls))
+                           (string-prefix? "https:" (cadr ls)))
+                       `((a (@ (href . ,(cadr ls))) "doc"))
+                       `((a (@ (href . ,(make-path "files" (cadr ls))))
+                            "Documentation")))
+                   '())))
+         (else '()))
+      (div
+       (b "Dependencies")
+       (ul
+        ,@(map
+           (lambda (dep)
+             `(li (a (@ (href . ,(dependency-url cfg dep repo)))
+                     ,(write-to-string dep))))
+           (filter
+            (lambda (dep)
+              (and (pair? dep) (not (eq? 'scheme (car dep)))))
+            (package-dependencies 'chibi cfg pkg)))))
+      (div
+       (b "Files")
+       (ul
+        ,@(map
+           (lambda (file) `(li (a (@ (href . ,(make-path "files" file))) ,file)))
+           (filter
+            (lambda (file)
+              (and (string? file)
+                   (not (equal? "" file))
+                   (not (string-prefix? "." file))))
+            files)))))))
+
 (define (respond cfg request proc)
   (let ((sexp? (equal? "sexp" (request-param request "fmt"))))
     (servlet-write

lib/chibi/snow/fort.sld

@@ -8,7 +8,8 @@
           invalid-signature-reason
           rewrite-repo update-repo
           update-repo-package update-repo-object
-          repo-publishers current-repo get-user-password)
+          repo-publishers current-repo get-user-password
+          dependency-url package-page)
   (import (scheme base)
           (scheme read)
           (scheme write)
@@ -16,6 +17,7 @@
           (srfi 1)
           (srfi 18)
           (chibi snow package)
+          (chibi snow utils)
           (chibi bytevector)
           (chibi config)
           (chibi crypto rsa)

lib/chibi/snow/utils.scm

@@ -29,6 +29,10 @@
             ,(delay
                (process->sexp
                 '(gosh -uscheme.base -e "(write (features))"))))
+    (guile "guile" (guile -e "(display (version))") "3.0.8"
+           ,(delay
+              (process->sexp
+               '(guile --r7rs -c "(import (scheme base)) (display (features))"))))
     (kawa "kawa" (kawa --version) "2.0"
           ,(delay
              (process->sexp

lib/chibi/sxml-test.sld

@@ -0,0 +1,10 @@
+
+(define-library (chibi sxml-test)
+  (import (scheme base) (chibi sxml) (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests)
+      (test-begin "sxml")
+      (test "<html><body><div><p>hello, world</p><br></div></body></html>"
+          (sxml->xml '(*TOP* (html (body (div (p "hello, world") (br)))))))
+      (test-end))))

lib/chibi/sxml.scm

@@ -40,11 +40,11 @@
     (lambda (out) (html-display-escaped-attr (display-to-string str) out))))
 
 (define (html-attr->string attr)
-  (if (cdr attr)
+  (if (null? (cdr attr))
+      (symbol->string (car attr))
       (let ((val (if (pair? (cdr attr)) (cadr attr) (cdr attr))))
         (string-append (symbol->string (car attr))
-                       "=\"" (html-escape-attr val) "\""))
+                       "=\"" (html-escape-attr val) "\""))))
-      (symbol->string (car attr))))
 
 (define (html-tag->string tag attrs)
   (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
@@ -80,13 +80,27 @@
   (call-with-output-string
     (lambda (out) (html-display-escaped-string str out))))
 
+(define indentable-elements
+  '(address article aside base blockquote body dd details dialog
+    div dl dt fieldset figcaption figure footer form h1 h2 h3 h4
+    h5 h6 head header hgroup hr li link main meta nav ol p pre
+    script section style table title ul))
+
+(define (indent i out)
+  (do ((j (* 2 i) (- j 1))) ((= j 0)) (write-char #\space out)))
+
 ;;> Render (valid, expanded) \var{sxml} as html.
 ;;> \var{@raw} tag is considered safe text and not processed or escaped.
-(define (sxml-display-as-html sxml . o)
+(define (sxml-display-as-html sxml . args)
-  (let ((out (if (pair? o) (car o) (current-output-port))))
+  (let* ((out (if (null? args) (current-output-port) (car args)))
+         (args (if (null? args) args (cdr args)))
+	 (indent? (if (null? args) #f (car args)))
+         (args (if (null? args) args (cdr args))))
+    (unless (null? args) (error "too many args"))
     (let lp ((sxml (if (and (pair? sxml) (eq? '*TOP* (car sxml)))
                        (cdr sxml)
-                       sxml)))
+                       sxml))
+	     (depth 0))
       (cond
        ((pair? sxml)
         (let ((tag (car sxml))
@@ -106,17 +120,23 @@
              ((and (pair? rest)
                    (pair? (car rest))
                    (eq? '@ (caar rest)))
+	      (when (and indent? (memq tag indentable-elements))
+		(newline out)
+		(indent depth out))
 	      (display (html-tag->string tag (cdar rest)) out)
-              (for-each lp (cdr rest))
+	      (for-each (lambda (x) (lp x (+ 1 depth))) (cdr rest))
 	      (unless (and (null? (cdr rest)) (memq tag void-elements))
                 (display "</" out) (display tag out) (display ">" out)))
              (else
+	      (when (and indent? (memq tag indentable-elements))
+		(newline out)
+		(indent depth out))
 	      (display (html-tag->string tag '()) out)
-              (for-each lp rest)
+	      (for-each (lambda (x) (lp x (+ 1 depth))) rest)
 	      (unless (and (null? rest) (memq tag void-elements))
                 (display "</" out) (display tag out) (display ">" out)))))
            (else
-            (for-each lp sxml)))))
+            (for-each (lambda (x) (lp x (+ 1 depth))) sxml)))))
        ((null? sxml))
        (else (html-display-escaped-string sxml out))))))
 
@@ -147,7 +167,7 @@
                        sxml)))
     (let lp ((sxml sxml))
       (cond
-       ((pair? sxml)
+       ((proper-list? sxml)
         (let ((tag (car sxml)))
           (cond
            ;; skip headers and the menu
@@ -156,16 +176,18 @@
                      (pair? (cdr sxml))
                      (pair? (cadr sxml))
                      (eq? '@ (car (cadr sxml)))
-                     (equal? '(id . "menu") (assq 'id (cdr (cadr sxml)))))))
+                     (equal? '(id . "menu") (assq 'id (cdr (cadr sxml))))))
+            )
            ;; recurse other tags, appending newlines for new sections
            ((symbol? tag)
             (if (memq tag '(h1 h2 h3 h4 h5 h6))
                 (newline out))
-            (for-each
+            (let ((ls (if (and (pair? (cdr sxml))
-             lp
+                               (pair? (cadr sxml))
-             (if (and (pair? (cdr sxml)) (eq? '@ (cadr sxml)))
+                               (eq? '@ (car (cadr sxml))))
                           (cddr sxml)
-                 (cdr sxml)))
+                          (cdr sxml))))
+              (for-each lp ls))
             (if (memq tag '(p li br h1 h2 h3 h4 h5 h6))
                 (newline out)))
            (else

lib/chibi/sxml.sld

@@ -4,5 +4,5 @@
 (define-library (chibi sxml)
   (export sxml->xml sxml-display-as-html sxml-display-as-text sxml-strip
           html-escape html-tag->string)
-  (import (scheme base) (scheme write))
+  (import (scheme base) (scheme list) (scheme write))
   (include "sxml.scm"))