Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Compare commits

base: Fcalva:master
Branches Tags
Fcalva:master
Fcalva:srfi-227
Fcalva:srfi-229
Fcalva:syntax-rules-parser
Fcalva:revert-619-command-lines
Fcalva:compacting
Fcalva:wiki
Fcalva:hugenums
Fcalva:0.11
Fcalva:0.10
Fcalva:0.9.1
Fcalva:0.9
Fcalva:0.8
Fcalva:0.7.3
Fcalva:0.7.2
Fcalva:0.7.1
Fcalva:0.7
Fcalva:0.6.1
Fcalva:0.6
Fcalva:0.5.3
Fcalva:0.5.2
Fcalva:0.5.1
Fcalva:0.5
Fcalva:stable
Fcalva:0.4
Fcalva:0.3
Fcalva:0.2
..
compare: Fcalva:0.10
Branches Tags
Fcalva:master
Fcalva:srfi-227
Fcalva:srfi-229
Fcalva:syntax-rules-parser
Fcalva:revert-619-command-lines
Fcalva:compacting
Fcalva:wiki
Fcalva:hugenums
Fcalva:0.11
Fcalva:0.10
Fcalva:0.9.1
Fcalva:0.9
Fcalva:0.8
Fcalva:0.7.3
Fcalva:0.7.2
Fcalva:0.7.1
Fcalva:0.7
Fcalva:0.6.1
Fcalva:0.6
Fcalva:0.5.3
Fcalva:0.5.2
Fcalva:0.5.1
Fcalva:0.5
Fcalva:stable
Fcalva:0.4
Fcalva:0.3
Fcalva:0.2

No commits in common. "master" and "0.10" have entirely different histories.
master ... 0.10

194 changed files with 1458 additions and 13476 deletions
Show stats Expand all files Collapse all files

2
.gitignore vendored
View file

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

19
AUTHORS
View file

@ -32,57 +32,38 @@ 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

563
CMakeLists.txt
View file

@ -1,28 +1,33 @@
#
# FIXME: This CMakeLists.txt is only for Win32 platforms for now
#
cmake_minimum_required(VERSION 3.12)
cmake_minimum_required(VERSION 2.8.7)
project(chibi-scheme)
file(READ ${CMAKE_CURRENT_SOURCE_DIR}/VERSION version)
string(STRIP ${version} version)
include(CheckIncludeFile)
#
# Version setting
#
file(READ ${CMAKE_CURRENT_SOURCE_DIR}/RELEASE release)
string(STRIP ${release} release)
project(chibi-scheme LANGUAGES C VERSION ${version}
DESCRIPTION "Chibi-Scheme: minimal r7rs implementation, release: ${release}")
file(READ ${CMAKE_CURRENT_SOURCE_DIR}/VERSION rawversion)
string(STRIP ${rawversion} rawversion)
set(version "${rawversion}-cmake")
include(CheckIncludeFile)
include(CheckSymbolExists)
include(GNUInstallDirs)
include(CMakePackageConfigHelpers)
set(chibischemelib "chibi-scheme-${rawversion}")
set(CMAKE_EXPORT_COMPILE_COMMANDS ON)
if(APPLE)
message(FATAL_ERROR
"DYLD platforms are not supported with this CMakeLists.txt. Use Makefile instead.")
endif()
set(CMAKE_BUILD_TYPE "${CMAKE_BUILD_TYPE}" CACHE STRING
"Build type: None, Debug, Release, RelWithDebInfo, MinSizeRel, or Sanitizer." FORCE)
if (NOT EXISTS ${CMAKE_BINARY_DIR}/CMakeCache.txt AND NOT CMAKE_BUILD_TYPE)
# CMake doesn't have a default build type, so set one manually
set(CMAKE_BUILD_TYPE "RelWithDebInfo" CACHE STRING "" FORCE)
if(UNIX)
message(FATAL_ERROR
"UNIX platforms are not supported with this CMakeLists.txt. Use Makefile instead.")
endif()
#
@ -30,25 +35,33 @@ endif()
#
check_include_file(poll.h HAVE_POLL_H)
check_symbol_exists(ntp_gettime sys/timex.h HAVE_NTP_GETTIME)
check_symbol_exists(int_least8_t inttypes.h HAVE_STDINT_H)
check_include_file(stdint.h HAVE_STDINT_H)
# option(CHIBI_SCHEME_USE_DL "Use dynamic loading" ON)
set(CHIBI_SCHEME_USE_DL OFF)
option(CHIBI_SCHEME_SHARED "Build chibi-scheme as a shared library" ON)
if (WIN32 AND NOT CYGWIN)
set(DEFAULT_SHARED_LIBS OFF)
else()
set(DEFAULT_SHARED_LIBS ON)
if(NOT CHIBI_SCHEME_SHARED)
add_definitions(-DSEXP_STATIC_LIBRARY=1)
endif()
option(BUILD_SHARED_LIBS "Build chibi-scheme as a shared library" ${DEFAULT_SHARED_LIBS})
option(SEXP_USE_BOEHM "Use Boehm garbage collection library" OFF)
if(CHIBI_SCHEME_USE_DL)
add_definitions(-DSEXP_USE_DL=1)
else()
add_definitions(-DSEXP_USE_DL=0)
endif()
if(SEXP_USE_BOEHM)
find_library(BOEHMGC gc REQUIRED)
find_path(BOEHMGC_INCLUDE NAMES gc/gc.h)
if(HAVE_STDINT_H)
add_definitions(-DSEXP_USE_INTTYPES=1)
endif()
if(NOT HAVE_POLL_H)
# Disable green threads: It depends on non-blocking I/O
add_definitions(-DSEXP_USE_GREEN_THREADS=0)
endif()
set(chibi-scheme-exclude-modules)
if(WIN32)
add_definitions(-DBUILDING_DLL)
set(chibi-scheme-exclude-modules
# Following modules are not compatible with Win32
lib/chibi/net.sld
@ -59,48 +72,6 @@ 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
#
@ -118,171 +89,73 @@ 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)
target_link_libraries(chibi-scheme-bootstrap PRIVATE libchibi-common)
#
# Core library
#
add_library(libchibi-scheme
${chibi-scheme-srcs})
target_link_libraries(libchibi-scheme
PUBLIC libchibi-common)
set_target_properties(libchibi-scheme
PROPERTIES
PREFIX "" # It's liblibchibi-scheme otherwise
SOVERSION ${CMAKE_PROJECT_VERSION_MAJOR}
VERSION ${CMAKE_PROJECT_VERSION})
if(WIN32)
target_link_libraries(chibi-scheme-bootstrap ws2_32)
endif()
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}
CONFIGURE_DEPENDS lib/*.sld)
if (chibi-scheme-exclude-modules)
# CMake doesn't complain anymore about an empty 2nd argument, but 3.12 does. When we require a
# more recent version, the if-guard should go.
list(REMOVE_ITEM slds ${chibi-scheme-exclude-modules})
endif()
${CMAKE_CURRENT_SOURCE_DIR}/lib/*.sld)
list(REMOVE_ITEM slds ${chibi-scheme-exclude-modules})
set(chibi-ffi ${CMAKE_CURRENT_SOURCE_DIR}/tools/chibi-ffi)
set(chibi-genstatic ${CMAKE_CURRENT_SOURCE_DIR}/tools/chibi-genstatic)
add_custom_target(chibi-compiled-libs)
function(add_compiled_library cfile)
if (NOT BUILD_SHARED_LIBS)
return()
endif()
set(link-libraries LINK_LIBRARIES)
cmake_parse_arguments(compiledlib-options "" "" "${link-libraries}" ${ARGN})
get_filename_component(basename ${cfile} NAME_WE)
get_filename_component(libdir ${cfile} DIRECTORY)
if(NOT IS_ABSOLUTE ${libdir})
set(libdir ${CMAKE_CURRENT_BINARY_DIR}/${libdir})
endif()
file(RELATIVE_PATH libname ${CMAKE_CURRENT_BINARY_DIR} ${libdir}/${basename})
string(REPLACE "/" "-" libname ${libname})
add_library(${libname} ${cfile})
target_link_libraries(${libname} PRIVATE libchibi-scheme ${compiledlib-options_LINK_LIBRARIES})
add_dependencies(chibi-compiled-libs ${libname})
set_target_properties(${libname} PROPERTIES
LIBRARY_OUTPUT_DIRECTORY ${libdir}
LIBRARY_OUTPUT_NAME ${basename}
PREFIX "")
file(RELATIVE_PATH installsubdir ${CMAKE_CURRENT_BINARY_DIR}/lib ${libdir})
install(TARGETS ${libname}
LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}/chibi/${installsubdir})
endfunction()
if(BUILD_SHARED_LIBS)
# This makes sure we only use the separate bootstrap executable for static
# builds. With dynamic linking, the default executable is fine. The dispatch
# is not a generator expression within the actual custom command to process
# the stubs, as older CMake versions fail to properly construct the dependency
# on the bootstrap executable from the generator expression.
set(bootstrap chibi-scheme)
else()
set(bootstrap chibi-scheme-bootstrap)
endif()
function(add_stubs_library stub)
set(link-libraries LINK_LIBRARIES)
cmake_parse_arguments(stubs-options "" "" "${link-libraries}" ${ARGN})
get_filename_component(stubdir ${stub} PATH)
get_filename_component(basename ${stub} NAME_WE)
set(stubfile ${CMAKE_CURRENT_SOURCE_DIR}/${stub})
set(stubdir ${CMAKE_CURRENT_BINARY_DIR}/${stubdir})
set(stuboutdir ${CMAKE_CURRENT_BINARY_DIR}/stubs/lib)
foreach(e ${stubs})
get_filename_component(stubdir ${e} PATH)
get_filename_component(basename ${e} NAME_WE)
set(stubfile ${CMAKE_CURRENT_SOURCE_DIR}/lib/${e})
set(stubdir ${stuboutdir}/${stubdir})
set(stubout ${stubdir}/${basename}.c)
set(stubouts ${stubouts} ${stubout} PARENT_SCOPE)
set(stublinkedlibs ${stublinkedlibs} ${stubs-options_LINK_LIBRARIES} PARENT_SCOPE)
file(MAKE_DIRECTORY ${stubdir})
add_custom_command(OUTPUT ${stubout}
COMMAND ${bootstrap} ${chibi-ffi} ${stubfile} ${stubout}
COMMAND chibi-scheme-bootstrap
${chibi-ffi} ${stubfile} ${stubout}
DEPENDS ${stubfile} ${chibi-ffi}
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
add_compiled_library(${stubout} LINK_LIBRARIES ${stubs-options_LINK_LIBRARIES})
endfunction()
add_stubs_library(lib/chibi/crypto/crypto.stub)
add_stubs_library(lib/chibi/emscripten.stub)
add_stubs_library(lib/chibi/filesystem.stub)
add_stubs_library(lib/chibi/io/io.stub)
add_stubs_library(lib/scheme/bytevector.stub)
add_stubs_library(lib/srfi/144/math.stub)
add_stubs_library(lib/srfi/160/uvprims.stub)
if(NOT WIN32)
add_stubs_library(lib/chibi/net.stub)
add_stubs_library(lib/chibi/process.stub)
add_stubs_library(lib/chibi/pty.stub LINK_LIBRARIES util)
add_stubs_library(lib/chibi/stty.stub)
add_stubs_library(lib/chibi/system.stub)
add_stubs_library(lib/chibi/time.stub)
else()
add_stubs_library(lib/chibi/win32/process-win32.stub)
endif()
list(APPEND stubouts ${stubout})
endforeach()
add_custom_target(chibi-scheme-stubs DEPENDS ${stubouts})
if (NOT BUILD_SHARED_LIBS)
add_dependencies(libchibi-scheme chibi-scheme-stubs)
endif()
add_compiled_library(lib/chibi/weak.c)
add_compiled_library(lib/chibi/heap-stats.c)
add_compiled_library(lib/chibi/disasm.c)
add_compiled_library(lib/chibi/ast.c)
add_compiled_library(lib/chibi/json.c)
add_compiled_library(lib/srfi/18/threads.c)
add_compiled_library(lib/chibi/optimize/rest.c)
add_compiled_library(lib/chibi/optimize/profile.c)
add_compiled_library(lib/srfi/27/rand.c)
add_compiled_library(lib/srfi/151/bit.c)
add_compiled_library(lib/srfi/39/param.c)
add_compiled_library(lib/srfi/69/hash.c)
add_compiled_library(lib/srfi/95/qsort.c)
add_compiled_library(lib/srfi/98/env.c)
add_compiled_library(lib/scheme/time.c)
#
# Generate clib.c for SEXP_USE_STATIC_LIBS
#
if (NOT BUILD_SHARED_LIBS)
string(REPLACE ";" "\n" genstatic-input "${slds}")
set(clibin ${CMAKE_CURRENT_BINARY_DIR}/clib-in.txt)
set(clibout ${CMAKE_CURRENT_BINARY_DIR}/clib.c)
set(genstatic-helper
string(REPLACE ";" "\n" genstatic-input "${slds}")
set(clibin ${CMAKE_CURRENT_BINARY_DIR}/clib-in.txt)
set(clibout ${CMAKE_CURRENT_BINARY_DIR}/clib.c)
set(genstatic-helper
${CMAKE_CURRENT_LIST_DIR}/contrib/chibi-genstatic-helper.cmake)
file(WRITE ${clibin} "${genstatic-input}")
file(WRITE ${clibin} "${genstatic-input}")
add_custom_command(OUTPUT ${clibout}
add_custom_command(OUTPUT ${clibout}
COMMAND
${CMAKE_COMMAND}
-DEXEC=$<TARGET_FILE:chibi-scheme-bootstrap>
@ -297,75 +170,87 @@ if (NOT BUILD_SHARED_LIBS)
${genstatic-helper}
${slds})
# The generated file will #include both manually written files in
# the source directory as well as files generated by chibi-ffi in
# the build directory. The latter can be found without special flags,
# as they are relative to the clib.c, but the preprocessor needs
# help for the former. As only clib.c needs this flag, we set it
# as locally as possible, i.e., not as a target property.
set_source_files_properties(${clibout}
PROPERTIES
INCLUDE_DIRECTORIES
${CMAKE_CURRENT_SOURCE_DIR})
#
# Core library
#
target_compile_definitions(libchibi-scheme
PUBLIC
SEXP_USE_STATIC_LIBS=1)
if(CHIBI_SCHEME_SHARED)
set(libtype SHARED)
else()
set(libtype STATIC)
endif()
target_sources(libchibi-scheme
PRIVATE
add_library(${chibischemelib} ${libtype}
${chibi-scheme-srcs}
${clibout})
target_link_libraries(libchibi-scheme
PRIVATE
${stublinkedlibs})
set_target_properties(${chibischemelib}
PROPERTIES
COMPILE_DEFINITIONS "SEXP_USE_STATIC_LIBS=1")
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)
target_link_libraries(chibi-scheme
PRIVATE libchibi-scheme)
bless_chibi_scheme_executable(chibi-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 "unix")
set(platform "unknown")
endif()
if(WIN32)
# Leave this empty for now, as the default GNU install directories won't
# help on Windows.
set(default_module_path "")
else()
string(JOIN ":" default_module_path
${CMAKE_INSTALL_FULL_DATAROOTDIR}/chibi
${CMAKE_INSTALL_FULL_LIBDIR}/chibi
${CMAKE_INSTALL_FULL_DATAROOTDIR}/snow
${CMAKE_INSTALL_FULL_LIBDIR}/snow)
endif()
configure_file(include/chibi/install.h.in include/chibi/install.h)
set(default_module_path
""
#"${CMAKE_INSTALL_PREFIX}/${thePrefix}${pathsep}${CMAKE_INSTALL_PREFIX}/bin"
)
file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/include/chibi)
file(WRITE
${CMAKE_CURRENT_BINARY_DIR}/include/chibi/install.h
"#define sexp_so_extension \"${soext}\"
#define sexp_default_module_path \"${default_module_path}\"
#define sexp_platform \"${platform}\"
#define sexp_version \"\"
#define sexp_release_name \"${release}\"")
#
# Testing
@ -375,27 +260,28 @@ enable_testing()
set(chibi-scheme-tests
r7rs-tests
division-tests
syntax-tests
unicode-tests)
## Not connected
#division-tests
#r5rs-tests
#syntax-tests
#unicode-tests
## Require threads
# lib-tests
)
foreach(e ${chibi-scheme-tests})
add_test(NAME "${e}"
COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib tests/${e}.scm
COMMAND chibi-scheme tests/${e}.scm
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
endforeach()
add_test(NAME r5rs-test
COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib -xchibi tests/r5rs-tests.scm
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
file(GLOB_RECURSE srfi_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
CONFIGURE_DEPENDS lib/srfi/*/test.sld)
${CMAKE_CURRENT_SOURCE_DIR}/lib/srfi/*/test.sld)
file(GLOB_RECURSE chibi_scheme_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
CONFIGURE_DEPENDS lib/chibi/*-test.sld)
${CMAKE_CURRENT_SOURCE_DIR}/lib/chibi/*-test.sld)
set(win32testexcludes
set(testexcludes
# Excluded tests
chibi/filesystem-test
chibi/memoize-test
@ -410,25 +296,21 @@ set(win32testexcludes
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()
if(WIN32)
list(REMOVE_ITEM testlibs ${win32testexcludes})
endif()
list(REMOVE_ITEM testlibs ${testexcludes})
foreach(e ${testlibs})
string(REGEX REPLACE "/" "_" testname ${e})
string(REGEX REPLACE "/" " " form ${e})
add_test(NAME "lib_${testname}"
COMMAND chibi-scheme -I ${CMAKE_CURRENT_BINARY_DIR}/lib
-e "(import (${form}))"
COMMAND chibi-scheme -e "(import (${form}))"
-e "(run-tests)"
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
endforeach()
@ -440,8 +322,7 @@ endforeach()
add_executable(test-foreign-apply-loop
tests/foreign/apply-loop.c)
target_link_libraries(test-foreign-apply-loop
PRIVATE libchibi-scheme)
bless_chibi_scheme_executable(test-foreign-apply-loop)
add_test(NAME "foreign-apply-loop"
COMMAND test-foreign-apply-loop
@ -450,154 +331,8 @@ add_test(NAME "foreign-apply-loop"
add_executable(test-foreign-typeid
tests/foreign/typeid.c)
target_link_libraries(test-foreign-typeid
PRIVATE libchibi-scheme)
bless_chibi_scheme_executable(test-foreign-typeid)
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)

13
CONTRIBUTING.md
View file

@ -1,13 +0,0 @@
# 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).

2
COPYING
View file

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

51
Makefile
View file

@ -46,14 +46,13 @@ 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 binary-record bytevector config \
crypto/md5 crypto/rsa crypto/sha2 diff disasm doc edit-distance \
equiv filesystem generic heap-stats io \
iset/base iset/constructors iset/iterators json loop \
MODULE_DOCS := app assert ast base64 bytevector config crypto/md5 crypto/rsa \
crypto/sha2 diff disasm doc edit-distance equiv filesystem generic \
heap-stats io iset/base iset/constructors iset/iterators json loop \
match math/prime memoize mime modules net net/http-server net/servlet \
optional parse pathname process repl scribble string stty sxml system \
temp-file test time trace type-inference uri weak monad/environment \
crypto/sha2 shell
crypto/sha2
IMAGE_FILES = lib/chibi.img lib/red.img lib/snow.img
@ -91,22 +90,13 @@ chibi-scheme-emscripten: VERSION
$(MAKE) distclean; \
mv "$$tempfile" chibi-scheme-emscripten)
include/chibi/install.h: Makefile.libs Makefile.detect
include/chibi/install.h: Makefile
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 $@ $<
@ -148,11 +138,7 @@ 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)
if [ -d .git ]; then \
$(GIT) ls-files lib | $(GREP) .sld | $(CHIBI) -q $(GENSTATIC) > $@; \
else \
$(FIND) lib -name \*.sld | $(CHIBI) -q $(GENSTATIC) > $@; \
fi
$(GIT) ls-files lib | $(GREP) .sld | $(CHIBI) -q $(GENSTATIC) > $@
chibi-scheme.pc: chibi-scheme.pc.in
echo "# pkg-config" > chibi-scheme.pc
@ -221,7 +207,6 @@ 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 > $@
@ -276,16 +261,13 @@ 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-syntax test-libs test-ffi test-division
test-all: test test-libs test-ffi test-division
test-dist: test-all test-memory test-build
@ -319,10 +301,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 $(DESTDIR)$(MODDIR)/chibi/text
$(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)/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 $(DESTDIR)$(MODDIR)/srfi/211 $(DESTDIR)$(MODDIR)/srfi/231
$(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
$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
@ -341,7 +323,6 @@ 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/
@ -370,15 +351,12 @@ 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/
@ -413,14 +391,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) >/dev/null 2>/dev/null; fi
-if type $(LDCONFIG) >/dev/null 2>/dev/null; then $(LDCONFIG); fi
install: install-base
ifneq "$(IMAGE_FILES)" ""
echo "Generating images"
-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.repl -d $(MODDIR)/chibi.img
-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -xscheme.red -mchibi.repl -d $(MODDIR)/red.img
-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils -d $(DESTDIR)$(MODDIR)/snow.img
-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
-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
-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
endif
uninstall:
@ -460,7 +438,6 @@ 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
@ -491,8 +468,6 @@ 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

4
Makefile.detect
View file

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

2
Makefile.libs
View file

@ -67,7 +67,7 @@ include Makefile.detect
########################################################################
all-libs: $(COMPILED_LIBS) lib/chibi/snow/install.sld
all-libs: $(COMPILED_LIBS)
lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES)
$(CHIBI_FFI) $<

12
README.md
View file

@ -2,7 +2,7 @@
**Minimal Scheme Implementation for use as an Extension Language**
https://github.com/ashinn/chibi-scheme
http://synthcode.com/wiki/chibi-scheme
Chibi-Scheme is a very small library intended for use as an extension
and scripting language in C programs. In addition to support for
@ -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, DragonFlyBSD, OS X, Plan 9, Windows, iOS, Android,
NetBSD, OpenBSD and 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,11 +50,9 @@ 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` (`DYLD_LIBRARY_PATH` on macOS) so it can find the
shared libraries.
`LD_LIBRARY_PATH` so it can find the shared libraries.
To make the emscripten build run `make js` (_not_ `emmake make js`).
To make the emscripten build run `make js`.
For more detailed documentation, run `make doc` and see the generated
*doc/chibi.html* or read the [manual](http://synthcode.com/scheme/chibi/)
online.
*doc/chibi.html*.

2
RELEASE
View file

@ -1 +1 @@
sodium
neon

2
VERSION
View file

@ -1 +1 @@
0.11.0
0.10.0

46
bignum.c
View file

@ -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_maybe_ratio(sexp_complex_real(tmp));
sexp_negate_maybe_ratio(sexp_complex_imag(tmp));
sexp_negate(sexp_complex_real(tmp));
sexp_negate(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.0)?-1:1)*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_gc_release1(ctx);
return res;
}
@ -1453,7 +1453,11 @@ 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) {
sexp_negate_maybe_ratio(r);
if (sexp_ratiop(r)) {
sexp_negate_exact(sexp_ratio_numerator(r));
} else {
sexp_negate_exact(r);
}
}
break;
#endif
@ -1485,10 +1489,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
if (negatep) {
if (sexp_complexp(r)) {
r = sexp_complex_copy(ctx, r);
sexp_negate_maybe_ratio(sexp_complex_real(r));
sexp_negate_maybe_ratio(sexp_complex_imag(r));
sexp_negate(sexp_complex_real(r));
sexp_negate(sexp_complex_imag(r));
} else {
sexp_negate_maybe_ratio(r);
sexp_negate(r);
}
}
break;
@ -1762,9 +1766,6 @@ 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;
@ -1867,16 +1868,16 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
sexp_gc_preserve1(ctx, tmp);
if (at > bt) {
r = sexp_compare(ctx, b, a);
if (!sexp_exceptionp(r)) { sexp_negate(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_FIX_CPX:
case SEXP_NUM_FLO_CPX: case SEXP_NUM_BIG_CPX:
case SEXP_NUM_CPX_CPX: case SEXP_NUM_CPX_FIX:
case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG:
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_CPX:
case SEXP_NUM_CPX_RAT:
#endif
#endif
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
@ -1885,13 +1886,12 @@ 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:
if (isinf(sexp_flonum_value(b))) {
r = sexp_flonum_value(b) > 0 ? SEXP_NEG_ONE : SEXP_ONE;
} else if (isnan(sexp_flonum_value(b))) {
f = sexp_fixnum_to_double(a);
g = sexp_flonum_value(b);
if (isnan(g))
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
} else {
r = sexp_compare(ctx, a, tmp=sexp_inexact_to_exact(ctx, NULL, 1, b));
}
else
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
break;
case SEXP_NUM_FIX_BIG:
if ((sexp_bignum_hi(b) > 1) ||
@ -1933,7 +1933,8 @@ 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 {
r = sexp_compare(ctx, tmp=sexp_inexact_to_exact(ctx, NULL, 1, a), b);
g = sexp_ratio_to_double(ctx, b);
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
}
break;
case SEXP_NUM_FIX_RAT:
@ -1944,9 +1945,6 @@ 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);

10
contrib/chibi-generate-install-meta-helper.cmake
View file

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

2
contrib/chibi-scheme-config.cmake
View file

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

14
contrib/chibi-scheme.pc.cmake.in
View file

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

2
doc/chibi-doc.1
View file

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

2
doc/chibi-ffi.1
View file

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

68
doc/chibi.scrbl
View file

@ -4,7 +4,7 @@
\author{Alex Shinn}
\centered{\smaller{Minimal Scheme Implementation for use as an Extension Language}}
\centered{\url{https://github.com/ashinn/chibi-scheme}}
\centered{\url{http://synthcode.com/wiki/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, OpenBSD, FreeBSD,
DragonFlyBSD, OS X, iOS, Windows (under Cygwin) and Plan9.
Chibi is known to build and run on 32 and 64-bit Linux, FreeBSD,
DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
\section{Installation}
@ -69,13 +69,6 @@ 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:
@ -86,8 +79,7 @@ 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 -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0"
make -B chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS
}
By default files are installed in /usr/local. You can optionally
@ -136,8 +128,6 @@ 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}
@ -165,14 +155,13 @@ 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. To minimize conflicts Chibi offers a special module named
\scheme{(auto)} which can export any identifier requested with
\scheme{only}, e.g. \scheme{(import (only (auto) foo))} will import
an auxiliary syntax \scheme{foo} binding. Separate modules can use
this to get the same binding without needing to know about each other
in advance. This is a Chibi-specific extension so is non-portable, but
you can always define a static \scheme{(auto)} module exporting a list
of all known bindings for other implementations.
keywords. By default Chibi considers all top-level bindings
effectively unbound when matching auxiliary keywords, so this case
will "just work". This decision was made because the chance of
different modules using the same keywords seems more likely than user
code unintentionally matching a top-level keyword with a different
binding, however if you want to use R7RS semantics you can compile
with \ccode{SEXP_USE_STRICT_TOPLEVEL_BINDINGS=1}.
\scheme{load} is extended to accept an optional environment argument, like
\scheme{eval}. You can also \scheme{load} shared libraries in addition to
@ -233,15 +222,6 @@ 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
@ -435,7 +415,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 attacks based thereon), but if you prefer convenience then
potential attackes 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},
@ -702,9 +682,7 @@ 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 (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_integerp(obj)} - \var{obj} is an integer}
\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}
@ -800,8 +778,6 @@ 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}
@ -834,7 +810,6 @@ 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}).}
@ -873,7 +848,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 ls1, sexp ls2)} - \scheme{append} for two arguments}
\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \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}}
@ -1274,7 +1249,6 @@ 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}}
@ -1311,12 +1285,6 @@ 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}}
]
@ -1333,8 +1301,6 @@ 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}}
@ -1401,10 +1367,6 @@ 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)}}
@ -1621,7 +1583,7 @@ command tells you which you currently have installed. The following
are currently supported:
\itemlist[
\item{chibi - version >= 0.7.3}
\item{chibi - native support as of 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}

162
eval.c
View file

@ -45,9 +45,7 @@ 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);
}
@ -626,7 +624,8 @@ 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 */
}
return sexp_contains_syntax_p_bound(ls1, depth-1);
if (sexp_synclop(ls1))
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))
@ -665,8 +664,6 @@ 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))
@ -767,26 +764,6 @@ 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);
@ -806,23 +783,14 @@ 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_var4(ref, value, cell, op);
sexp_gc_preserve4(ctx, ref, value, cell, op);
sexp_gc_var2(ref, value);
sexp_gc_preserve2(ctx, ref, value);
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_refp(ref) && sexp_lambdap(sexp_ref_loc(ref)))
if (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)) {
@ -837,8 +805,7 @@ static sexp analyze_set (sexp ctx, sexp x, int depth) {
sexp_set_source(res) = sexp_pair_source(x);
}
}
}
sexp_gc_release4(ctx);
sexp_gc_release2(ctx);
return res;
}
@ -933,18 +900,11 @@ 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(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail);
}
}
res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
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);
@ -1102,13 +1062,8 @@ 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)) {
@ -1120,12 +1075,7 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
: sexp_compile_error(ctx, "unexpected define", x);
break;
case SEXP_CORE_SET:
x = analyze_set(ctx, x, depth);
if (!sexp_exceptionp(x) && !sexp_setp(x))
goto loop;
else
res = x;
break;
res = analyze_set(ctx, x, depth); break;
case SEXP_CORE_LAMBDA:
res = analyze_lambda(ctx, x, depth); break;
case SEXP_CORE_IF:
@ -1156,7 +1106,14 @@ 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)) {
x = analyze_macro_once(ctx, x, op, depth);
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);
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));
@ -1188,14 +1145,7 @@ 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))) {
@ -1380,53 +1330,24 @@ 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_EMPTY
struct sexp_library_entry_t* sexp_static_libraries = NULL;
#elif SEXP_USE_STATIC_LIBS_NO_INCLUDE
#if 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, *table;
struct sexp_library_entry_t *entry;
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 (table = sexp_static_libraries;
table;
table = (struct sexp_library_entry_t*)entry->init) {
for (entry = &table[0]; entry->name; entry++)
for (entry = &sexp_static_libraries[0]; entry->name; entry++)
if (! strncmp(file, entry->name, base_len))
return entry;
}
return NULL;
}
#else
@ -1702,8 +1623,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); /* may be larger or smaller than z */
maybe_convert_ratio(ctx, z) /* TODO: add ratio sqrt */
d = (double)sexp_unbox_fixnum(z);
maybe_convert_ratio(ctx, z) /* XXXX add ratio sqrt */
maybe_convert_complex(z, sexp_complex_sqrt)
else
return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
@ -1743,11 +1664,6 @@ 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);
}
}
@ -1947,8 +1863,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) > (double)SEXP_MAX_FIXNUM)
|| sexp_flonum_value(z) < (double)SEXP_MIN_FIXNUM) {
} else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM)
|| sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
res = sexp_double_to_bignum(ctx, sexp_flonum_value(z));
#endif
} else {
@ -2047,7 +1963,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 (sexp_copy_on_writep(str) || old_len != new_len) { /* resize bytes if needed */
if (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)) {
@ -2058,17 +1974,10 @@ void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) {
p = q + i;
}
sexp_string_size(str) += new_len - old_len;
sexp_copy_on_writep(str) = 0;
}
sexp_utf8_encode_char(p, new_len, c);
if (old_len != new_len) {
#if SEXP_USE_STRING_INDEX_TABLE
if (old_len != new_len)
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) {
@ -2076,8 +1985,6 @@ 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))
@ -2292,9 +2199,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_LET_SYNTAX, (sexp)"let-syntax"},
{SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"},
{SEXP_CORE_DEFINE_SYNTAX, (sexp)"%define-syntax"},
{SEXP_CORE_LET_SYNTAX, (sexp)"%let-syntax"},
{SEXP_CORE_LETREC_SYNTAX, (sexp)"%letrec-syntax"},
};
sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
@ -2585,19 +2492,10 @@ 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;

3
examples/hello.scm
View file

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

36
examples/simple-http-client.scm
View file

@ -1,36 +0,0 @@
#! /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)))

16
examples/simple-http-server.scm
View file

@ -1,16 +0,0 @@
#! /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))))))))

4
gc.c
View file

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

2
include/chibi/bignum.h
View file

@ -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 v.lo;
return lsint_lt_0(v) ? -v.lo : v.lo;
}
static inline sexp_uint_t luint_to_uint(sexp_luint_t v) {

3
include/chibi/eval.h
View file

@ -129,7 +129,6 @@ 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);
@ -195,8 +194,6 @@ 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)

64
include/chibi/features.h
View file

@ -23,27 +23,16 @@
/* sexp_init_library(ctx, env) function provided. */
/* #define SEXP_USE_DL 0 */
/* uncomment this to support statically compiled C libs */
/* Unless SEXP_USE_STATIC_LIBS_EMPTY is set (see below), this */
/* will statically include the clibs.c file into the standard */
/* environment, so that you can have access to a predefined set */
/* of C libraries without needing dynamic loading. The clibs.c */
/* file is generated automatically by searching the lib directory */
/* for modules with include-shared, but can be hand-tailored to */
/* your needs. You can also register your own C libraries using */
/* sexp_add_static_libraries (see below). */
/* uncomment this to statically compile all C libs */
/* If set, this will statically include the clibs.c file */
/* into the standard environment, so that you can have */
/* access to a predefined set of C libraries without */
/* needing dynamic loading. The clibs.c file is generated */
/* automatically by searching the lib directory for */
/* modules with include-shared, but can be hand-tailored */
/* to your needs. */
/* #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 */
@ -188,10 +177,6 @@
/* 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. */
@ -267,12 +252,6 @@
/* */
/* #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 */
@ -301,7 +280,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 1 */
/* #define SEXP_USE_ALIGNED_BYTECODE */
/************************************************************************/
/* These settings are configurable but only recommended for */
@ -345,15 +324,6 @@
#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 */
/************************************************************************/
@ -478,17 +448,13 @@
#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 SEXP_USE_STATIC_LIBS_EMPTY
#define SEXP_USE_STATIC_LIBS 0
#endif
/* don't include clibs.c - include separately or link */
#ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
#if defined(PLAN9) || SEXP_USE_STATIC_LIBS_EMPTY
#ifdef PLAN9
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 0
#else
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 1
@ -690,10 +656,6 @@
#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
@ -718,10 +680,6 @@
#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

6
include/chibi/install.h.in
View file

@ -1,6 +0,0 @@
#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@"

98
include/chibi/sexp.h
View file

@ -1,5 +1,5 @@
/* sexp.h -- header for sexp library */
/* Copyright (c) 2009-2022 Alex Shinn. All rights reserved. */
/* Copyright (c) 2009-2015 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 [SEXP_FLEXIBLE_ARRAY_SIZE]
#define SEXP_FLEXIBLE_ARRAY [1]
#else
#define SEXP_FLEXIBLE_ARRAY []
#endif
@ -270,7 +270,6 @@ 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
@ -395,8 +394,8 @@ struct sexp_gc_var_t {
struct sexp_gc_var_t *next;
};
struct sexp_library_entry_t { /* for static builds and user exported C */
const char *name; /* libaries */
struct sexp_library_entry_t { /* for static builds */
const char *name;
sexp_init_proc init;
};
@ -442,7 +441,6 @@ 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];
@ -461,9 +459,11 @@ 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,19 +476,18 @@ 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;
@ -511,6 +510,7 @@ struct sexp_struct {
struct {
signed char sign;
sexp_uint_t length;
sexp_uint_t data SEXP_FLEXIBLE_ARRAY;
} bignum;
struct {
sexp numerator, denominator;
@ -522,6 +522,7 @@ struct sexp_struct {
sexp parent;
sexp_uint_t length;
void *value;
char body SEXP_FLEXIBLE_ARRAY;
} cpointer;
/* runtime types */
struct {
@ -533,10 +534,11 @@ 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; /* a boxed fixnum truncated to char */
char flags;
sexp_proc_num_args_t num_args;
} procedure;
struct {
@ -576,6 +578,7 @@ struct sexp_struct {
/* compiler state */
struct {
sexp_uint_t length, top;
sexp data SEXP_FLEXIBLE_ARRAY;
} stack;
struct {
sexp stack, env, parent, child,
@ -774,11 +777,9 @@ 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)
@ -793,12 +794,11 @@ 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,8 +879,6 @@ 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)
@ -896,8 +894,6 @@ 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))
@ -1050,10 +1046,7 @@ 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) || \
(sexp_ratiop(x) && \
sexp_exact_negativep(sexp_ratio_numerator(x))) || \
#define sexp_pedantic_negativep(x) (sexp_exact_negativep(x) || \
(sexp_flonump(x) && \
((sexp_flonum_value(x) < 0) || \
(sexp_flonum_value(x) == 0 && \
@ -1079,20 +1072,12 @@ 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
@ -1125,13 +1110,6 @@ 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
@ -1150,11 +1128,8 @@ SEXP_API unsigned short sexp_double_to_half(double 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_flexible_array_field(x, vector, sexp)
#define sexp_vector_data(x) (sexp_field(x, vector, SEXP_VECTOR, data))
#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))
@ -1168,18 +1143,17 @@ SEXP_API unsigned short sexp_double_to_half(double 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_flexible_array_field(x, bytes, char)
#define sexp_bytes_data(x) (sexp_field(x, bytes, SEXP_BYTES, data))
#define sexp_bytes_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_bytes_data(x))
static const unsigned char sexp_uvector_sizes[] = {
0, 1, 8, 8, 16, 16, 32, 32, 64, 64, 32, 64, 64, 128, 8, 16};
static const unsigned char sexp_uvector_chars[] = "#ususususuffccff";
0, 1, 8, 8, 16, 16, 32, 32, 64, 64, 32, 64, 64, 128};
static const unsigned char sexp_uvector_chars[] = "#ususususuffcc";
enum sexp_uniform_vector_type {
SEXP_NOT_A_UNIFORM_TYPE,
@ -1195,10 +1169,7 @@ enum sexp_uniform_vector_type {
SEXP_F32,
SEXP_F64,
SEXP_C64,
SEXP_C128,
SEXP_F8,
SEXP_F16,
SEXP_END_OF_UNIFORM_TYPES
SEXP_C128
};
#define sexp_uvector_freep(x) (sexp_freep(x))
@ -1217,17 +1188,13 @@ 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_flexible_array_field(x, string, char)
#define sexp_string_data(x) (sexp_field(x, string, SEXP_STRING, data))
#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
@ -1239,7 +1206,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_flexible_array_field(x, symbol, char)
#define sexp_lsymbol_data(x) (sexp_field(x, symbol, SEXP_SYMBOL, data))
#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))
@ -1286,6 +1253,7 @@ 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))
@ -1295,7 +1263,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_flexible_array_field(x, bytecode, unsigned char)
#define sexp_bytecode_data(x) (sexp_field(x, bytecode, SEXP_BYTECODE, data))
#define sexp_env_cell_syntactic_p(x) ((x)->syntacticp)
@ -1385,7 +1353,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_flexible_array_field(x, stack, sexp)
#define sexp_stack_data(x) (sexp_field(x, stack, SEXP_STACK, data))
#define sexp_promise_donep(x) (sexp_field(x, promise, SEXP_PROMISE, donep))
#define sexp_promise_value(x) (sexp_field(x, promise, SEXP_PROMISE, value))
@ -1530,7 +1498,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_flexible_array_field(x, bignum, sexp_uint_t)
#define sexp_bignum_data(x) (sexp_field(x, bignum, SEXP_BIGNUM, data))
/****************************** arithmetic ****************************/
@ -1704,16 +1672,6 @@ 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);
@ -1790,7 +1748,6 @@ 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, ...);
@ -1798,7 +1755,6 @@ 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);
@ -1827,7 +1783,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, ch) (sexp_string_utf8_set(ctx, s, i, ch))
#define sexp_string_cursor_set(ctx, s, i) (sexp_string_utf8_set(ctx, s, i))
#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))

2
lib/chibi/accept.c
View file

@ -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, sizeof(buf), "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
/* snprintf(buf, INET6_ADDRSTRLEN, "%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)) :

5
lib/chibi/app-test.sld
View file

@ -41,9 +41,4 @@
(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))))

100
lib/chibi/app.scm
View file

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

46
lib/chibi/ast.c
View file

@ -98,26 +98,9 @@ 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) (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));
return sexp_make_fixnum(sexp_procedure_flags(proc));
}
sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
@ -364,21 +347,12 @@ sexp sexp_immutablep_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
return sexp_pointerp(x) ? sexp_make_boolean(sexp_immutablep(x)) : SEXP_TRUE;
}
sexp sexp_immutable_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp s) {
sexp res;
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, s);
#if SEXP_USE_PACKED_STRINGS
/* no sharing with packed strings */
res = sexp_c_string(ctx, sexp_string_data(s), sexp_string_size(s));
#else
res = sexp_alloc_type(ctx, string, SEXP_STRING);
sexp_string_bytes(res) = sexp_string_bytes(s);
sexp_string_offset(res) = sexp_string_offset(s);
sexp_string_size(res) = sexp_string_size(s);
sexp_copy_on_writep(s) = 1;
#endif
sexp_immutablep(res) = 1;
return res;
sexp sexp_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_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
@ -677,6 +651,7 @@ 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);
@ -714,14 +689,11 @@ 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);
@ -763,7 +735,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, "immutable-string", 1, sexp_immutable_string_op);
sexp_define_foreign(ctx, env, "make-immutable!", 1, sexp_make_immutable_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);

28
lib/chibi/ast.scm
View file

@ -109,34 +109,6 @@
((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

10
lib/chibi/ast.sld
View file

@ -1,8 +1,7 @@
(define-library (chibi ast)
(export
analyze optimize env-cell ast->sexp macroexpand identifier-syntax
type-of
analyze optimize env-cell ast->sexp macroexpand 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
@ -26,11 +25,10 @@
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?
opcode-class opcode-code opcode-data opcode-variadic?
macro-procedure macro-env macro-source macro-aux macro-aux-set!
procedure-code procedure-vars procedure-name procedure-name-set!
procedure-arity procedure-variadic? procedure-variable-transformer?
procedure-flags make-variable-transformer make-procedure procedure?
procedure-arity procedure-variadic? procedure-flags
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!
@ -41,7 +39,7 @@
atomically thread-list abort
string-contains string-cursor-copy! errno integer->error-string
flatten-dot update-free-vars! setenv unsetenv safe-setenv
immutable? immutable-string make-immutable!
immutable? make-immutable!
thread-interrupt!
chibi-version)
(import (chibi))

31
lib/chibi/binary-record-test.sld
View file

@ -1,31 +0,0 @@
(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))))

82
lib/chibi/binary-record.scm
View file

@ -1,80 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
() () ()))))
;; binary records
(define-syntax defrec
(syntax-rules (make: pred: read: write: block:)
@ -158,3 +84,9 @@
((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
() () ()))))

25
lib/chibi/binary-record.sld
View file

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

14
lib/chibi/binary-types.scm
View file

@ -85,6 +85,20 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)

18
lib/chibi/char-set/full.scm
View file

File diff suppressed because one or more lines are too long

98
lib/chibi/csv-test.sld
View file

@ -1,98 +0,0 @@
(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))))

498
lib/chibi/csv.scm
View file

@ -1,498 +0,0 @@
;;> \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))))

11
lib/chibi/csv.sld
View file

@ -1,11 +0,0 @@
(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"))

16
lib/chibi/diff-test.sld
View file

@ -35,22 +35,6 @@
(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))

48
lib/chibi/diff.scm
View file

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

4
lib/chibi/disasm.c
View file

@ -22,13 +22,13 @@
static void sexp_write_pointer (sexp ctx, void *p, sexp out) {
char buf[32];
snprintf(buf, sizeof(buf), "%p", p);
snprintf(buf, 32, "%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, sizeof(buf), SEXP_PRId, n);
snprintf(buf, 32, SEXP_PRId, n);
sexp_write_string(ctx, buf, out);
}

10
lib/chibi/doc-test.sld
View file

@ -36,14 +36,4 @@
" 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))))

5
lib/chibi/doc.scm
View file

@ -267,8 +267,6 @@
(url . ,expand-url)
(hyperlink . ,expand-hyperlink)
(rawcode . code)
(pre . pre)
(bibitem . ,(lambda (x env) '())) ;; TODO: bibtex
(code . ,expand-code)
(codeblock . ,expand-codeblock)
(ccode
@ -1041,8 +1039,7 @@ 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 (protect (exn (else #f))
(module-ref mod x)))))
(let ((val (and mod (module-ref mod x))))
`(,x ,val ,(object-source val))))
exports)))
(define (resolve-file file)

2
lib/chibi/equiv.scm
View file

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

4
lib/chibi/filesystem.scm
View file

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

7
lib/chibi/highlight.scm
View file

@ -121,6 +121,10 @@
(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)
@ -130,6 +134,9 @@
((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))

14
lib/chibi/io-test.sld
View file

@ -134,20 +134,6 @@
(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)))

5
lib/chibi/io.sld
View file

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

21
lib/chibi/io/io.scm
View file

@ -9,10 +9,25 @@
(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)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (bytevector-length vec))))
(string-copy (utf8->string! vec start end))))
(if (pair? o)
(let ((start (car o))
(end (if (pair? (cdr o)) (cadr o) (bytevector-length vec))))
(utf8->string (subbytes vec start end)))
(string-copy (utf8->string! vec))))
(define (string->utf8 str . o)
(if (pair? o)

13
lib/chibi/io/io.stub
View file

@ -50,19 +50,8 @@
((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 (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))
((value ctx sexp) (value self sexp) sexp))
(define-c sexp (write-u8 "sexp_write_u8")
((value ctx sexp) (value self sexp) sexp (default (current-output-port) sexp)))

78
lib/chibi/io/port.c
View file

@ -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_uint_t offset, sexp_uint_t size) {
sexp sexp_bytes_to_string (sexp ctx, sexp vec) {
sexp res;
#if SEXP_USE_PACKED_STRINGS
res = sexp_c_string(ctx, sexp_bytes_data(vec) + offset, size);
res = sexp_c_string(ctx, sexp_bytes_data(vec), sexp_bytes_length(vec));
#else
res = sexp_alloc_type(ctx, string, SEXP_STRING);
sexp_string_bytes(res) = vec;
sexp_string_offset(res) = offset;
sexp_string_size(res) = size - offset;
sexp_string_offset(res) = 0;
sexp_string_size(res) = sexp_bytes_length(vec);
#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, 0, sexp_bytes_length(vec));
str = sexp_bytes_to_string(ctx, vec);
res = sexp_open_input_string(ctx, str);
sexp_port_binaryp(res) = 1;
sexp_gc_release2(ctx);
@ -341,72 +341,10 @@ sexp sexp_string_to_utf8 (sexp ctx, sexp self, sexp str) {
return sexp_string_to_bytes(ctx, res);
}
sexp sexp_string_to_utf8_x (sexp ctx, sexp self, sexp str) {
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) {
/* TODO: add validation */
sexp sexp_utf8_to_string_x (sexp ctx, sexp self, sexp vec) {
sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, 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));
return sexp_bytes_to_string(ctx, vec);
}
sexp sexp_write_u8 (sexp ctx, sexp self, sexp u8, sexp out) {

13
lib/chibi/iset-test.sld
View file

@ -243,17 +243,4 @@
(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))))

3
lib/chibi/iset.sld
View file

@ -19,5 +19,4 @@
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-rank iset-select))
iset-cursor iset-cursor? iset-cursor-next iset-ref end-of-iset?))

75
lib/chibi/iset/iterators.scm
View file

@ -95,75 +95,6 @@
(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
@ -270,6 +201,10 @@
(define (iset-size iset)
(iset-fold-node
(lambda (is acc) (+ acc (iset-node-size is)))
(lambda (is acc)
(let ((bits (iset-bits is)))
(+ acc (if bits
(bit-count bits)
(+ 1 (- (iset-end is) (iset-start is)))))))
0
iset))

2
lib/chibi/iset/iterators.sld
View file

@ -12,7 +12,5 @@
(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?))

4
lib/chibi/json-test.sld
View file

@ -9,8 +9,6 @@
(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\""))
@ -121,8 +119,6 @@
(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 "😐"))

44
lib/chibi/json.c
View file

@ -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) > (double)SEXP_MAX_FIXNUM) ?
return (inexactp || fabs(res) > 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_intern(ctx, "null", -1));
res = json_read_literal(ctx, self, in, "null", SEXP_VOID);
break;
case 't': case 'T':
res = json_read_literal(ctx, self, in, "true", SEXP_TRUE);
@ -406,43 +406,30 @@ 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;
sexp_gc_var2(tmp, res);
sexp ls, cur, key, val, tmp;
if (sexp_length(ctx, obj) == SEXP_FALSE)
sexp_json_write_exception(ctx, self, "unable to encode circular list", obj);
sexp_gc_preserve2(ctx, tmp, res);
res = SEXP_VOID;
return sexp_json_write_exception(ctx, self, "unable to encode circular list", obj);
sexp_write_char(ctx, '{', out);
for (ls = obj; sexp_pairp(ls); ls = sexp_cdr(ls)) {
if (ls != obj)
sexp_write_char(ctx, ',', out);
cur = sexp_car(ls);
if (!sexp_pairp(cur)) {
res = sexp_json_write_exception(ctx, self, "unable to encode key-value pair: not a pair", obj);
break;
}
if (!sexp_pairp(cur))
return sexp_json_write_exception(ctx, self, "unable to encode key-value pair: not a pair", obj);
key = sexp_car(cur);
if (!sexp_symbolp(key)) {
res = sexp_json_write_exception(ctx, self, "unable to encode key: not a symbol", key);
break;
}
tmp = sexp_symbol_to_string(ctx, key);
tmp = json_write(ctx, self, tmp, out);
if (sexp_exceptionp(tmp)) {
res = tmp;
break;
}
if (!sexp_symbolp(key))
return sexp_json_write_exception(ctx, self, "unable to encode key: not a symbol", key);
tmp = json_write(ctx, self, key, out);
if (sexp_exceptionp(tmp))
return tmp;
sexp_write_char(ctx, ':', out);
val = sexp_cdr(cur);
tmp = json_write(ctx, self, val, out);
if (sexp_exceptionp(tmp)) {
res = tmp;
break;
}
if (sexp_exceptionp(tmp))
return tmp;
}
sexp_write_char(ctx, '}', out);
sexp_gc_release2(ctx);
return res;
return SEXP_VOID;
}
sexp json_write (sexp ctx, sexp self, const sexp obj, sexp out) {
@ -450,7 +437,8 @@ 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_write(ctx, obj, out);
res = sexp_symbol_to_string(ctx, obj);
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) {

2
lib/chibi/loop.sld
View file

@ -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 in-substrings
summing multiplying in-string in-string-reverse
in-vector in-vector-reverse)
(import (chibi))
(include "loop/loop.scm"))

20
lib/chibi/loop/loop.scm
View file

@ -268,26 +268,6 @@
. 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

13
lib/chibi/match-test.sld
View file

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

97
lib/chibi/match/match.scm
View file

@ -32,11 +32,6 @@
;;> 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.
@ -133,7 +128,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) (_ #f))}
;;> \example{(match 1 ((or) #t) (else #f))}
;;> \example{(match 1 ((or x) x))}
;;> \example{(match 1 ((or x 2) x))}
@ -247,8 +242,6 @@
;; 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
@ -572,47 +565,30 @@
(define-syntax match-gen-ellipsis
(syntax-rules ()
;; TODO: restore fast path when p is not already bound
((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier p
;; simplest case equivalent to (p ...), just match the list
(let ((w v))
(if (list? w)
(match-one w p g+s (sk ...) fk i)
fk))
;; simple case, match all elements of the list
(let loop ((ls v) (id-ls '()) ...)
(cond
((null? ls)
(let ((id (reverse id-ls)) ...) (sk ... i)))
((pair? ls)
(let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk i)))
(else
fk)))))
;; ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
;; (match-check-identifier p
;; ;; simplest case equivalent to (p ...), just bind the list
;; (let ((p v))
;; (if (list? p)
;; (sk ... i)
;; fk))
;; ;; simple case, match all elements of the list
;; (let loop ((ls v) (id-ls '()) ...)
;; (cond
;; ((null? ls)
;; (let ((id (reverse id-ls)) ...) (sk ... i)))
;; ((pair? ls)
;; (let ((w (car ls)))
;; (match-one w p ((car ls) (set-car! ls))
;; (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
;; fk i)))
;; (else
;; 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))))
@ -631,8 +607,7 @@
fk
(i ...))))
(else
fk)))
)))))))
fk)))))))))
;; Variant of the above where the rest pattern is in a quasiquote.
@ -1120,12 +1095,6 @@
(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))))))))
@ -1146,12 +1115,6 @@
(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))))))))
@ -1214,18 +1177,4 @@
((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))))
))

15
lib/chibi/math/prime-test.sld
View file

@ -47,7 +47,6 @@
(test 5 (prime-below 7))
(test 797 (prime-below 808))
(test 1 (totient 1))
(test 1 (totient 2))
(test 2 (totient 3))
(test 2 (totient 4))
@ -57,7 +56,6 @@
(test 4 (totient 8))
(test 6 (totient 9))
(test 4 (totient 10))
(test-error (totient 0))
(test #f (perfect? 1))
(test #f (perfect? 2))
@ -73,7 +71,7 @@
(test #t (perfect? 496))
(test #t (perfect? 8128))
(test '() (factor 1))
(test '(1) (factor 1))
(test '(2) (factor 2))
(test '(3) (factor 3))
(test '(2 2) (factor 4))
@ -88,16 +86,8 @@
(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))
@ -117,7 +107,4 @@
5772301760555853353
(* 2936546443 3213384203)))
(test "Miller-Rabin vs. Carmichael prime"
#t (miller-rabin-composite? 118901521))
(test-end))))

179
lib/chibi/math/prime.scm
View file

@ -4,13 +4,12 @@
;;> Prime and number theoretic utilities.
;; Given \var{n} and a continuation \var{return},
;; returns (\var{return} \var{k2} \var{n2}) where
;; \var{k2} is the power of 2 in the factorization of \var{n}, and
;; \var{n2} is product of all other prime powers dividing \var{n}
(define (factor-twos n return)
(let ((b (first-set-bit n)))
(return b (arithmetic-shift n (- b)))))
;;> Returns a pair whose car is the power of 2 in the factorization of
;;> n, and whose cdr is the product of all remaining primes.
(define (factor-twos n)
(do ((p 0 (+ p 1))
(r n (arithmetic-shift r -1)))
((odd? r) (cons p r))))
;;> Returns the multiplicative inverse of \var{a} modulo \var{b}.
(define (modular-inverse a b)
@ -74,36 +73,22 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Probable primes.
;; Given \var{n}, return a predicate that tests whether
;; its argument \var{a} is a witness for \var{n} not being prime,
;; 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)
(define (modular-root-of-one? twos odd a n neg1)
;; Returns true iff any (modular-expt a odd*2^i n) for i=0..twos-1
;; returns 1 modulo n.
(let ((b (modular-expt a odd n)))
(let lp ((i 0) (b b))
(cond ((= b neg1)
;; found -1 (expected sqrt(1))
#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)))))))))))
(cond ((or (= b 1) (= b neg1))) ; in (= b 1) case we could factor
((>= i twos) #f)
(else (lp (+ i 1) (remainder (* b b) n)))))))
;;> Returns true if we can show \var{n} to be composite
;;> 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))
;;> Returns true if we can show \var{n} to be composite by finding an
;;> exception to the Miller Rabin lemma.
(define (miller-rabin-composite? n)
(let* ((witness? (miller-rabin-witnesser n))
(let* ((neg1 (- n 1))
(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
@ -112,10 +97,11 @@
(rand-limit (if (< n 341550071728321) fixed-limit 20)))
(let try ((i 0))
(and (< i rand-limit)
(or (witness? (if (< i fixed-limit)
(let ((a (if (< i fixed-limit)
(vector-ref prime-table i)
(+ (random-integer (- n 3)) 2)))
(try (+ i 1)))))))
(+ (random-integer (- n 3)) 2))))
(or (not (modular-root-of-one? twos odd a n neg1))
(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)
@ -189,84 +175,57 @@
((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
(let ((rfactor (make-factorizer '()
(lambda (l p k) (cons (make-list k p) l)))))
(lambda (n) (concatenate! (reverse (rfactor n))))))
(define (factor n)
(cond
((negative? n)
(cons -1 (factor (- 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))))))))))
;;> The Euler totient φ(\var{n}) is the number of positive
;;> integers less than or equal to \var{n} that are
;;> relatively prime to \var{n}.
(define totient
(make-factorizer 1
(lambda (tot p k)
(* tot (- p 1) (expt p (- k 1))))
(lambda (tot k)
(arithmetic-shift tot (- k 1)))
(lambda (_)
(error "totient of negative number?"))))
;;> The aliquot sum s(\var{n}) is
;;> 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))))
;;> Returns the Euler totient function, the number of positive
;;> integers less than \var{n} that are relatively prime to \var{n}.
(define (totient n)
(let ((limit (exact (ceiling (sqrt n)))))
(let lp ((i 2) (count 1))
(cond ((> i limit)
(if (= count (- i 1))
(- n 1) ; shortcut for prime
(let lp ((i i) (count count))
(cond ((>= i n) count)
((= 1 (gcd n i)) (lp (+ i 1) (+ count 1)))
(else (lp (+ i 1) count))))))
((= 1 (gcd n i)) (lp (+ i 1) (+ count 1)))
(else (lp (+ i 1) count))))))
;;> 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.

5
lib/chibi/math/prime.sld
View file

@ -1,12 +1,11 @@
(define-library (chibi math prime)
(import (scheme base) (scheme inexact) (chibi optional) (srfi 1) (srfi 27))
(import (scheme base) (scheme inexact) (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 factor-alist perfect?
(export prime? nth-prime prime-above prime-below factor perfect?
totient aliquot
provable-prime? probable-prime?
random-prime random-prime-distinct-from

46
lib/chibi/memoize-test.sld
View file

@ -1,13 +1,6 @@
(define-library (chibi memoize-test)
(export run-tests)
(import (scheme base)
(scheme file)
(chibi filesystem)
(chibi memoize)
(chibi pathname)
(chibi process)
(chibi temp-file)
(chibi test))
(import (scheme base) (scheme file) (chibi memoize) (chibi test))
(begin
(define (run-tests)
(test-begin "memoize")
@ -46,44 +39,13 @@
(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)))))))
(call-with-temp-dir
"memo.d"
(lambda (dir preserve)
(let ((f (memoize-to-file fib 'memo-dir: dir)))
(let ((f (memoize-to-file fib 'memo-dir: "/tmp/memo.d/")))
(test 89 (f 10))
(test 177 calls)
;; (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-assert (file-exists? "/tmp/memo.d/10.memo"))
(test 89 (f 10))))
(test-end))))

22
lib/chibi/mime.scm
View file

@ -24,25 +24,15 @@
;; most of these are plain text for easier viewing in the browser
(define (mime-type-from-extension ext)
(assq-ref
'((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")
'((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")
(svg . "image/svg+xml")
(txt . "text/plain; charset=utf-8"))
(c . "text/plain; charset=utf-8")
(h . "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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

13
lib/chibi/net/http-server.scm
View file

@ -33,7 +33,6 @@
(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
@ -54,9 +53,8 @@
(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)
@ -65,7 +63,7 @@
(let restart ((request request))
(servlet cfg request servlet-bad-request restart)))))))
(else
(let ((request (make-request command "" #f in out sock addr)))
(let ((request (make-request command #f #f in out sock addr)))
(servlet-respond request 400 "bad request")))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -147,7 +145,7 @@
(cond
((mime-type-from-extension (path-extension path))
=> (lambda (type) `((Content-Type . ,type))))
(else '((Content-Type . "application/octet-stream"))))))
(else '()))))
(servlet-respond request 200 "OK" headers)
(send-file path (request-out request))))
(else
@ -525,7 +523,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Sample main. In chibi-scheme you can run:
;;
;; chibi-scheme -Rchibi.net.http-server -- [<cfg-file-or-directory>]
;; chibi-scheme -Rchibi.net.http-config-server -- [<cfg-file-or-directory>]
;;
;; which defaults to serving the current directory on port 8000.
@ -551,8 +549,7 @@
(@
((port integer)
(doc-root string)
(verbose? boolean (#\v "verbose"))
(quiet? boolean (#\q "quiet"))))
(verbose? boolean (#\v "verbose"))))
,run-app))
(define (main args) (run-application app-spec))

3
lib/chibi/net/http-server.sld
View file

@ -8,8 +8,7 @@
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-send-file)
http-cgi-bin-dir-servlet http-scheme-script-dir-servlet)
(import
(scheme time) (srfi 39) (srfi 95)
(chibi) (chibi mime) (chibi regexp) (chibi pathname) (chibi uri)

4
lib/chibi/net/servlet.scm
View file

@ -158,10 +158,6 @@
(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.

3
lib/chibi/numeric-test.sld
View file

@ -311,9 +311,6 @@
(- 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))

43
lib/chibi/optional-test.sld
View file

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

95
lib/chibi/optional.scm
View file

@ -9,11 +9,9 @@
(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 (tmp . d))) rest . body))
((let*-to-let letstar ls (vars ...) (v . rest) . body)
(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*-to-let letstar ls (vars ... (v tmp . d)) rest . body))
((let*-to-let letstar ls ((var tmp . d) ...) rest . body)
(letstar ls ((tmp . d) ... . rest)
(let ((var tmp) ...) . body)))))
;;> \macro{(let-optionals ls ((var default) ... [rest]) body ...)}
@ -30,9 +28,6 @@
;;> 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.
@ -56,8 +51,8 @@
(define-syntax let-optionals
(syntax-rules ()
((let-optionals ls (var&default ... . rest) body ...)
(let*-to-let let-optionals* ls () (var&default ... . rest) body ...))))
((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 ...)}
;;>
@ -76,17 +71,18 @@
(define-syntax opt-lambda
(syntax-rules ()
((opt-lambda vars . body)
(lambda args (let-optionals args vars . body)))))
(opt-lambda/aux () vars . body))))
;;> \macro{(opt-lambda* ((var default) ... [rest]) body ...)}
;;>
;;> Variant of \scheme{opt-lambda} which binds using
;;> \scheme{let-optionals*}.
(define-syntax opt-lambda*
(define-syntax opt-lambda/aux
(syntax-rules ()
((opt-lambda* vars . body)
(lambda args (let-optionals* args vars . body)))))
((opt-lambda/aux (args ...) ((var . default) . vars) . body)
(lambda (args ... . o)
(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 ...)}
;;>
@ -99,24 +95,6 @@
((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
@ -125,8 +103,12 @@
;;> \var{default}, or \scheme{#f}.
(define (keyword-ref ls key . o)
(cond ((mem-key key ls) => (lambda (cell) (cadr cell)))
(else (and (pair? o) (car o)))))
(let lp ((ls ls))
(if (and (pair? ls) (pair? (cdr ls)))
(if (eq? key (car ls))
(cadr ls)
(lp (cddr ls)))
(and (pair? o) (car o)))))
;;> \macro{(keyword-ref* ls key default)}
;;>
@ -136,7 +118,7 @@
(define-syntax keyword-ref*
(syntax-rules ()
((keyword-ref* ls key default)
(cond ((mem-key key ls) => cadr) (else default)))))
(cond ((memq key ls) => cadr) (else default)))))
(define (symbol->keyword sym)
(string->symbol (string-append (symbol->string sym) ":")))
@ -162,21 +144,13 @@
;;> 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 (though no type
;;> checking is performed). Thus when passing keyword arguments they
;;> must be quoted (or otherwise dynamically evaluated).
;;> syntax for keywords - they are simply identifiers. Thus when
;;> passing keyword arguments they must be quoted (or otherwise
;;> dynamically evaluated).
;;>
;;> \emph{Example:}
;;> \example{
@ -197,27 +171,12 @@
;;> ((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)))
@ -226,8 +185,6 @@
(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))
@ -239,7 +196,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.
;;>

13
lib/chibi/optional.sld
View file

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

10
lib/chibi/parse-test.sld
View file

@ -21,7 +21,6 @@
(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"))
@ -54,15 +53,6 @@
(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 ()

27
lib/chibi/parse/parse.scm
View file

@ -167,11 +167,8 @@
;; 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 max-char))
(parse-stream-count-lines s (parse-stream-max-char s)))
(line (+ (parse-stream-line s) (car line-info)))
(col (if (zero? (car line-info))
(+ (parse-stream-column s) (cadr line-info))
@ -179,7 +176,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)))
@ -402,9 +399,7 @@
((null? (cdr o))
(let ((f (car o)))
(lambda (s i sk fk)
(f s i (lambda (r s i fk)
(sk (if (eq? r ignored-value) '() (list r)) s i fk))
fk))))
(f s i (lambda (r s i fk) (sk (list r) s i fk)) fk))))
(else
(let* ((f (car o))
(o (cdr o))
@ -413,10 +408,7 @@
(g (if (pair? o)
(apply parse-seq g o)
(lambda (s i sk fk)
(g s i (lambda (r s i fk)
(sk (if (eq? r ignored-value) '() (list r))
s i fk))
fk)))))
(g s i (lambda (r s i fk) (sk (list r) s i fk)) fk)))))
(lambda (source index sk fk)
(f source
index
@ -523,15 +515,10 @@
;;> 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 . o)
(let ((commit-fk (if (pair? o) (car o) (lambda (s i r) #f))))
(define (parse-commit f)
(lambda (source index sk fk)
(f source index (lambda (res s i fk) (sk res s i commit-fk)) fk))))
(f source index (lambda (res s i fk) (sk res s i (lambda (s i r) #f))) fk)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -671,7 +658,7 @@
(define (parse-string str)
(parse-map (parse-with-failure-reason
(parse-seq-list (map parse-char (string->list str)))
(string-append "expected '" str "'"))
`(expected ,str))
list->string))
;;> Parse a sequence of characters matching \var{x} as with

24
lib/chibi/process.scm
View file

@ -1,29 +1,20 @@
(define unwind #f)
((call/cc
(lambda (k)
(set! unwind k)
(lambda () #f))))
(cond-expand
(plan9
(define (emergency-exit . o)
(define (exit . o)
(%exit (if (pair? o)
(if (string? (car o))
(car o)
(if (eq? #t (car o)) "" "chibi error"))
""))))
(else
(define (emergency-exit . o)
(define (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)
@ -132,11 +123,8 @@
;;> \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. If
;;> 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)
;;> \scheme{system}, or a string which is split on white-space.
(define (call-with-process-io command proc)
(define (set-non-blocking! fd)
(cond-expand
(threads
@ -145,8 +133,7 @@
(bitwise-ior open/non-block (get-file-descriptor-status fd))))
(else
#f)))
(let ((child-proc (and (pair? o) (car o)))
(command-ls (if (string? command) (string-split command) command))
(let ((command-ls (if (string? command) (string-split command) command))
(in-pipe (open-pipe))
(out-pipe (open-pipe))
(err-pipe (open-pipe)))
@ -165,7 +152,6 @@
(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

5
lib/chibi/process.sld
View file

@ -1,7 +1,6 @@
(define-library (chibi process)
(export exit emergency-exit sleep alarm
%fork fork kill execute waitpid system system?
(export 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?
@ -18,7 +17,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) (only (scheme base) call/cc))
(import (chibi) (chibi io) (chibi string) (chibi filesystem))
(cond-expand (threads (import (srfi 18) (srfi 151))) (else #f))
(cond-expand ((not windows) (include-shared "process")))
(include "process.scm"))

29
lib/chibi/regexp-test.sld
View file

@ -151,9 +151,6 @@
(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>")
@ -164,32 +161,6 @@
(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")

128
lib/chibi/regexp.scm
View file

@ -30,9 +30,8 @@
(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 is a guarded epsilon transition which advances
;; only if the procedure returns a true value. The signature
;; is of the form (proc str i ch start end matches).
;; procedure of the form (lambda (ch i matches) ...) is a predicate
;; which should return #t if the char matches.
(chars state-chars state-chars-set!)
;; A single integer indicating the match position to record.
(match state-match state-match-set!)
@ -301,9 +300,11 @@
(if (not (eq? m (searcher-matches sr1)))
(searcher-matches-set! sr1 (copy-regexp-match m)))))
(define (searcher>=? sr1 sr2)
(or (not (searcher? sr2))
(regexp-match>=? (searcher-matches sr1) (searcher-matches sr2))))
(define (searcher-max sr1 sr2)
(if (or (not (searcher? sr2))
(regexp-match>=? (searcher-matches sr1) (searcher-matches sr2)))
sr1
sr2))
(define (searcher-start-match sr)
(regexp-match-ref (searcher-matches sr) 0))
@ -343,26 +344,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)
@ -389,7 +370,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 state sr str i start end)
(define (posse-advance! new seen accept sr str i start end)
(let advance! ((sr sr))
(let ((st (searcher-state sr)))
;; Update match data.
@ -413,10 +394,7 @@
;; Follow transitions.
(cond
((state-accept? st)
(cond
((searcher>=? sr (regexp-state-accept state))
(regexp-state-accept-set! state sr)
(regexp-state-string-set! state str))))
(set-cdr! accept (searcher-max sr (cdr accept))))
((posse-ref seen sr)
=> (lambda (sr-prev) (searcher-merge! sr-prev sr)))
((epsilon-state? st)
@ -428,7 +406,8 @@
(posse-add! seen sr)
(let* ((next1 (state-next1 st))
(next2 (state-next2 st))
(matches (and next2 (searcher-matches sr))))
(matches
(and next2 (searcher-matches sr))))
(cond
(next1
(searcher-state-set! sr next1)
@ -445,27 +424,27 @@
;; Add new searcher.
(posse-add! new sr))))))
;;> 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-advance! search? init? rx str start end . o)
;; Run so long as there is more to match.
(define (regexp-run-offsets search? rx str start end)
(let ((rx (regexp rx))
(state (if (pair? o) (car o) (make-regexp-state)))
(epsilons (posse)))
(epsilons (posse))
(accept (list #f)))
(let lp ((i start)
(searchers1 (posse))
(searchers2 (posse)))
;; Advance initial epsilons once from the first index, or every
;; time when searching.
(cond
((or search? (and init? (string-cursor=? i start)))
(posse-advance! searchers1 epsilons state (make-start-searcher rx str)
((or search? (string-cursor=? i start))
(posse-advance! searchers1 epsilons accept (make-start-searcher rx str)
str i start end)
(posse-clear! epsilons)))
(cond
((or (string-cursor>=? i end)
(and search?
(searcher? (regexp-state-accept state))
(let ((accept-start (searcher-start-match (regexp-state-accept state))))
(searcher? (cdr accept))
(let ((accept-start (searcher-start-match (cdr accept))))
(posse-every
(lambda (searcher)
(string-cursor>? (searcher-start-match searcher)
@ -473,14 +452,16 @@
searchers1)))
(and (not search?)
(posse-empty? searchers1)))
;; Terminate when the string is done or there are no more searchers or
;; we've found an accept state which started before any pending matches.
;; If we terminate prematurely and are not searching, return false.
(regexp-state-searchers-set! state searchers1)
state)
;; Terminate when the string is done or there are no more
;; searchers. If we terminate prematurely and are not
;; searching, return false.
(and (searcher? (cdr accept))
(let ((matches (searcher-matches (cdr accept))))
(and (or search? (string-cursor>=? (regexp-match-ref matches 1)
end))
(searcher-matches (cdr accept))))))
(else
;; Otherwise advance normally from searchers1, storing the new state in
;; searchers2, and recurse swapping the two (to reduce garbage).
;; Otherwise advance normally.
(let ((ch (string-cursor-ref str i))
(i2 (string-cursor-next str i)))
(posse-for-each ;; NOTE: non-deterministic from hash order
@ -490,21 +471,12 @@
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 state sr str i2 start end)
(posse-advance! searchers2 epsilons accept 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)
@ -597,28 +569,6 @@
(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?)
@ -974,24 +924,6 @@
(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)

8
lib/chibi/regexp.sld
View file

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

30
lib/chibi/repl.scm
View file

@ -1,5 +1,5 @@
;; repl.scm - friendlier repl with line editing and signal handling
;; Copyright (c) 2012-2024 Alex Shinn. All rights reserved.
;; Copyright (c) 2012-2013 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,8 +296,6 @@
(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)
@ -402,16 +400,6 @@
((= (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)))
@ -421,7 +409,7 @@
(lambda ()
(protect (exn
(else
(repl-print-exception exn out)
(print-exception exn out)
(repl-advise-exception exn (current-error-port))))
(for-each
(lambda (expr)
@ -432,17 +420,17 @@
(null? expr))
(eval expr (repl-env rp))
expr))
(lambda res-values
(lambda res-list
(cond
((not (or (null? res-values)
(equal? res-values (list undefined-value))))
(push-history-value-maybe! res-values)
(repl-print (car res-values) out)
((not (or (null? res-list)
(equal? res-list (list (if #f #f)))))
(push-history-value-maybe! res-list)
(write/ss (car res-list) out)
(for-each
(lambda (res)
(write-char #\space out)
(repl-print res out))
(cdr res-values))
(write/ss res out))
(cdr res-list))
(newline out))))))
expr-list))))))

5
lib/chibi/repl.sld
View file

@ -1,9 +1,8 @@
(define-library (chibi repl)
(export repl repl-print repl-print-exception
$0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
(export repl $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 generic)
(chibi ast) (chibi modules) (chibi doc)
(chibi string) (chibi io) (chibi optional)
(chibi process) (chibi term edit-line)
(srfi 1)

3
lib/chibi/scribble-test.sld
View file

@ -15,9 +15,6 @@
(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}")

8
lib/chibi/scribble.scm
View file

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

47
lib/chibi/shell-test.sld
View file

@ -1,47 +0,0 @@
(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))))

525
lib/chibi/shell.scm
View file

@ -1,525 +0,0 @@
;;> \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))))

29
lib/chibi/shell.sld
View file

@ -1,29 +0,0 @@
(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"))

9
lib/chibi/show/c.scm
View file

@ -398,11 +398,6 @@
((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)
@ -427,9 +422,7 @@
(in-macro? (pair? x))
(macro-vars
(map (lambda (v) (if (pair? v) (cadr v) v))
(if (pair? x)
(list-without-dot x)
(list x))))
(if (pair? x) x (list x))))
(op 'zero))
(c-in-expr (apply c-begin body)))))
"")))

135
lib/chibi/snow/commands.scm
View file

@ -772,9 +772,7 @@
=> (lambda (y)
`("-F" ,(string-append
(display-to-string (car x)) "="
(write-to-string
(display-to-string (cdr y)))
"\""))))
(display-to-string (cdr y))))))
((and (pair? (cdr x)) (assq 'file (cdr x)))
=> (lambda (y)
`("-F" ,(string-append
@ -783,8 +781,7 @@
(else
`("-F" ,(string-append
(display-to-string (car x)) "="
(write-to-string
(display-to-string (cdr x))))))))
(display-to-string (cdr x)))))))
params)
,(uri->string uri))))
(open-input-bytevector (process->bytevector cmd))))
@ -794,18 +791,10 @@
(http-post uri params))))
(define (remote-command cfg name path params)
(let* ((uri (remote-uri cfg name path))
(response
(port->string (snow-post cfg uri (cons '(fmt . "sexp") params)))))
(guard (exn (else
(display "ERROR: couldn't display sxml response: ")
(write response)
(let ((uri (remote-uri cfg name path)))
(sxml-display-as-text
(read (snow-post cfg uri (cons '(fmt . "sexp") params))))
(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
@ -1015,11 +1004,7 @@
(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)))
(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)))))))
(remove-directory cfg dir)))))))
(define (command/remove cfg spec . args)
(let* ((impls (conf-selected-implementations cfg))
@ -1174,9 +1159,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
@ -1209,17 +1194,10 @@
;; returns the single repo as a sexp, updated as needed
(define (maybe-update-repository cfg repo-uri)
(or (guard (exn
(else
(warn "error updating remote repository: "
repo-uri " error: " exn)
#f))
(or (guard (exn (else #f))
(and (should-update-repository? cfg repo-uri)
(update-repository cfg repo-uri)))
(guard (exn
(else
(warn "error reading local repository: " exn)
'(repository)))
(guard (exn (else '(repository)))
(call-with-input-file (repository-local-path cfg repo-uri)
read))))
@ -1271,8 +1249,7 @@
(lp (cdr ls) seen res)
(let* ((repo (maybe-update-repository cfg uri))
(siblings
(if (and (valid-repository? repo)
(conf-get cfg 'follow-siblings? #t))
(if (and repo (conf-get cfg 'follow-siblings? #t))
(let ((uri-base
(if (string-suffix? "/" uri)
uri
@ -1334,12 +1311,6 @@
'(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))
@ -1412,10 +1383,7 @@
(chibi (eval '(current-module-path) (environment '(chibi))))
(else (process->sexp
'(chibi-scheme -q -p "(current-module-path)"))))))
(lib-dir (find (lambda (d)
(and (equal? (string-ref d 0) #\/)
(string-contains d "/lib")))
dirs)))
(lib-dir (find (lambda (d) (string-contains d "/lib")) dirs)))
(if lib-dir
(cons lib-dir (delete lib-dir dirs))
dirs)))
@ -1595,7 +1563,7 @@
(lambda (file acc)
(cond
((and (equal? "meta" (path-extension file))
(guard (exn (else (warn "read meta failed" exn) #f))
(guard (exn (else #f))
(let ((pkg (call-with-input-file file read)))
(and (package? pkg)
(every file-exists? (package-installed-files pkg))
@ -1620,9 +1588,6 @@
(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
@ -1679,11 +1644,10 @@
(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 snow-module-directory)))
(else (car (get-install-dirs impl cfg)))))
(define (get-install-data-dir impl cfg)
(cond
@ -1692,7 +1656,7 @@
((conf-get cfg 'install-data-dir))
((conf-get cfg 'install-prefix)
=> (lambda (prefix) (make-path prefix "share/snow" impl)))
(else snow-module-directory)))
(else (car (get-install-dirs impl cfg)))))
(define (get-install-library-dir impl cfg)
(cond
@ -1706,11 +1670,9 @@
(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 snow-binary-module-directory)))
(else (car (get-install-library-dirs impl cfg)))))
(define (get-install-binary-dir impl cfg)
(cond
@ -1870,60 +1832,17 @@
(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)
@ -2088,33 +2007,16 @@
" - 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 guile) impl)
((chibi chicken cyclone) impl)
(else 'default)))
(define (build-library impl cfg library dir)
@ -2210,8 +2112,7 @@
(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)
dest))
(install-file cfg (make-path dir src) dest)))
(define (fetch-package cfg url)
(resource->bytevector cfg url))

7
lib/chibi/snow/commands.sld
View file

@ -59,11 +59,4 @@
((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"))

74
lib/chibi/snow/fort.scm
View file

@ -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 . o)
(define (package-dir email pkg)
(make-path
(email->path email)
(string-join (map escape-path (map x->string (package-name pkg))) "/")
(escape-path (if (pair? o) (car o) (package-version pkg)))))
(escape-path (package-version pkg))))
;; Simplistic pretty printing for package/repository/config declarations.
(define (write-simple-pretty pkg out)
@ -257,76 +257,6 @@
(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

4
lib/chibi/snow/fort.sld
View file

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

4
lib/chibi/snow/utils.scm
View file

@ -29,10 +29,6 @@
,(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

10
lib/chibi/sxml-test.sld
View file

@ -1,10 +0,0 @@
(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))))

52
lib/chibi/sxml.scm
View file

@ -40,11 +40,11 @@
(lambda (out) (html-display-escaped-attr (display-to-string str) out))))
(define (html-attr->string attr)
(if (null? (cdr attr))
(symbol->string (car attr))
(if (cdr 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,27 +80,13 @@
(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 . args)
(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"))
(define (sxml-display-as-html sxml . o)
(let ((out (if (pair? o) (car o) (current-output-port))))
(let lp ((sxml (if (and (pair? sxml) (eq? '*TOP* (car sxml)))
(cdr sxml)
sxml))
(depth 0))
sxml)))
(cond
((pair? sxml)
(let ((tag (car sxml))
@ -120,23 +106,17 @@
((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 (lambda (x) (lp x (+ 1 depth))) (cdr rest))
(for-each lp (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 (lambda (x) (lp x (+ 1 depth))) rest)
(for-each lp rest)
(unless (and (null? rest) (memq tag void-elements))
(display "</" out) (display tag out) (display ">" out)))))
(else
(for-each (lambda (x) (lp x (+ 1 depth))) sxml)))))
(for-each lp sxml)))))
((null? sxml))
(else (html-display-escaped-string sxml out))))))
@ -167,7 +147,7 @@
sxml)))
(let lp ((sxml sxml))
(cond
((proper-list? sxml)
((pair? sxml)
(let ((tag (car sxml)))
(cond
;; skip headers and the menu
@ -176,18 +156,16 @@
(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))
(let ((ls (if (and (pair? (cdr sxml))
(pair? (cadr sxml))
(eq? '@ (car (cadr sxml))))
(for-each
lp
(if (and (pair? (cdr sxml)) (eq? '@ (cadr sxml)))
(cddr sxml)
(cdr sxml))))
(for-each lp ls))
(cdr sxml)))
(if (memq tag '(p li br h1 h2 h3 h4 h5 h6))
(newline out)))
(else

2
lib/chibi/sxml.sld
View file

@ -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 list) (scheme write))
(import (scheme base) (scheme write))
(include "sxml.scm"))

Some files were not shown because too many files have changed in this diff Show more