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.7
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.7" have entirely different histories.
master ... 0.7

721 changed files with 12201 additions and 77955 deletions
Show stats Expand all files Collapse all files

30
.githooks/pre-commit
View file

@ -1,30 +0,0 @@
#!/bin/bash
if git rev-parse --verify HEAD >/dev/null 2>&1; then
against=HEAD
else
# Initial commit: diff against an empty tree object
against=4b825dc642cb6eb9a060e54bf8d69288fbee4904
fi
# fail if we add any new lines to C or Scheme source containing a tab
if git diff --name-only "$against" | egrep -q '\.(cpp|h|scm|sld|stub)$' &&\
git diff --name-only "$against" |\
egrep '\.(cpp|h|scm|sld|stub)$' |\
xargs -d'\n' git diff -U0 --no-color "$against" -- |\
grep -q $'^+ *\t'; then
echo "Error: Attempting to add a source file using tabs for indentation."
echo
echo -n " "
git diff --name-only "$against" |\
egrep '\.(cpp|h|scm|sld|stub)$' |\
xargs -d'\n' git diff -U0 "$against" -- |\
grep $'^+ *\t' | head -1
echo
cat <<EOF
It's important for arguments to line up vertically to a precise column.
Since there is no standard tab width, using tabs for indentation makes
this impossible in general. Please use spaces.
EOF
exit 1
fi

23
.github/workflows/CI.yaml vendored
View file

@ -1,23 +0,0 @@
name: CI
on: [push, pull_request]
jobs:
build:
name: ${{ matrix.os }}
runs-on: ${{ matrix.os }}
strategy:
matrix:
os: [ubuntu-latest, macos-latest]
steps:
- uses: actions/checkout@v2
- name: Build
run: make # assumes GNUMake
- name: Test
run: make test-all
- name: Setup
run: sudo make install
- name: Run in PATH
run: chibi-scheme r7rs-tests.scm
working-directory: tests

86
.gitignore vendored
View file

@ -1,86 +0,0 @@
# Object files
*.o
*.bc
*.ko
*.obj
*.elf
# Precompiled Headers
*.gch
*.pch
# Libraries
*.lib
*.a
*.la
*.lo
# Shared objects (inc. Windows DLLs)
*.dll
*.dll.*
*.so
*.so.*
*.dylib
# Executables
*.exe
*.out
*.app
*.i*86
*.x86_64
*.hex
# Debug files
*.dSYM/
# Snow Meta files
lib/.*.meta
# Generated files
chibi-scheme
chibi-scheme-emscripten
chibi-scheme.pc
include/chibi/install.h
lib/chibi/emscripten.c
lib/chibi/filesystem.c
lib/chibi/io/io.c
lib/chibi/net.c
lib/chibi/process.c
lib/chibi/pty.c
lib/chibi/snow/install.sld
lib/chibi/stty.c
lib/chibi/system.c
lib/chibi/time.c
lib/chibi/win32/process-win32.c
lib/scheme/bytevector.c
lib/srfi/144/math.c
lib/srfi/160/uvprims.c
*.tgz
*.bz2
*.xz
*.html
*.img
*.err
*.fasl
*.txt
!CMakeLists.txt
*.test
*.train
*.h5
!index.html
benchmarks/gabriel/times.tsv
examples/snow-fort
examples/synthcode
tests/snow/repo-cache
tests/snow/repo*/repo.scm
tests/snow/tmp-root
tmp
/lib/chibi/crypto/crypto.c
/chibi-scheme-ulimit
/clibs.c
js/chibi.*
build-lib/chibi/char-set/derived.scm
build-lib/chibi/char-set/width.scm

1
.hgignore
View file

@ -37,7 +37,6 @@ lib/chibi/process.c
lib/chibi/system.c
lib/chibi/time.c
lib/chibi/stty.c
lib/chibi/emscripten.c
doc/*.html
doc/lib/chibi/*.html
misc/*

4
.travis.yml
View file

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

42
AUTHORS
View file

@ -1,11 +1,6 @@
Alex Shinn wrote the initial version of chibi-scheme and all
distributed modules.
The Emscripten build, syntax-case and SRFI 139 implementation, and
various other patches were contributed by Marc Nieper-Wißkirchen.
The image handling code in gc_heap.c was written by Chris Walsh.
The `dynamic-wind' implementation is adapted from the implementation
in the appendix to the Scheme48 reference manual, reportedly first
written by Chris Hanson and John Lamping.
@ -14,17 +9,6 @@ The (scheme time) module includes code for handling leap seconds
from Alan Watson's Scheme clock library at
http://code.google.com/p/scheme-clock/ under the same license.
The lgamma_r implementation for Windows builds is based on code by
Haruhiko Okumura via Ruby.
The following distributed SRFIs use the reference implementations:
(srfi 101) is adapted from David van Horn's implementation
(srfi 134) is Shiro Kawai's implementation
(srfi 135) is Will Clinger's implementation
(srfi 139), (srfi 146), (srfi 154), (srfi 165) are Marc Nieper-Wißkirchen's implementations
(srfi 146 hash) is Arthur Gleckler's Hash Array Mapped Trie implementation
The benchmarks are based on the Racket versions of the classic
Gabriel benchmarks from
http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html.
@ -32,58 +16,34 @@ 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
* Zhang Meng
If you would prefer not to be listed, or are one of the users listed
without a full name, please contact me. If you've made a contribution

603
CMakeLists.txt
View file

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

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-2012 Alex Shinn
All rights reserved.
Redistribution and use in source and binary forms, with or without

449
Makefile
View file

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

132
Makefile.detect
View file

@ -9,7 +9,6 @@ PLATFORM=macosx
else
ifeq ($(shell uname),FreeBSD)
PLATFORM=bsd
LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
else
ifeq ($(shell uname),NetBSD)
PLATFORM=bsd
@ -21,7 +20,7 @@ ifeq ($(shell uname),DragonFly)
PLATFORM=bsd
else
ifeq ($(shell uname -o),Msys)
PLATFORM=windows
PLATFORM=mingw
SOLIBDIR = $(BINDIR)
DIFFOPTS = -b
else
@ -30,15 +29,9 @@ PLATFORM=cygwin
SOLIBDIR = $(BINDIR)
DIFFOPTS = -b
else
ifeq ($(shell uname -o),Android)
PLATFORM=android
else
ifeq ($(shell uname -o),GNU/Linux)
PLATFORM=linux
else
ifeq ($(shell uname),SunOS)
PLATFORM=solaris
else
PLATFORM=unix
endif
endif
@ -48,31 +41,19 @@ endif
endif
endif
endif
endif
endif
endif
ifndef ARCH
ARCH = $(shell uname -m)
endif
########################################################################
# Set default variables for the platform.
LIBDL = -ldl
SO_VERSIONED_SUFFIX = $(SO).$(SOVERSION)
SO_MAJOR_VERSIONED_SUFFIX = $(SO).$(SOVERSION_MAJOR)
STATIC_LDFLAGS = -lm -ldl -lutil
ifeq ($(PLATFORM),macosx)
SO = .dylib
SO_VERSIONED_SUFFIX = .$(SOVERSION)$(SO)
SO_MAJOR_VERSIONED_SUFFIX = .$(SOVERSION_MAJOR)$(SO)
EXE =
CLIBFLAGS =
CLINKFLAGS = -dynamiclib
STATICFLAGS = -DSEXP_USE_DL=0 # -static-libgcc
LIBCHIBI_FLAGS = -install_name $(DESTDIR)$(SOLIBDIR)/libchibi-scheme.$(SOVERSION).dylib
STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0
LIBCHIBI_FLAGS = -install_name $(DESTDIR)$(SOLIBDIR)/libchibi-scheme.dylib.$(SOVERSION)
else
ifeq ($(PLATFORM),bsd)
SO = .so
@ -80,37 +61,17 @@ EXE =
CLIBFLAGS = -fPIC
CLINKFLAGS = -shared
LIBDL =
RLDFLAGS=-Wl,-R$(LIBDIR)
else
ifeq ($(PLATFORM),solaris)
SO = .so
EXE =
CLIBFLAGS = -fPIC
CLINKFLAGS = -shared
LIBDL = -ldl
RLDFLAGS=-Wl,-R$(LIBDIR)
else
ifeq ($(PLATFORM),windows)
SO = .dll
EXE = .exe
CC ?= gcc
CLIBFLAGS =
CLINKFLAGS = -shared
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DSEXP_USE_GREEN_THREADS=0 -DSEXP_USE_GC_FILE_DESCRIPTORS=0 -DBUILDING_DLL
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
STATICFLAGS =
STATIC_LDFLAGS = -lm -ldl
LIBDL = -lws2_32
else
ifeq ($(PLATFORM),msys)
ifeq ($(PLATFORM),mingw)
SO = .dll
EXE = .exe
CC = gcc
CLIBFLAGS =
CLINKFLAGS = -shared
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
STATIC_LDFLAGS = -lm -ldl
STATICFLAGS = -DSEXP_USE_DL=0
LIBDL =
else
ifeq ($(PLATFORM),cygwin)
SO = .dll
@ -120,7 +81,6 @@ CLIBFLAGS =
CLINKFLAGS = -shared
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
STATIC_LDFLAGS = -lm -ldl
else
SO = .so
EXE =
@ -128,6 +88,9 @@ CLIBFLAGS = -fPIC
CLINKFLAGS = -shared
STATICFLAGS = -static -DSEXP_USE_DL=0
LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
ifeq ($(PLATFORM),BSD)
LIBDL=
RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
endif
endif
endif
@ -135,83 +98,18 @@ endif
endif
endif
ifeq ($(PLATFORM),emscripten)
STATIC_LDFLAGS = -lm -ldl
endif
ifeq ($(PLATFORM),unix)
#RLDFLAGS=-rpath $(LIBDIR)
RLDFLAGS=-Wl,-R$(LIBDIR)
RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
endif
########################################################################
# Library config.
#
# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to
# automatically include the necessary compiler and linker flags in
# addition to setting those features. If not using GNU make just
# comment out the ifs and use the else branches for the defaults.
# Check for NTP (who needs autoconf?)
ifeq ($(SEXP_USE_BOEHM),1)
GCLDFLAGS := -lgc
XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
else
GCLDFLAGS :=
XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
endif
ifeq ($(SEXP_USE_DL),0)
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
XCFLAGS := -Wall -DSEXP_USE_DL=0 -g -g3 -O3 $(CFLAGS)
else
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
XCFLAGS := -Wall -g -g3 -O3 $(CFLAGS)
endif
ifeq ($(PLATFORM),solaris)
XLDFLAGS += -lsocket
XCPPFLAGS += -D_POSIX_PTHREAD_SEMANTICS
endif
# Choose compiled library on MSYS
ifeq ($(OS), Windows_NT)
ifeq ($(PLATFORM),msys)
EXCLUDE_WIN32_LIBS=1
else
ifeq ($(shell uname -o),Cygwin)
EXCLUDE_WIN32_LIBS=1
else
EXCLUDE_POSIX_LIBS=1
endif
endif
endif
CHIBI_POSIX_COMPILED_LIBS = lib/chibi/process$(SO) lib/chibi/time$(SO) \
lib/chibi/system$(SO) lib/chibi/stty$(SO) lib/chibi/pty$(SO) \
lib/chibi/net$(SO) lib/srfi/18/threads$(SO)
CHIBI_WIN32_COMPILED_LIBS = lib/chibi/win32/process-win32$(SO)
ifndef EXCLUDE_POSIX_LIBS
CHIBI_COMPILED_LIBS += $(CHIBI_POSIX_COMPILED_LIBS)
else
CHIBI_COMPILED_LIBS += $(CHIBI_WIN32_COMPILED_LIBS)
endif
########################################################################
# Check for headers (who needs autoconf?)
ifndef SEXP_USE_NTP_GETTIME
SEXP_USE_NTP_GETTIME := $(shell echo "int main(){struct ntptimeval n; ntp_gettime(&n);}" | $(CC) -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
ifndef $(SEXP_USE_NTP_GETTIME)
SEXP_USE_NTP_GETTIME := $(shell echo "main(){struct ntptimeval n; ntp_gettime(&n);}" | gcc -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
endif
ifeq ($(SEXP_USE_NTP_GETTIME),1)
XCPPFLAGS += -DSEXP_USE_NTPGETTIME
endif
ifndef SEXP_USE_INTTYPES
SEXP_USE_INTTYPES := $(shell echo "int main(){int_least8_t x;}" | $(CC) -fsyntax-only -include inttypes.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
endif
ifeq ($(SEXP_USE_INTTYPES),1)
XCPPFLAGS += -DSEXP_USE_INTTYPES
CPPFLAGS += -DSEXP_USE_NTPGETTIME
endif

49
Makefile.libs
View file

@ -14,49 +14,25 @@ CD ?= cd
RM ?= rm -f
LS ?= ls
CP ?= cp
LN ?= ln -sf
LN ?= ln
INSTALL ?= install
INSTALL_EXE ?= $(INSTALL)
MKDIR ?= $(INSTALL) -d
RMDIR ?= rmdir
TAR ?= tar
DIFF ?= diff
GIT ?= git
GREP ?= grep
FIND ?= find
SYMLINK ?= ln -s
LDCONFIG ?= ldconfig
# gnu coding standards
prefix ?= /usr/local
PREFIX ?= $(prefix)
exec_prefix ?= $(PREFIX)
bindir ?= $(exec_prefix)/bin
libdir ?= $(exec_prefix)/lib
includedir ?= $(PREFIX)/include
datarootdir ?= $(PREFIX)/share
datadir ?= $(datarootdir)
mandir ?= $(datarootdir)/man
man1dir ?= $(mandir)/man1
PREFIX ?= /usr/local
BINDIR ?= $(PREFIX)/bin
LIBDIR ?= $(PREFIX)/lib
SOLIBDIR ?= $(PREFIX)/lib
INCDIR ?= $(PREFIX)/include/chibi
MODDIR ?= $(PREFIX)/share/chibi
BINMODDIR ?= $(PREFIX)/lib/chibi
MANDIR ?= $(PREFIX)/share/man/man1
# hysterical raisins
BINDIR ?= $(bindir)
LIBDIR ?= $(libdir)
SOLIBDIR ?= $(libdir)
INCDIR ?= $(includedir)/chibi
MODDIR ?= $(datadir)/chibi
BINMODDIR ?= $(SOLIBDIR)/chibi
PKGCONFDIR ?= $(SOLIBDIR)/pkgconfig
MANDIR ?= $(man1dir)
# allow snow to be configured separately
SNOWPREFIX ?= /usr/local
SNOWLIBDIR ?= $(SNOWPREFIX)/lib
SNOWSOLIBDIR ?= $(SNOWLIBDIR)
SNOWMODDIR ?= $(SNOWPREFIX)/share/snow
SNOWBINMODDIR ?= $(SNOWSOLIBDIR)/snow
# for packaging tools
DESTDIR ?=
########################################################################
@ -67,16 +43,13 @@ 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) $<
lib/chibi/pty$(SO): lib/chibi/pty.c $(INCLUDES) libchibi-scheme$(SO)
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) $(XLIBS) -lchibi-scheme -lutil
lib/%$(SO): lib/%.c $(INCLUDES) libchibi-scheme$(SO)
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) $(XLIBS) -lchibi-scheme
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme
doc-libs: $(HTML_LIBS)

39
README Normal file
View file

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

81
README-win32.md
View file

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

60
README.md
View file

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

2
RELEASE
View file

@ -1 +1 @@
sodium
nitrogen

32
TODO
View file

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

2
VERSION
View file

@ -1 +1 @@
0.11.0
0.7

53
appveyor.yml
View file

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

38
benchmarks/gabriel/chibi-prelude.scm
View file

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

34
benchmarks/gabriel/difftimes.sh
View file

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

1
benchmarks/gabriel/input.txt
View file

@ -1 +0,0 @@
1

201
benchmarks/gabriel/ray.scm
View file

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

30
benchmarks/gabriel/run.sh
View file

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

506
bignum.c
View file

@ -1,5 +1,5 @@
/* bignum.c -- bignum support */
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
/* Copyright (c) 2009-2013 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "chibi/sexp.h"
@ -19,107 +19,50 @@ static int hex_digit (int n) {
sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) {
sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t);
sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM);
if (!sexp_exceptionp(res)) {
sexp_bignum_length(res) = len;
sexp_bignum_sign(res) = 1;
}
return res;
}
sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) {
sexp res = sexp_make_bignum(ctx, 1);
if (!sexp_exceptionp(res)) {
sexp_bignum_data(res)[0] = sexp_unbox_fx_abs(a);
sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a));
sexp_bignum_sign(res) = sexp_fx_sign(a);
}
return res;
}
sexp sexp_make_integer_from_lsint (sexp ctx, sexp_lsint_t x) {
sexp res;
if (lsint_is_fixnum(x)) {
res = sexp_make_fixnum(lsint_to_sint(x));
} else if (sexp_lsint_fits_sint(x)) {
res = sexp_make_bignum(ctx, 1);
if (lsint_lt_0(x)) {
sexp_bignum_sign(res) = -1;
sexp_bignum_data(res)[0] = (sexp_uint_t)-lsint_to_sint(x);
} else {
sexp_bignum_sign(res) = 1;
sexp_bignum_data(res)[0] = (sexp_uint_t)lsint_to_sint(x);
}
} else {
res = sexp_make_bignum(ctx, 2);
if (lsint_lt_0(x)) {
sexp_bignum_sign(res) = -1;
sexp_bignum_data(res)[0] = (sexp_uint_t)-lsint_to_sint(x);
sexp_bignum_data(res)[1] = (sexp_uint_t)~lsint_to_sint_hi(x);
} else {
sexp_bignum_sign(res) = 1;
sexp_bignum_data(res)[0] = (sexp_uint_t)lsint_to_sint(x);
sexp_bignum_data(res)[1] = (sexp_uint_t)lsint_to_sint_hi(x);
}
}
return res;
}
sexp sexp_make_unsigned_integer_from_luint (sexp ctx, sexp_luint_t x) {
sexp res;
if (luint_is_fixnum(x)) {
res = sexp_make_fixnum(luint_to_uint(x));
} else if (sexp_luint_fits_uint(x)) {
res = sexp_make_bignum(ctx, 1);
sexp_bignum_sign(res) = 1;
sexp_bignum_data(res)[0] = luint_to_uint(x);
} else {
res = sexp_make_bignum(ctx, 2);
sexp_bignum_sign(res) = 1;
sexp_bignum_data(res)[0] = luint_to_uint(x);
sexp_bignum_data(res)[1] = luint_to_uint_hi(x);
}
return res;
}
#if SEXP_USE_CUSTOM_LONG_LONGS
sexp sexp_make_integer(sexp ctx, long long x) {
return sexp_make_integer_from_lsint(ctx, lsint_from_sint(x));
}
sexp sexp_make_unsigned_integer(sexp ctx, unsigned long long x) {
return sexp_make_unsigned_integer_from_luint(ctx, luint_from_uint(x));
}
#else
sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) {
return sexp_make_integer_from_lsint(ctx, x);
sexp res;
if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) {
res = sexp_make_fixnum(x);
} else {
res = sexp_make_bignum(ctx, 1);
if (x < 0) {
sexp_bignum_sign(res) = -1;
sexp_bignum_data(res)[0] = -x;
} else {
sexp_bignum_sign(res) = 1;
sexp_bignum_data(res)[0] = x;
}
}
return res;
}
sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
return sexp_make_unsigned_integer_from_luint(ctx, x);
sexp res;
if (x <= SEXP_MAX_FIXNUM) {
res = sexp_make_fixnum(x);
} else {
res = sexp_make_bignum(ctx, 1);
sexp_bignum_sign(res) = 1;
sexp_bignum_data(res)[0] = x;
}
#endif
#if !SEXP_64_BIT
long long sexp_bignum_to_sint(sexp x) {
if (!sexp_bignump(x))
return 0;
if (sexp_bignum_length(x) > 1)
return sexp_bignum_sign(x) * (
(((long long)(sexp_bignum_data(x)[1]))<<(8*sizeof(sexp_bignum_data(x)[0]))) + sexp_bignum_data(x)[0]);
return sexp_bignum_sign(x) * sexp_bignum_data(x)[0];
return res;
}
unsigned long long sexp_bignum_to_uint(sexp x) {
if (!sexp_bignump(x))
return 0;
if (sexp_bignum_length(x) > 1)
return (((unsigned long long)(sexp_bignum_data(x)[1]))<<(8*sizeof(sexp_bignum_data(x)[0]))) + sexp_bignum_data(x)[0];
return sexp_bignum_data(x)[0];
}
#endif
#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0)
#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f))
#define double_16s_digit(f) fmod(f,16.0)
sexp sexp_double_to_bignum (sexp ctx, double f) {
int sign;
sexp_gc_var3(res, scale, tmp);
@ -127,10 +70,10 @@ sexp sexp_double_to_bignum (sexp ctx, double f) {
res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
sign = (f < 0 ? -1 : 1);
for (f=fabs(f); f >= 1.0; f=trunc(f/16)) {
tmp = sexp_bignum_fxmul(ctx, NULL, scale, (sexp_uint_t)double_16s_digit(f), 0);
for (f=fabs(f); f >= 1.0; f=trunc(f/10)) {
tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0);
res = sexp_bignum_add(ctx, res, res, tmp);
scale = sexp_bignum_fxmul(ctx, NULL, scale, 16, 0);
scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0);
}
sexp_bignum_sign(res) = sign;
sexp_gc_release3(ctx);
@ -188,8 +131,7 @@ sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) {
sexp_sint_t sexp_bignum_compare (sexp a, sexp b) {
if (sexp_bignum_sign(a) != sexp_bignum_sign(b))
return sexp_bignum_sign(a);
sexp_sint_t cmp = sexp_bignum_compare_abs(a, b);
return sexp_bignum_sign(a) < 0 ? -cmp : cmp;
return sexp_bignum_compare_abs(a, b);
}
sexp sexp_bignum_normalize (sexp a) {
@ -252,9 +194,9 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
tmp = d;
data = sexp_bignum_data(d);
for (i=0; i<len; i++) {
n = luint_add(luint_mul_uint(luint_from_uint(adata[i]), b), luint_from_uint(carry));
data[i+offset] = luint_to_uint(n);
carry = luint_to_uint(luint_shr(n, (sizeof(sexp_uint_t)*8)));
n = (sexp_luint_t)adata[i]*b + carry;
data[i+offset] = (sexp_uint_t)n;
carry = n >> (sizeof(sexp_uint_t)*8);
}
if (carry) {
if (sexp_bignum_length(d) <= len+offset)
@ -268,13 +210,13 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0;
int i;
sexp_luint_t n = luint_from_uint(0);
sexp_luint_t n = 0;
for (i=len-1; i>=offset; i--) {
n = luint_add(luint_shl(n, sizeof(sexp_uint_t)*8), luint_from_uint(data[i]));
q = luint_to_uint(luint_div_uint(n, b));
r = luint_to_uint(luint_sub(n, luint_mul_uint(luint_from_uint(q), b)));
n = (n << sizeof(sexp_uint_t)*8) + data[i];
q = n / b;
r = n - (sexp_luint_t)q * b;
data[i] = q;
n = luint_from_uint(r);
n = r;
}
return r;
}
@ -282,35 +224,32 @@ sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) {
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, b0;
int i;
sexp_luint_t n = luint_from_uint(0);
sexp_luint_t n = 0;
if (b > 0) {
q = b - 1;
if ((b & q) == 0)
return sexp_make_fixnum(sexp_bignum_sign(a) * (data[0] & q));
}
b0 = (b >= 0) ? b : -b;
if (b0 == 0) {
return sexp_xtype_exception(ctx, NULL, "divide by zero", a);
}
for (i=len-1; i>=0; i--) {
n = luint_add(luint_shl(n, sizeof(sexp_uint_t)*8), luint_from_uint(data[i]));
q = luint_to_uint(luint_div_uint(n, b0));
n = luint_sub(n, luint_mul_uint(luint_from_uint(q), b0));
n = (n << sizeof(sexp_uint_t)*8) + data[i];
q = n / b0;
n -= (sexp_luint_t)q * b0;
}
return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)luint_to_uint(n));
return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)n);
}
sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
signed char sign, sexp_uint_t base) {
int c, digit;
sexp_gc_var3(res, tmp, imag);
sexp_gc_preserve3(ctx, res, tmp, imag);
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE);
sexp_bignum_sign(res) = sign;
sexp_bignum_data(res)[0] = init;
for (c=sexp_read_char(ctx, in); sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
digit = digit_value(c);
if ((digit < 0) || (digit >= (int)base))
if ((digit < 0) || (digit >= base))
break;
res = sexp_bignum_fxmul(ctx, res, res, base, 0);
res = sexp_bignum_fxadd(ctx, res, digit);
@ -318,38 +257,15 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
if (c=='.' || c=='e' || c=='E') {
if (base != 10) {
res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
} else if (c=='.') {
} else {
if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */
res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1));
} else {
tmp = sexp_read_number(ctx, in, base, 0);
#if SEXP_USE_COMPLEX
if (sexp_complexp(tmp)) {
imag = sexp_complex_imag(tmp);
tmp = sexp_complex_real(tmp);
} else {
imag = SEXP_ZERO;
}
#endif
if (sexp_exceptionp(tmp)) {
res = tmp;
} else if (sexp_fixnump(tmp) && labs(sexp_unbox_fixnum(tmp)) < 100*1024*1024) {
tmp = sexp_expt(ctx, SEXP_TEN, tmp);
res = sexp_mul(ctx, res, tmp);
} else {
tmp = sexp_exact_to_inexact(ctx, NULL, 2, tmp);
tmp = sexp_expt(ctx, SEXP_TEN, tmp);
res = sexp_mul(ctx, res, tmp);
}
#if SEXP_USE_COMPLEX
if (imag != SEXP_ZERO && !sexp_exceptionp(res))
res = sexp_make_complex(ctx, res, imag);
#endif
}
#if SEXP_USE_RATIOS
} else if (c=='/') {
res = sexp_bignum_normalize(res);
res = sexp_make_ratio(ctx, res, SEXP_ONE);
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10, 0);
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10);
res = sexp_ratio_normalize(ctx, res, in);
#endif
#if SEXP_USE_COMPLEX
@ -364,7 +280,7 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
} else {
sexp_push_char(ctx, c, in);
}
sexp_gc_release3(ctx);
sexp_gc_release1(ctx);
return sexp_bignum_normalize(res);
}
@ -383,9 +299,6 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) {
sexp_gc_preserve2(ctx, b, str);
b = sexp_copy_bignum(ctx, NULL, a, 0);
sexp_bignum_sign(b) = 1;
if (lg_base < 1) {
return sexp_xtype_exception(ctx, NULL, "number base too small", a);
}
i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1)
/ lg_base + 1;
str = sexp_make_string(ctx, sexp_make_fixnum(str_len),
@ -409,9 +322,9 @@ sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) {
sexp_gc_preserve1(ctx, c);
c = sexp_copy_bignum(ctx, NULL, a, 0);
if (sexp_bignum_sign(c) == sexp_fx_sign(b))
c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fx_abs(b));
c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
else
c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fx_abs(b));
c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
sexp_gc_release1(ctx);
return c;
}
@ -450,7 +363,7 @@ sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) {
sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
carry=0, i, old_a, p_sum, *adata, *bdata, *cdata;
carry=0, i, n, *adata, *bdata, *cdata;
sexp_gc_var1(c);
if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a);
sexp_gc_preserve1(ctx, c);
@ -460,11 +373,9 @@ sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
bdata = sexp_bignum_data(b);
cdata = sexp_bignum_data(c);
for (i=0; i<blen; i++) {
old_a = adata[i]; /* adata may alias cdata */
p_sum = adata[i] + bdata[i];
cdata[i] = p_sum + carry;
carry = (old_a > (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0)
+ (p_sum > (SEXP_UINT_T_MAX - carry) ? 1 : 0);
n = adata[i];
cdata[i] = n + bdata[i] + carry;
carry = (n > (SEXP_UINT_T_MAX - bdata[i] - carry) ? 1 : 0);
}
for ( ; carry && (i<alen); i++) {
carry = (cdata[i] == SEXP_UINT_T_MAX ? 1 : 0);
@ -595,44 +506,44 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
sexp_bignum_sign(b1) = 1;
q = SEXP_ZERO;
x = sexp_make_bignum(ctx, sexp_bignum_length(a));
while (sexp_bignum_compare_abs(a1, b1) >= 0) { /* a1, b1 at least 2 bigits */
while (sexp_bignum_compare_abs(a1, b1) > 0) { /* a1, b1 at least 2 bigits */
/* guess divisor x */
alen = sexp_bignum_hi(a1);
sexp_bignum_data(x)[off] = 0;
if (off > 0) sexp_bignum_data(x)[off-1] = 0;
off = alen - blen + 1;
dn = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(a1)[alen-1])
, (sizeof(sexp_uint_t)*8))
, sexp_bignum_data(a1)[alen-2]);
dd = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(b1)[blen-1])
, (sizeof(sexp_uint_t)*8))
, sexp_bignum_data(b1)[blen-2]);
dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
<< (sizeof(sexp_uint_t)*8))
+ sexp_bignum_data(a1)[alen-2]);
dd = (((sexp_luint_t)sexp_bignum_data(b1)[blen-1]
<< (sizeof(sexp_uint_t)*8))
+ sexp_bignum_data(b1)[blen-2]);
if (alen > 2 && blen > 2 &&
luint_lt(luint_from_uint(sexp_bignum_data(a1)[alen-1]), luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4))) &&
luint_lt(luint_from_uint(sexp_bignum_data(b1)[blen-1]), luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4)))) {
dn = luint_add_uint(luint_shl(dn, (sizeof(sexp_uint_t)*4))
, (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4)));
dd = luint_add_uint(luint_shl(dd, (sizeof(sexp_uint_t)*4))
, (sexp_bignum_data(b1)[blen-3] >> (sizeof(sexp_uint_t)*4)));
sexp_bignum_data(a1)[alen-1] < (1uL<<(sizeof(sexp_uint_t)*4)) &&
sexp_bignum_data(b1)[blen-1] < (1uL<<(sizeof(sexp_uint_t)*4))) {
dn = (dn << (sizeof(sexp_uint_t)*4))
+ (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4));
dd = (dd << (sizeof(sexp_uint_t)*4))
+ (sexp_bignum_data(b1)[blen-3] >> (sizeof(sexp_uint_t)*4));
}
d = luint_div(dn, dd);
if (luint_eq(d, luint_from_uint(0))) {
dn = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(a1)[alen-1])
, (sizeof(sexp_uint_t)*8))
, sexp_bignum_data(a1)[alen-2]);
dd = luint_from_uint(sexp_bignum_data(b1)[blen-1]);
if (luint_lt(luint_from_uint(sexp_bignum_data(a1)[alen-1]), (luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4)))) &&
luint_lt(luint_from_uint(sexp_bignum_data(b1)[blen-1]), (luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4))))) {
dn = luint_add_uint(luint_shl(dn, (sizeof(sexp_uint_t)*4))
, (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4)));
dd = luint_add_uint(luint_shl(dd, (sizeof(sexp_uint_t)*4))
, (sexp_bignum_data(b1)[blen-2] >> (sizeof(sexp_uint_t)*4)));
d = dn / dd;
if (d == 0) {
dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
<< (sizeof(sexp_uint_t)*8))
+ sexp_bignum_data(a1)[alen-2]);
dd = sexp_bignum_data(b1)[blen-1];
if (sexp_bignum_data(a1)[alen-1] < (1uL<<(sizeof(sexp_uint_t)*4)) &&
sexp_bignum_data(b1)[blen-1] < (1uL<<(sizeof(sexp_uint_t)*4))) {
dn = (dn << (sizeof(sexp_uint_t)*4))
+ (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4));
dd = (dd << (sizeof(sexp_uint_t)*4))
+ (sexp_bignum_data(b1)[blen-2] >> (sizeof(sexp_uint_t)*4));
}
d = luint_div(dn, dd);
d = dn / dd;
off--;
}
dhi = luint_to_uint(luint_shr(d, (sizeof(sexp_uint_t)*8)));
dlo = luint_to_uint(luint_and(d, luint_sub(luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*8)), luint_from_uint(1))));
dhi = d >> (sizeof(sexp_uint_t)*8);
dlo = d & (((sexp_luint_t)1<<(sizeof(sexp_uint_t)*8))-1);
sexp_bignum_data(x)[off] = dhi;
if (off > 0) sexp_bignum_data(x)[off-1] = dlo;
/* update quotient q and remainder a1 estimates */
@ -646,13 +557,12 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
}
/* flip the sign if we overshot in our estimate */
if (sexp_bignum_sign(a1) != sign) {
sexp_bignum_sign(a1) = (char)(-sign);
sexp_bignum_sign(a1) = -sign;
sign *= -1;
}
}
/* adjust signs */
a1 = sexp_bignum_normalize(a1);
if (sign < 0 && a1 != SEXP_ZERO) {
if (sign < 0) {
q = sexp_sub(ctx, q, SEXP_ONE);
a1 = sexp_add(ctx, a1, b1);
}
@ -685,21 +595,14 @@ sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) {
}
sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) {
sexp_sint_t e = sexp_unbox_fixnum(b);
sexp_sint_t abs_e;
if (e < 0)
abs_e = -e;
else
abs_e = e;
sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b));
sexp_gc_var2(res, acc);
sexp_gc_preserve2(ctx, res, acc);
res = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
acc = sexp_copy_bignum(ctx, NULL, a, 0);
for (; abs_e; abs_e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
if (abs_e & 1)
for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
if (e & 1)
res = sexp_bignum_mul(ctx, NULL, res, acc);
if (e < 0)
res = sexp_div(ctx, sexp_fixnum_to_bignum(ctx, SEXP_ONE), res);
sexp_gc_release2(ctx);
return sexp_bignum_normalize(res);
}
@ -735,7 +638,7 @@ sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) {
if (! sexp_bignump(a)) return sexp_type_exception(ctx, NULL, SEXP_BIGNUM, a);
sexp_gc_preserve4(ctx, res, rem, tmp, tmpa);
/* initial estimate via flonum, ignoring signs */
if (sexp_exact_negativep(a)) {
if (sexp_negativep(a)) {
tmpa = sexp_copy_bignum(ctx, NULL, a, 0);
a = tmpa;
sexp_negate(a);
@ -779,25 +682,12 @@ sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) {
#if SEXP_USE_RATIOS
double sexp_ratio_to_double (sexp ctx, sexp rat) {
sexp_gc_var1(quot);
double sexp_ratio_to_double (sexp rat) {
sexp num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
double res = (sexp_bignump(num) ? sexp_bignum_to_double(num)
return (sexp_bignump(num) ? sexp_bignum_to_double(num)
: sexp_fixnum_to_double(num))
/ (sexp_bignump(den) ? sexp_bignum_to_double(den)
: sexp_fixnum_to_double(den));
if (!isfinite(res)) {
sexp_gc_preserve1(ctx, quot);
if (sexp_unbox_fixnum(sexp_compare(ctx, sexp_ratio_numerator(rat), sexp_ratio_denominator(rat))) < 0) {
quot = sexp_quotient(ctx, sexp_ratio_denominator(rat), sexp_ratio_numerator(rat));
res = 1 / sexp_to_double(ctx, quot);
} else {
quot = sexp_quotient(ctx, sexp_ratio_numerator(rat), sexp_ratio_denominator(rat));
res = sexp_to_double(ctx, quot);
}
sexp_gc_release1(ctx);
}
return res;
}
sexp sexp_double_to_ratio (sexp ctx, double f) {
@ -813,7 +703,7 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) {
res = sexp_bignum_fxmul(ctx, NULL, res, 10, 0);
f = f * 10;
res = sexp_bignum_fxadd(ctx, res, (sexp_uint_t)double_10s_digit(f));
res = sexp_bignum_fxadd(ctx, res, double_10s_digit(f));
f = f - trunc(f);
scale = sexp_mul(ctx, scale, SEXP_TEN);
}
@ -827,41 +717,6 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
return res;
}
/*
* For conversion that does not introduce round-off error,
* no matter what FLT_RADIX is.
*/
sexp sexp_double_to_ratio_2 (sexp ctx, double f) {
int sign,i;
sexp_gc_var3(res, whole, scale);
if (f == trunc(f))
return sexp_bignum_normalize(sexp_double_to_bignum(ctx, f));
sexp_gc_preserve3(ctx, res, whole, scale);
whole = sexp_double_to_bignum(ctx, trunc(f));
res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
scale = SEXP_ONE;
sign = (f < 0 ? -1 : 1);
f = fabs(f-trunc(f));
while(f) {
res = sexp_bignum_fxmul(ctx, NULL, res, FLT_RADIX, 0);
scale = sexp_mul(ctx, scale, sexp_make_fixnum(FLT_RADIX));
f *= FLT_RADIX;
i = trunc(f);
if (i) {
f -= i;
res = sexp_bignum_fxadd(ctx, res, i);
}
}
sexp_bignum_sign(res) = sign;
res = sexp_bignum_normalize(res);
scale = sexp_bignum_normalize(scale);
res = sexp_make_ratio(ctx, res, scale);
res = sexp_ratio_normalize(ctx, res, SEXP_FALSE);
res = sexp_add(ctx, res, whole);
sexp_gc_release3(ctx);
return res;
}
sexp sexp_ratio_add (sexp ctx, sexp a, sexp b) {
sexp_gc_var3(res, num, den);
sexp_gc_preserve3(ctx, res, num, den);
@ -912,13 +767,13 @@ sexp sexp_ratio_round (sexp ctx, sexp a) {
sexp_gc_preserve2(ctx, q, r);
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
if ((sexp_ratio_denominator(a) == SEXP_TWO) && sexp_oddp(q)) {
q = sexp_add(ctx, q, (sexp_exact_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
} else {
r = sexp_remainder(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
r = sexp_mul(ctx, r, SEXP_TWO);
if (sexp_exact_negativep(r)) {sexp_negate(r);}
if (sexp_negativep(r)) {sexp_negate(r);}
if (sexp_unbox_fixnum(sexp_compare(ctx, r, sexp_ratio_denominator(a))) > 0)
q = sexp_add(ctx, q, (sexp_exact_negativep(sexp_ratio_numerator(a)) ? SEXP_NEG_ONE : SEXP_ONE));
q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
}
sexp_gc_release2(ctx);
return q;
@ -932,7 +787,7 @@ sexp sexp_ratio_floor (sexp ctx, sexp a) {
sexp_gc_var1(q);
sexp_gc_preserve1(ctx, q);
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
if (sexp_exact_negativep(sexp_ratio_numerator(a)))
if (sexp_negativep(sexp_ratio_numerator(a)))
q = sexp_add(ctx, q, SEXP_NEG_ONE);
sexp_gc_release1(ctx);
return q;
@ -942,7 +797,7 @@ sexp sexp_ratio_ceiling (sexp ctx, sexp a) {
sexp_gc_var1(q);
sexp_gc_preserve1(ctx, q);
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
if (sexp_exact_positivep(sexp_ratio_numerator(a)))
if (sexp_positivep(sexp_ratio_numerator(a)))
q = sexp_add(ctx, q, SEXP_ONE);
sexp_gc_release1(ctx);
return q;
@ -950,21 +805,6 @@ sexp sexp_ratio_ceiling (sexp ctx, sexp a) {
#endif
double sexp_to_double (sexp ctx, sexp x) {
if (sexp_flonump(x))
return sexp_flonum_value(x);
else if (sexp_fixnump(x))
return sexp_fixnum_to_double(x);
else if (sexp_bignump(x))
return sexp_bignum_to_double(x);
#if SEXP_USE_RATIOS
else if (sexp_ratiop(x))
return sexp_ratio_to_double(ctx, x);
#endif
else
return 0.0;
}
/************************ complex numbers ****************************/
#if SEXP_USE_COMPLEX
@ -999,8 +839,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;
@ -1046,6 +886,21 @@ sexp sexp_complex_div (sexp ctx, sexp a, sexp b) {
return sexp_complex_normalize(res);
}
static double sexp_to_double (sexp x) {
if (sexp_flonump(x))
return sexp_flonum_value(x);
else if (sexp_fixnump(x))
return sexp_fixnum_to_double(x);
else if (sexp_bignump(x))
return sexp_bignum_to_double(x);
#if SEXP_USE_RATIOS
else if (sexp_ratiop(x))
return sexp_ratio_to_double(x);
#endif
else
return 0.0;
}
static sexp sexp_to_complex (sexp ctx, sexp x) {
#if SEXP_USE_RATIOS
sexp_gc_var1(tmp);
@ -1056,7 +911,7 @@ static sexp sexp_to_complex (sexp ctx, sexp x) {
} else if (sexp_ratiop(x)) {
sexp_gc_preserve1(ctx, tmp);
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(ctx, x));
sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(x));
sexp_gc_release1(ctx);
return tmp;
#endif
@ -1066,8 +921,8 @@ static sexp sexp_to_complex (sexp ctx, sexp x) {
}
sexp sexp_complex_exp (sexp ctx, sexp z) {
double e2x = exp(sexp_to_double(ctx, sexp_complex_real(z))),
y = sexp_to_double(ctx, sexp_complex_imag(z));
double e2x = exp(sexp_to_double(sexp_complex_real(z))),
y = sexp_to_double(sexp_complex_imag(z));
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
@ -1078,8 +933,8 @@ sexp sexp_complex_exp (sexp ctx, sexp z) {
}
sexp sexp_complex_log (sexp ctx, sexp z) {
double x = sexp_to_double(ctx, sexp_complex_real(z)),
y = sexp_to_double(ctx, sexp_complex_imag(z));
double x = sexp_to_double(sexp_complex_real(z)),
y = sexp_to_double(sexp_complex_imag(z));
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
@ -1103,21 +958,21 @@ sexp sexp_complex_expt (sexp ctx, sexp a, sexp b) {
#if SEXP_USE_MATH
sexp sexp_complex_sqrt (sexp ctx, sexp z) {
double x = sexp_to_double(ctx, sexp_complex_real(z)),
y = sexp_to_double(ctx, sexp_complex_imag(z)), r;
double x = sexp_to_double(sexp_complex_real(z)),
y = sexp_to_double(sexp_complex_imag(z)), r;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
r = sqrt(x*x + y*y);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
sexp_complex_real(res) = sexp_make_flonum(ctx, sqrt((x+r)/2));
sexp_complex_imag(res) = sexp_make_flonum(ctx, ((y<-0.0)?-1:1)*sqrt((-x+r)/2));
sexp_complex_imag(res) = sexp_make_flonum(ctx, (y<0?-1:1)*sqrt((-x+r)/2));
sexp_gc_release1(ctx);
return res;
}
sexp sexp_complex_sin (sexp ctx, sexp z) {
double x = sexp_to_double(ctx, sexp_complex_real(z)),
y = sexp_to_double(ctx, sexp_complex_imag(z));
double x = sexp_to_double(sexp_complex_real(z)),
y = sexp_to_double(sexp_complex_imag(z));
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
@ -1128,8 +983,8 @@ sexp sexp_complex_sin (sexp ctx, sexp z) {
}
sexp sexp_complex_cos (sexp ctx, sexp z) {
double x = sexp_to_double(ctx, sexp_complex_real(z)),
y = sexp_to_double(ctx, sexp_complex_imag(z));
double x = sexp_to_double(sexp_complex_real(z)),
y = sexp_to_double(sexp_complex_imag(z));
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
@ -1151,19 +1006,22 @@ sexp sexp_complex_tan (sexp ctx, sexp z) {
}
sexp sexp_complex_asin (sexp ctx, sexp z) {
sexp_gc_var3(res, tmp, tmp2);
sexp_gc_preserve3(ctx, res, tmp, tmp2);
sexp_gc_var2(res, tmp);
sexp_gc_preserve2(ctx, res, tmp);
res = sexp_complex_mul(ctx, z, z);
res = sexp_sub(ctx, SEXP_ONE, res);
res = sexp_sqrt(ctx, NULL, 1, res);
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
sexp_complex_real(tmp) = sexp_mul(ctx, SEXP_NEG_ONE, sexp_complex_imag(z));
tmp = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO);
res = sexp_complex_sub(ctx, tmp, res);
res = sexp_complex_sqrt(ctx, res);
/* tmp = iz */
sexp_complex_real(tmp) = sexp_complex_imag(z);
sexp_negate(sexp_complex_real(tmp));
sexp_complex_imag(tmp) = sexp_complex_real(z);
res = sexp_add(ctx, tmp, res);
res = sexp_log(ctx, NULL, 1, res);
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_NEG_ONE);
res = sexp_mul(ctx, res, tmp);
sexp_gc_release3(ctx);
res = sexp_complex_add(ctx, tmp, res);
tmp = sexp_complex_log(ctx, res);
/* res = -i*tmp */
res = sexp_complex_copy(ctx, tmp);
sexp_negate(sexp_complex_imag(res));
sexp_gc_release2(ctx);
return res;
}
@ -1327,7 +1185,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
r = sexp_make_fixnum(sum);
break;
case SEXP_NUM_FIX_FLO:
r = a == SEXP_ZERO ? b : sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
break;
case SEXP_NUM_FIX_BIG:
r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a));
@ -1343,7 +1201,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
break;
#if SEXP_USE_RATIOS
case SEXP_NUM_FLO_RAT:
r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_ratio_to_double(ctx, b));
r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_ratio_to_double(b));
break;
case SEXP_NUM_FIX_RAT:
case SEXP_NUM_BIG_RAT:
@ -1403,7 +1261,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
r = sexp_fx_sub(a, b); /* VM catches this case */
break;
case SEXP_NUM_FIX_FLO:
r = sexp_make_flonum(ctx, a==SEXP_ZERO ? -sexp_flonum_value(b) : sexp_fixnum_to_double(a)-sexp_flonum_value(b));
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b));
break;
case SEXP_NUM_FIX_BIG:
tmp1 = sexp_fixnum_to_bignum(ctx, a);
@ -1432,10 +1290,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
break;
#if SEXP_USE_RATIOS
case SEXP_NUM_FLO_RAT:
r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_ratio_to_double(ctx, b));
r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_ratio_to_double(b));
break;
case SEXP_NUM_RAT_FLO:
r = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a) - sexp_flonum_value(b));
r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) - sexp_flonum_value(b));
break;
case SEXP_NUM_RAT_FIX:
case SEXP_NUM_RAT_BIG:
@ -1453,17 +1311,21 @@ 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
#if SEXP_USE_COMPLEX
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_CPX:
a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a));
a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
goto complex_sub;
case SEXP_NUM_CPX_RAT:
b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, b));
b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
/* ... FALLTHROUGH ... */
#endif
case SEXP_NUM_CPX_FLO:
@ -1485,10 +1347,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;
@ -1514,17 +1376,17 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
break;
case SEXP_NUM_FIX_FIX:
prod = lsint_mul_sint(lsint_from_sint(sexp_unbox_fixnum(a)), sexp_unbox_fixnum(b));
if (!lsint_is_fixnum(prod))
prod = (sexp_lsint_t)sexp_unbox_fixnum(a) * sexp_unbox_fixnum(b);
if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM))
r = sexp_mul(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
else
r = sexp_make_fixnum(lsint_to_sint(prod));
r = sexp_make_fixnum(prod);
break;
case SEXP_NUM_FIX_FLO:
r = (a==SEXP_ZERO ? a : sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)));
break;
case SEXP_NUM_FIX_BIG:
r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fx_abs(a), 0);
r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0);
sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b);
r = sexp_bignum_normalize(r);
break;
@ -1539,7 +1401,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
break;
#if SEXP_USE_RATIOS
case SEXP_NUM_FLO_RAT:
r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_ratio_to_double(ctx, b));
r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_ratio_to_double(b));
break;
case SEXP_NUM_FIX_RAT:
case SEXP_NUM_BIG_RAT:
@ -1646,10 +1508,10 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
break;
#if SEXP_USE_RATIOS
case SEXP_NUM_FLO_RAT:
r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_ratio_to_double(ctx, b));
r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_ratio_to_double(b));
break;
case SEXP_NUM_RAT_FLO:
r = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a) / sexp_flonum_value(b));
r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) / sexp_flonum_value(b));
break;
case SEXP_NUM_RAT_FIX:
case SEXP_NUM_RAT_BIG:
@ -1667,7 +1529,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
#if SEXP_USE_COMPLEX
#if SEXP_USE_RATIOS
case SEXP_NUM_CPX_RAT:
b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, b));
b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
/* ... FALLTHROUGH ... */
#endif
case SEXP_NUM_CPX_FLO:
@ -1678,7 +1540,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_CPX:
if (sexp_ratiop(a))
a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a));
a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
/* ... FALLTHROUGH ... */
#endif
case SEXP_NUM_FLO_CPX:
@ -1762,9 +1624,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;
@ -1798,11 +1657,8 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
#if SEXP_USE_RATIOS
case SEXP_NUM_FLO_RAT:
#endif
if (isinf(sexp_flonum_value(a)) ||
sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
} else if (bt == SEXP_NUM_FLO && isinf(sexp_flonum_value(b))) {
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
} else {
tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(a)));
tmp = sexp_remainder(ctx, tmp, b);
@ -1825,8 +1681,7 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_FLO:
#endif
if (isinf(sexp_flonum_value(b)) ||
sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
} else {
tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(b)));
@ -1867,16 +1722,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 +1740,9 @@ 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))) {
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));
}
f = sexp_fixnum_to_double(a);
g = sexp_flonum_value(b);
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
break;
case SEXP_NUM_FIX_BIG:
if ((sexp_bignum_hi(b) > 1) ||
@ -1903,11 +1754,6 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
case SEXP_NUM_FLO_FLO:
f = sexp_flonum_value(a);
g = sexp_flonum_value(b);
if (isnan(f))
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
else if (isnan(g))
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
else
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
break;
case SEXP_NUM_FLO_BIG:
@ -1933,7 +1779,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(b);
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
}
break;
case SEXP_NUM_FIX_RAT:
@ -1944,9 +1791,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);

2
build-lib/chibi/char-set/compute.scm
View file

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

12
build-lib/chibi/char-set/width.sld
View file

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

206
chibi-scheme.vcproj Normal file
View file

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

5
configure vendored
View file

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

5
contrib/bash_completion
View file

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

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()

27
contrib/chibi-genstatic-helper.cmake
View file

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

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}

439
contrib/scheme-keywords.el
View file

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

2
data/.gitignore vendored
View file

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

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/

79
doc/chibi-scheme.1
View file

@ -6,16 +6,13 @@ chibi-scheme \- a tiny Scheme interpreter
.SH SYNOPSIS
.B chibi-scheme
[-qQrRfTV]
[-qQrRfV]
[-I
.I path
]
[-A
.I path
]
[-D
.I feature
]
[-m
.I module
]
@ -75,42 +72,21 @@ program. Signals aren't caught either - to enable handling keyboard
interrupts you can use the (chibi process) module. For a more
sophisticated REPL with readline support, signal handling, module
management and smarter read/write you may want to use the (chibi repl)
module. This can be launched automatically with:
.I chibi-scheme -R
\[char46]
module. For example,
.I chibi-scheme -mchibi.repl -e'(repl)'
For convenience the default language is the
(scheme small) module, which includes every library in the R7RS
small standard, and transitively some other dependencies. All of this
together is actually quite large, so for a more minimal startup
language you'll want to use the
.I -x module
option described below.
To get a mostly R5RS-compatible language, use
The default language the R7RS
(scheme base) module. To get a mostly R5RS-compatible language, use
.I chibi-scheme -xscheme.r5rs
or to get just the core language used for bootstrapping, use
.I chibi-scheme -xchibi
or its shortcut
.I chibi-scheme -q
\[char46]
.SH OPTIONS
Space is optional between options and their arguments. Options
without arguments may not be chained together.
To reduce the need for shell escapes, options with module arguments
(
.I -m
,
.I -x
and
.I -R
) are written in a dot notation, so that the module
.I (foo bar)
is written as
.I foo.bar
\[char46]
Space is optional between options and their arguments.
Options without arguments may not be chained together.
.TP 5
.BI -V
@ -138,10 +114,6 @@ Loads the given module and runs the "main" procedure it defines (which
need not be exported) with a single argument of the list of command-line
arguments as in SRFI-22. The name "main" can be overridden with the -r
option.
.I [module]
may be omitted, in which case it defaults to chibi.repl. Thus
.I chibi-scheme -R
is the recommended means to obtain the advanced REPL.
.TP
.BI -s
Strict mode, escalating warnings to fatal errors.
@ -149,11 +121,6 @@ Strict mode, escalating warnings to fatal errors.
.BI -f
Change the reader to case-fold symbols as in R5RS.
.TP
.BI -T
Disables tail-call optimization. This can be useful for
debugging in some cases, but also makes it very likely to
overflow the stack.
.TP
.BI -h size[/max_size]
Specifies the initial size of the heap, in bytes,
optionally followed by the maximum size the heap can
@ -175,12 +142,6 @@ Appends
.I path
to the load path list.
.TP
.BI -D feature
Adds
.I feature
to the feature list, useful for cond-expanding different
library code.
.TP
.BI -m module
.TP
.BI -x module
@ -188,7 +149,11 @@ Imports
.I module
as though "(import
.I module
)" were evaluated.
)" were evaluated. However, to reduce the need for shell
escapes, modules are written in a dot notation, so that the module
.I (foo bar)
is written as
.I foo.bar
If the
.BI -x
version is used, then
@ -225,17 +190,13 @@ Loads the Scheme heap from
.I image-file
instead of compiling the init file on the fly.
This feature is still experimental.
.TP
.BI -b
Makes stdio nonblocking (blocking by default). Only available when
lightweight threads are enabled.
.SH ENVIRONMENT
.TP
.B CHIBI_MODULE_PATH
A colon separated list of directories to search for module
files, inserted before the system default load paths. chibi-scheme
searches for modules in directories in the following order:
searchs for modules in directories in the following order:
.TP
directories included with the -I path option
@ -246,14 +207,8 @@ searches for modules in directories in the following order:
.TP
directories included with -A path option
If CHIBI_MODULE_PATH is unset, the directories "./lib", and "." are
searched in order. Set to empty to only consider -I, system
directories and -A.
.TP
.B CHIBI_IGNORE_SYSTEM_PATH
If set to anything but "0", system directories (as listed above) are
not included in the search paths.
If CHIBI_MODULE_PATH is unset, the directoriese "./lib", and "." are
search in order.
.SH AUTHORS
.PP
@ -261,9 +216,9 @@ Alex Shinn (alexshinn @ gmail . com)
.SH SEE ALSO
.PP
More detailed information can be found in the manual included in
More detailed information can be found in the manuale included in
doc/chibi.scrbl included in the distribution.
The chibi-scheme home-page:
.br
https://github.com/ashinn/chibi-scheme/
http://code.google.com/p/chibi-scheme/

467
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,16 +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"
}
By default files are installed in /usr/local. You can optionally
specify a PREFIX for the installation directory:
\command{
make PREFIX=/path/to/install/
sudo make PREFIX=/path/to/install/ install
make -B chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS
}
\subsection{Compile-Time Options}
@ -120,7 +104,6 @@ are listed below.
\item{\ccode{SEXP_USE_RATIOS} - use exact ratios (enabled by default)}
\item{\ccode{SEXP_USE_COMPLEX} - use complex numbers (enabled by default)}
\item{\ccode{SEXP_USE_UTF8_STRINGS} - Unicode support (enabled by default)}
\item{\ccode{SEXP_USE_STRING_INDEX_TABLE} - precompute offsets for O(1) \scheme{string-ref}}
\item{\ccode{SEXP_USE_NO_FEATURES} - disable almost all features}
]
@ -136,8 +119,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}
@ -148,10 +129,9 @@ superset of
\hyperlink["http://www.schemers.org/Documents/Standards/R5RS/HTML/"]{R5RS}.
The reader defaults to case-sensitive, like R6RS and R7RS but unlike
R5RS. You can specify the -f option on the command-line to enable
case-folding. The default configuration includes the full numeric
tower: fixnums, flonums, bignums, exact rationals and complex numbers,
though this can be customized at compile time.
R5RS. The default configuration includes the full numeric tower:
fixnums, flonums, bignums, exact rationals and complex numbers, though
this can be customized at compile time.
Full continuations are supported, but currently continuations don't
take C code into account. This means that you can call from Scheme to
@ -165,14 +145,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
@ -192,12 +171,11 @@ other languages.
\subsection{Module System}
Chibi supports the R7RS module system natively, which is a simple
static module system. The Chibi implementation is actually a
hierarchy of languages in the style of the
\hyperlink["http://s48.org/"]{Scheme48} module system, allowing easy
extension of the module system itself. As with most features this is
optional, and can be ignored or completely disabled at compile time.
Chibi uses the R7RS module system natively, which is a simple static
module system in the style of the
\hyperlink["http://s48.org/"]{Scheme48} module system. As with most
features this is optional, and can be ignored or completely disabled
at compile time.
Modules names are hierarchical lists of symbols or numbers. A module
definition uses the following form:
@ -215,8 +193,7 @@ where \var{<library-declarations>} can be any of
(begin <expr> ...) ;; inline Scheme code
(include <file> ...) ;; load one or more files
(include-ci <file> ...) ;; as include, with case-folding
(include-shared <file> ...) ;; dynamic load a library (non-R7RS)
(alias-for <library>) ;; a library alias (non-R7RS)
(include-shared <file> ...) ;; dynamic load a library
}
\var{<import-spec>} can either be a module name or any of
@ -225,23 +202,13 @@ where \var{<library-declarations>} can be any of
(only <import-spec> <id> ...)
(except <import-spec> <id> ...)
(rename <import-spec> (<from-id> <to-id>) ...)
(prefix <import-spec> <prefix-id>)
(drop-prefix <import-spec> <prefix-id>) ;; non-R7RS
(prefix <prefix-id> <import-spec>)
}
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
@ -250,7 +217,7 @@ module \scheme{(foo bar baz)} is searched for in the file
installed directories, \scheme{"."} and \scheme{"./lib"}. Additional
directories can be specified with the command-line options \ccode{-I}
and \ccode{-A} (see the command-line options below) or with the
\scheme{add-module-directory} procedure at runtime. You can search for
\scheme{add-modue-directory} procedure at runtime. You can search for
a module file with \scheme{(find-module-file <file>)}, or load it with
\scheme{(load-module-file <file> <env>)}.
@ -289,8 +256,8 @@ These are just syntactic sugar for the following more primitive type
constructors:
\schemeblock{
(register-simple-type <name-string> <parent> <field-names>)
=> <type> ; parent may be #f, field-names should be a list of symbols
(register-simple-type <name-string> <parent> <num-fields>)
=> <type>
(make-type-predicate <opcode-name-string> <type>)
=> <opcode> ; takes 1 arg, returns #t iff that arg is of the type
@ -303,38 +270,27 @@ constructors:
(make-setter <setter-name-string> <type> <field-index>)
=> <opcode> ; takes 2 args, sets the field located at the index
(type-slot-offset <type> <field-name>)
=> <index> ; returns the index of the field with the given name
}
\subsection{Unicode}
Chibi supports Unicode strings and I/O natively. Case mappings and
comparisons, character properties, formatting and regular expressions
are all Unicode aware, supporting the latest version 13.0 of the
Unicode standard.
Internally strings are encoded as UTF-8. This provides easy
interoperability with many C libraries, but means that
\scheme{string-ref} and \scheme{string-set!} are O(n), so they should
be avoided in performance-sensitive code (unless you compile Chibi
with SEXP_USE_STRING_INDEX_TABLE).
Chibi supports Unicode strings, encoding them as utf8. This provides easy
interoperability with many C libraries, but means that \scheme{string-ref} and
\scheme{string-set!} are O(n), so they should be avoided in
performance-sensitive code.
In general you should use high-level APIs such as \scheme{string-map}
to ensure fast string iteration. String ports also provide a simple
and portable way to efficiently iterate and construct strings, by
looping over an input string or accumulating characters in an output
string.
way to efficiently iterate and construct strings, by looping over an
input string or accumulating characters in an output string.
The \scheme{in-string} and \scheme{in-string-reverse} iterators in the
\scheme{(chibi loop)} module will also iterate over strings
efficiently while hiding the low-level details.
In the event that you do need a low-level interface, such as when
writing your own iterator protocol, you should use string cursors.
\scheme{(srfi 130)} provides a portable API for this, or you can use
\scheme{(chibi string)} which builds on the following core procedures:
writing your own iterator protocol, you should use the following
string cursor API instead of indexes.
\itemlist[
\item{\scheme{(string-cursor-start str)}
@ -370,10 +326,9 @@ To use Chibi-Scheme in a program you need to link against the
\ccode{#include <chibi/eval.h>}
All definitions begin with a "sexp_" prefix, or "SEXP_" for constants
(deliberately chosen not to conflict with other Scheme implementations
which typically use "scm_"). In addition to the prototypes and
utility macros, this includes the following type definitions:
All definitions begin with a "sexp_" prefix, or "SEXP_" for constants.
In addition to the prototypes and utility macros, this includes the
following type definitions:
\itemlist[
\item{\ctype{sexp} - an s-expression, used to represent all Scheme objects}
@ -407,10 +362,9 @@ void dostuff(sexp ctx) {
int main(int argc, char** argv) {
sexp ctx;
sexp_scheme_init();
ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
sexp_load_standard_env(ctx, NULL, SEXP_SEVEN);
sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 1);
sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 0);
dostuff(ctx);
sexp_destroy_context(ctx);
}
@ -435,7 +389,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},
@ -476,11 +430,6 @@ using only the parent.
Otherwise, a new heap is allocated with \var{size} bytes, expandable to a
maximum of \var{max_size} bytes, using the system defaults if either is 0.
Note this context is not a malloced pointer (it resides inside a
malloced heap), and therefore can't be passed to \ccode{free()},
or stored in a C++ smart pointer. It can only be reclaimed with
\ccode{sexp_destroy_context}.
}}
\item{\ccode{sexp_make_eval_context(sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size)}
@ -512,8 +461,7 @@ the default context environment is used. Any of the \ctype{FILE*} may
be \cvar{NULL}, in which case the corresponding port is not set. If
\var{leave_open} is true, then the underlying \ctype{FILE*} is left
open after the Scheme port is closed, otherwise they are both closed
together. If you want to reuse these streams from other vms, or from
C, you should specify leave_open.
together.
}}
\item{\ccode{sexp_load(sexp ctx, sexp file, sexp env)}
@ -557,11 +505,6 @@ Returns the current binding of \var{sym} in \var{env}, or \var{dflt} if there
is no binding.
}}
\item{\ccode{sexp_env_import(sexp ctx, sexp to, sexp from, sexp ls, sexp immutp)}
\p{
Imports the bindings from environment \var{from} into environment \var{to}. \var{ls} is the list of bindings to import - if it is \scheme{#f} then import all bindings. If \var{immutp} is true the imported bindings are immutable and cannot be redefined.
}}
\item{\ccode{sexp_parameter_ref(sexp ctx, sexp param)}
\p{
Returns the current dynamic value of the parameter \var{param} in the
@ -666,15 +609,13 @@ sexp_release_object(ctx, obj)
Decrement the absolute reference count for \var{obj}.
\subsection{C API Index}
\subsection{API Index}
The above sections describe most everything you need for embedding in
a typical application, notably creating environments and evaluating
code from sexps, strings or files. The following sections expand on
additional macros and utilities for inspecting, accessing and creating
different Scheme types, and for performing port and string I/O. It is
incomplete - see the macros and SEXP_API annotated functions in the
include files (sexp.h, eval.h, bignum.h) for more bindings.
different Scheme types, and for performing port and string I/O.
Being able to convert from C string to sexp, evaluate it, and convert
the result back to a C string forms the basis of the C API. Because
@ -702,13 +643,10 @@ 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}
\item{\ccode{sexp_string_cursorp(obj)} - \var{obj} is a string cursor}
\item{\ccode{sexp_bytesp(obj)} - \var{obj} is a bytevector}
\item{\ccode{sexp_symbolp(obj)} - \var{obj} is a symbol}
\item{\ccode{sexp_idp(obj)} - \var{obj} is a symbol or hygienic identifier}
@ -766,7 +704,7 @@ check. The runtime does not prevent embedded NULLs inside strings,
however data after the NULL may be ignored.
By default (unless you compile with -DSEXP_USE_UTF8_STRING=0), strings
are interpreted as UTF-8 encoded on the Scheme side, as describe in
are interpreted as utf8 encoded on the Scheme side, as describe in
section Unicode above. In many cases you can ignore this on the C
side and just treat the string as an opaque sequence of bytes.
However, if you need to you can use the following macros to safely
@ -784,7 +722,7 @@ compiled with:
\item{\ccode{sexp sexp_substring_cursor(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between raw offsets \var{i} and \var{j}}
]
When UTF-8 support is not compiled in the cursor and non-cursor
When UTF8 support is not compiled in the cursor and non-cursor
variants are equivalent.
\subsubsection{Accessors}
@ -800,12 +738,8 @@ once.
\item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise}
\item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}}
\item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer}
\item{\ccode{sexp_make_flonum(sexp ctx, float f)} - creates a new floating point value}
\item{\ccode{sexp_flonum_value(obj)} - converts a flonum to a C float}
\item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}}
\item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char}
\item{\ccode{sexp sexp_make_string_cursor(int offset)} - creates a string cursor for the given byte offset}
\item{\ccode{int sexp_unbox_string_cursor(sexp sc)} - returns the offset for the given string cursor}
\item{\ccode{sexp_car(pair)} - the car of \var{pair}}
\item{\ccode{sexp_cdr(pair)} - the cdr of \var{pair}}
\item{\ccode{sexp_ratio_numerator(q)} - the numerator of the ratio \var{q}}
@ -834,7 +768,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}).}
@ -850,6 +783,7 @@ Any of these may fail and return the OOM exception object.
\item{\ccode{sexp_read(sexp ctx, sexp in)} - read a single datum from port \var{in}}
\item{\ccode{sexp_write(sexp ctx, sexp obj, sexp out)} - write \var{obj} to port \var{out}}
\item{\ccode{sexp_write_string(sexp ctx, char* str, sexp out)} - write the characters in \var{str} to port \var{out}}
\item{\ccode{sexp_display(sexp ctx, sexp obj, sexp out)} - display \var{obj} to port \var{out}}
\item{\ccode{sexp_newline(sexp ctx, sexp out)} - write a newline to port \var{out}}
\item{\ccode{sexp_print_exception(sexp ctx, sexp exn, sexp out)} - print an error message for \var{exn} to port \var{out}}
\item{\ccode{sexp_current_input_port(sexp ctx)} - the \scheme{current-input-port}}
@ -860,7 +794,7 @@ Any of these may fail and return the OOM exception object.
\item{\ccode{sexp_write_to_string(sexp ctx, sexp obj)} - return a Scheme string representation of \var{obj}}
\item{\ccode{sexp_open_input_string(sexp ctx, sexp str)} - equivalent to \scheme{open-input-string}}
\item{\ccode{sexp_open_output_string(sexp ctx)} - equivalent to \scheme{open-output-string}}
\item{\ccode{sexp_get_output_string(sexp ctx, sexp port)} - equivalent to \scheme{get-output-string}}
\item{\ccode{sexp_get_output_string(sexp ctx, sexp port)} - equivalent to \scheme{open-output-string}}
]
\subsubsection{Utilities}
@ -873,7 +807,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}}
@ -953,39 +887,6 @@ to any inherited from the parent type \var{parent}. If \var{parent} is false,
inherits from the default \var{object} record type.
}}
\item{\ccode{sexp sexp_register_c_type(sexp ctx, sexp name, sexp finalizer)}
\p{
Shortcut to defines a new type as a wrapper around a C pointer.
Returns the type object, which can be used with sexp_make_cpointer to
wrap instances of the type. The finalizer may be sexp_finalize_c_type
in which case managed pointers are freed as if allocated with malloc,
NULL in which case the pointers are never freed, or otherwise a
procedure of one argument which should release any resources.
}}
\item{\ccode{sexp sexp_make_cpointer(sexp ctx, sexp_uint_t type_tag, void* value, sexp parent, int freep)}
\p{
Creates a new instance of the type indicated by type_tag wrapping
value. If parent is provided, references to the child will also
preserve the parent, important e.g. to preserve an enclosing struct
when wrapped references to nested structs are still in use. If freep
is true, then when reclaimed by the GC the finalizer for this type,
if any, will be called on the instance.
You can retrieve the tag from a type object with sexp_type_tag(type).
}}
\item{\ccode{sexp sexp_lookup_type(sexp ctx, sexp name, sexp tag_or_id)}
\p{
Returns the type whose name matches the string \var{name}. If
\var{tag_or_id} is an integer, it is taken as the tag and requires the
numeric type tag (as from sexp_type_tag) to also match.
}
\p{If \var{tag_or_id} is a string, it is taken as the unique id of the
type, and must match sexp_type_id(type). However, currently
sexp_type_id(type) is never set.
}}
]
See the C FFI for an easy way to automate adding bindings for C
@ -1248,8 +1149,7 @@ A number of SRFIs are provided in the default installation. Note that
SRFIs 0, 6, 23, 46 and 62 are built into the default environment so
there's no need to import them. SRFI 22 is available with the "-r"
command-line option. This list includes popular SRFIs or SRFIs used
in standard Chibi modules (many other SRFIs are available on
snow-fort):
in standard Chibi modules
\itemlist[
@ -1260,7 +1160,6 @@ snow-fort):
\item{\hyperlink["http://srfi.schemers.org/srfi-8/srfi-8.html"]{(srfi 8) - receive}}
\item{\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{(srfi 9) - define-record-type}}
\item{\hyperlink["http://srfi.schemers.org/srfi-11/srfi-11.html"]{(srfi 11) - let-values/let*-values}}
\item{\hyperlink["http://srfi.schemers.org/srfi-14/srfi-14.html"]{(srfi 14) - character-set library}}
\item{\hyperlink["http://srfi.schemers.org/srfi-16/srfi-16.html"]{(srfi 16) - case-lambda}}
\item{\hyperlink["http://srfi.schemers.org/srfi-18/srfi-18.html"]{(srfi 18) - multi-threading support}}
\item{\hyperlink["http://srfi.schemers.org/srfi-22/srfi-22.html"]{(srfi 22) - running scheme scripts on Unix}}
@ -1270,53 +1169,13 @@ snow-fort):
\item{\hyperlink["http://srfi.schemers.org/srfi-33/srfi-33.html"]{(srfi 33) - bitwise operators}}
\item{\hyperlink["http://srfi.schemers.org/srfi-38/srfi-38.html"]{(srfi 38) - read/write shared structures}}
\item{\hyperlink["http://srfi.schemers.org/srfi-39/srfi-39.html"]{(srfi 39) - parameter objects}}
\item{\hyperlink["http://srfi.schemers.org/srfi-41/srfi-41.html"]{(srfi 41) - streams}}
\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}}
\item{\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{(srfi 99) - ERR5RS records}}
\item{\hyperlink["http://srfi.schemers.org/srfi-101/srfi-101.html"]{(srfi 101) - purely functional random-access pairs and lists}}
\item{\hyperlink["http://srfi.schemers.org/srfi-111/srfi-111.html"]{(srfi 111) - boxes}}
\item{\hyperlink["http://srfi.schemers.org/srfi-113/srfi-113.html"]{(srfi 113) - sets and bags}}
\item{\hyperlink["http://srfi.schemers.org/srfi-115/srfi-115.html"]{(srfi 115) - Scheme regular expressions}}
\item{\hyperlink["http://srfi.schemers.org/srfi-116/srfi-116.html"]{(srfi 116) - immutable list library}}
\item{\hyperlink["http://srfi.schemers.org/srfi-117/srfi-117.html"]{(srfi 117) - mutable queues}}
\item{\hyperlink["http://srfi.schemers.org/srfi-121/srfi-121.html"]{(srfi 121) - generators}}
\item{\hyperlink["http://srfi.schemers.org/srfi-124/srfi-124.html"]{(srfi 124) - ephemerons}}
\item{\hyperlink["http://srfi.schemers.org/srfi-125/srfi-125.html"]{(srfi 125) - intermediate hash tables}}
\item{\hyperlink["http://srfi.schemers.org/srfi-127/srfi-127.html"]{(srfi 127) - lazy sequences}}
\item{\hyperlink["http://srfi.schemers.org/srfi-128/srfi-128.html"]{(srfi 128) - comparators (reduced)}}
\item{\hyperlink["http://srfi.schemers.org/srfi-129/srfi-129.html"]{(srfi 129) - titlecase procedures}}
\item{\hyperlink["http://srfi.schemers.org/srfi-130/srfi-130.html"]{(srfi 130) - cursor-based string library}}
\item{\hyperlink["http://srfi.schemers.org/srfi-132/srfi-132.html"]{(srfi 132) - sort libraries}}
\item{\hyperlink["http://srfi.schemers.org/srfi-133/srfi-133.html"]{(srfi 133) - vector library}}
\item{\hyperlink["http://srfi.schemers.org/srfi-134/srfi-134.html"]{(srfi 134) - immutable deques}}
\item{\hyperlink["http://srfi.schemers.org/srfi-135/srfi-135.html"]{(srfi 135) - immutable texts}}
\item{\hyperlink["http://srfi.schemers.org/srfi-139/srfi-139.html"]{(srfi 139) - syntax parameters}}
\item{\hyperlink["http://srfi.schemers.org/srfi-141/srfi-141.html"]{(srfi 141) - integer division}}
\item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-142.html"]{(srfi 142) - bitwise operations}}
\item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-143.html"]{(srfi 143) - fixnums}}
\item{\hyperlink["http://srfi.schemers.org/srfi-144/srfi-144.html"]{(srfi 144) - flonums}}
\item{\hyperlink["http://srfi.schemers.org/srfi-145/srfi-145.html"]{(srfi 145) - assumptions}}
\item{\hyperlink["http://srfi.schemers.org/srfi-147/srfi-147.html"]{(srfi 147) - custom macro transformers}}
\item{\hyperlink["http://srfi.schemers.org/srfi-151/srfi-151.html"]{(srfi 151) - bitwise operators}}
\item{\hyperlink["http://srfi.schemers.org/srfi-154/srfi-154.html"]{(srfi 154) - first-class dynamic extents}}
\item{\hyperlink["http://srfi.schemers.org/srfi-158/srfi-158.html"]{(srfi 158) - generators and accumulators}}
\item{\hyperlink["http://srfi.schemers.org/srfi-160/srfi-160.html"]{(srfi 160) - homogeneous numeric vector libraries}}
\item{\hyperlink["http://srfi.schemers.org/srfi-165/srfi-165.html"]{(srfi 165) - the environment Monad}}
\item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-166.html"]{(srfi 166) - monadic formatting}}
\item{\hyperlink["http://srfi.schemers.org/srfi-179/srfi-179.html"]{(srfi 179) - nonempty intervals and generalized arrays}}
\item{\hyperlink["http://srfi.schemers.org/srfi-188/srfi-188.html"]{(srfi 188) - splicing binding constructs for syntactic keywords}}
\item{\hyperlink["http://srfi.schemers.org/srfi-193/srfi-193.html"]{(srfi 193) - command-line}}
\item{\hyperlink["http://srfi.schemers.org/srfi-211/srfi-211.html"]{(srfi 211) - scheme macro libaries}}
\item{\hyperlink["http://srfi.schemers.org/srfi-219/srfi-219.html"]{(srfi 219) - define higher-order lambda}}
\item{\hyperlink["http://srfi.schemers.org/srfi-227/srfi-227.html"]{(srfi 227) - optional arguments}}
\item{\hyperlink["http://srfi.schemers.org/srfi-229/srfi-229.html"]{(srfi 229) - tagged procedures}}
\item{\hyperlink["http://srfi.schemers.org/srfi-231/srfi-231.html"]{(srfi 231) - intervals and generalized arrays}}
]
@ -1325,34 +1184,12 @@ namespace.
\itemlist[
\item{\hyperlink["lib/chibi/app.html"]{(chibi app) - Unified option parsing and config}}
\item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}}
\item{\hyperlink["lib/chibi/assert.html"]{(chibi assert) - A nicer assert macro}}
\item{\hyperlink["lib/chibi/base64.html"]{(chibi base64) - Base64 encoding and decoding}}
\item{\hyperlink["lib/chibi/binary-record.html"]{(chibi binary-record) - Record types with binary serialization}}
\item{\hyperlink["lib/chibi/bytevector.html"]{(chibi bytevector) - Bytevector Utilities}}
\item{\hyperlink["lib/chibi/config.html"]{(chibi config) - General configuration management}}
\item{\hyperlink["lib/chibi/crypto/md5.html"]{(chibi crypto md5) - MD5 hash}}
\item{\hyperlink["lib/chibi/crypto/rsa.html"]{(chibi crypto rsa) - RSA public key encryption}}
\item{\hyperlink["lib/chibi/crypto/sha2.html"]{(chibi crypto sha2) - SHA-2 hash}}
\item{\hyperlink["lib/chibi/diff.html"]{(chibi diff) - LCS Algorithm and diff utilities}}
\item{\hyperlink["lib/chibi/disasm.html"]{(chibi disasm) - Disassembler for the virtual machine}}
\item{\hyperlink["lib/chibi/doc.html"]{(chibi doc) - Chibi documentation utilities}}
\item{\hyperlink["lib/chibi/edit-distance.html"]{(chibi edit-distance) - A levenshtein distance implementation}}
\item{\hyperlink["lib/chibi/equiv.html"]{(chibi equiv) - A version of \scheme{equal?} which is guaranteed to terminate}}
\item{\hyperlink["lib/chibi/filesystem.html"]{(chibi filesystem) - Interface to the filesystem and file descriptor objects}}
@ -1363,60 +1200,32 @@ namespace.
\item{\hyperlink["lib/chibi/io.html"]{(chibi io) - Various I/O extensions and custom ports}}
\item{\hyperlink["lib/chibi/iset/base.html"]{(chibi iset base) - Compact integer sets}}
\item{\hyperlink["lib/chibi/iset/base.html"]{(chibi iset base) - Compact integer sets}}
\item{\hyperlink["lib/chibi/iset/constructors.html"]{(chibi iset constructors) - Compact integer set construction}}
\item{\hyperlink["lib/chibi/iset/iterators.html"]{(chibi iset iterators) - Iterating over compact integer sets}}
\item{\hyperlink["lib/chibi/json.html"]{(chibi json) - JSON reading and writing}}
\item{\hyperlink["lib/chibi/loop.html"]{(chibi loop) - Fast and extensible loop syntax}}
\item{\hyperlink["lib/chibi/match.html"]{(chibi match) - Intuitive and widely supported pattern matching syntax}}
\item{\hyperlink["lib/chibi/math/prime.html"]{(chibi math prime) - Prime number utilities}}
\item{\hyperlink["lib/chibi/memoize.html"]{(chibi memoize) - Procedure memoization}}
\item{\hyperlink["lib/chibi/mime.html"]{(chibi mime) - Parse MIME files into SXML}}
\item{\hyperlink["lib/chibi/modules.html"]{(chibi modules) - Introspection for the module system itself}}
\item{\hyperlink["lib/chibi/net.html"]{(chibi net) - Simple networking interface}}
\item{\hyperlink["lib/chibi/net/http-server.html"]{(chibi net http-server) - Simple http-server with servlet support}}
\item{\hyperlink["lib/chibi/net/servlet.html"]{(chibi net servlet) - HTTP servlets for http-server or CGI}}
\item{\hyperlink["lib/chibi/optional.html"]{(chibi optional) - Syntax to support optional and named keyword arguments}}
\item{\hyperlink["lib/chibi/parse.html"]{(chibi parse) - Parser combinators with convenient syntax}}
\item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}}
\item{\hyperlink["lib/chibi/process.html"]{(chibi process) - Interface to spawn processes and handle signals}}
\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)}}
\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - A combinator formatting library}}
\item{\hyperlink["lib/chibi/show/base.scm"]{(chibi show base) - Base combinator formatting}}
\item{\hyperlink["lib/chibi/stty.html"]{(chibi stty) - A high-level interface to ioctl}}
\item{\hyperlink["lib/chibi/sxml.html"]{(chibi sxml) - SXML utilities}}
\item{\hyperlink["lib/chibi/system.html"]{(chibi system) - Access to the host system and current user information}}
\item{\hyperlink["lib/chibi/temp-file.html"]{(chibi temp-file) - Temporary file and directory creation}}
\item{\hyperlink["lib/chibi/test.html"]{(chibi test) - A simple unit testing framework}}
\item{\hyperlink["lib/chibi/time.html"]{(chibi time) - An interface to the current system time}}
@ -1434,199 +1243,67 @@ namespace.
\section{Snow Package Manager}
Beyond the distributed modules, Chibi comes with a package manager
based on \hyperlink["https://small.r7rs.org/wiki/Snow/"]{Snow2}
based on \hyperlink["http://trac.sacrideo.us/wg/wiki/Snow"]{Snow2}
which can be used to share R7RS libraries. Packages are distributed
as tar gzipped files called "snowballs," and may contain multiple
libraries. The program is installed as \scheme{snow-chibi}. The
"help" subcommand can be used to list all subcommands and options.
Note by default \scheme{snow-chibi} uses an image file to speed-up
loading (since it loads many libraries) - if you have any difficulties
with image files on your platform you can run
\command{snow-chibi --noimage} to disable this feature.
libraries. The program is installed as \scheme{snow-chibi} and takes
the following subcommands:
\subsubsection{Querying Packages and Status}
By default \scheme{snow-chibi} looks for packages in the public
repository \hyperlink["http://snow-fort.org/"]{http://snow-fort.org/},
though you can customize this with the \scheme{--repository-uri} or
\scheme{--repo} option (e.g. "http://snow-fort.org/s/repo.scm").
Packages can be browsed on the site, but you can also search and query
from the command-line tool.
\subsubsection{Querying Packages}
\itemlist[
\item{search terms ... - search for packages
\p{Print a list of available packages matching the given keywords.}}
\p{Prints a list of available packages matching the given keywords.}}
\item{show names ... - show package descriptions
\p{Show detailed information for the listed packages, which can
be sexp library names or the dotted shorthand used by chibi. For example,
\scheme{snow-chibi show "(chibi match)"} can be shortened as
\scheme{snow-chibi show chibi.match}.}}
be sexp library names or the dotted shorthand used by chibi.}}
\item{status names ... - print package status
\p{Print the installed version of the given packages. Uninstalled
packages will not be shown. If no names are given, prints all
currently installed packages.}}
\item{implementations - print list of available implementations
\p{Print the currently installed Scheme implementations supported
by \scheme{snow-chibi}. If an implementation is found but has an
older version, a warning is printed.}}
\p{Print the installed version of the given packages.}}
]
\subsubsection{Managing Packages}
The basic package management functionality, installing upgrading and
removing packages.
By default the packages will be managed for Chibi. You can specify
what Scheme implementation to install, upgrade... with
\scheme{--implementations} or \scheme{--impls} option. Specify "all"
to manage all supported implementations.
\itemlist[
\item{install names ... - install packages
\p{Install the given packages. Package names can be sexp lists or
use the dotted shorthand. Explicit names for packages are optional,
as a package can always be referred to by the name of any library it
contains. If multiple packages provide libraries with the same name,
you will be asked to confirm which implementation to install.}
\p{You can also bypass the repository and install a manually downloaded
snowball by giving a path to that file instead of a name. No package
dependencies will be checked for install in this case}}
\p{Install the given packages.}}
\item{upgrade names ... - upgrade installed packages
\p{Upgrade the packages if new versions are available.
If no names are given, upgrades all eligible packages.}}
\item{remove names ... - remove packages
\p{Uninstalls the given packages. If the packages were not installed
with \scheme{snow-chibi} they cannot be removed.}}
\item{update - update local cache of remote repository
\p{\scheme{snow-chibi} keeps a local cache of the remote repository
and updates only periodically for performance, but you can force an
update with this command.}}
\p{Uninstalls the given packages.}}
]
\subsubsection{Authoring Packages}
Creating packages can be done with the \scheme{package} command,
though other commands allow for uploading to public repositories.
By default the public repository is
\hyperlink["http://snow-fort.org/"]{http://snow-fort.org/} but you can
customize this with the \scheme{--host} option.
\subsubsection{Creating Packages}
\itemlist[
\item{package files ... - create a package
\p{Create a package snowball from the given files, which should
be R7RS library files containing \scheme{define-library} forms.
Include files are inferred and packaged automatically. You can
share packages directly, or upload them to a snow repository for
easy automated install.}}
Include files are inferred and packaged automatically.}}
\item{upload files ... - upload packages
\p{Sign and upload to the default snow host. The files may either
be .tgz package files, or files containing define-library forms as
in the \scheme{package} command, from which packages are generated
automatically. Before you can upload to the default host a key
must be generated and registered first with the \scheme{gen-key}
and \scheme{reg-key} commands.}}
\item{gen-key - create a new key
\p{Create a new key, with your name, email address, and optionally
an RSA public key pair (disabled by default in the current implementation).
This is saved locally to ~/.snow/priv-key.scm - you need to register it
with reg-key before it can be used for uploads.}}
\item{reg-key - register a key
\p{Register your key on the default snow host.}}
\item{gen-key - create an RSA key pair
\p{Create a new private key pair.}}
\item{sign file - sign a package
\p{Sign a file with your key and write it to the .sig file.
This can be used with the verify command for testing, but otherwise
is not needed as the upload command generates the signature automatically.}}
\p{Sign a file with your private key and write it to the .sig file.}}
\item{verify sig-file - verify a signature
\item{verify file - verify a signature
\p{Print a message verifying if a signature is valid.}}
]
\subsubsection{Easy Packaging}
To encourage sharing code it's important to make it as easy as
possible to create packages, while encouraging documentation and
tests. In particular, you should never need to duplicate information
anywhere. Thus the \scheme{package} command automatically locates
and packages include files (and data and ffi files) and determines
dependencies for you. In addition, it can automatically handle
versions, docs and tests:
\itemlist[
\item{version - can come explicitly from the \scheme{--version} option, or the \scheme{--version-file=<file>} option}
\item{docs - can come explicitly from the \scheme{--doc=<file>} option, or be extracted automatically from literate documentation with \scheme{doc-for-scribble}}
\item{tests - can come explicitly from the \scheme{--test=<prog-file>} option, or the \scheme{--test-library=<lib-name>} which will generate a program to run just the \scheme{run-tests} thunk in that library}
]
Other useful meta-info options include:
\itemlist[
\item{\scheme{--authors} - specify the package authors (comma-delimited)}
\item{\scheme{--maintainers} - specify the package maintainers (comma-delimited)}
\item{\scheme{--license} - specify the package licence}
]
These three are typically always the same, so it's useful to save them
in your ~/.snow/config.scm file. This file contains a single sexp and
can specify any option, for example:
\schemeblock{
((repository-uri "http://alopeke.gr/repo.scm")
(command
(package
(authors "Socrates <hemlock@aol.com>")
(doc-from-scribble #t)
(version-file "VERSION")
(test-library (append-to-last -test))
(license gpl))))
}
Top-level snow options are represented as a flat alist. Options
specific to a command are nested under \scheme{(command (name ...))},
with most options here being for \scheme{package}. Here unless
overridden on the command-line, all packages will use the given author
and license, try to extract literate docs from the code, look for a
version in the file "VERSION", and try to find a test with the same
library name appended with \scheme{-test}, e.g. for the library
\scheme{(socratic method)}, the test library would be
\scheme{(socratic method-test)}. This form is an alternate to using
an explicit test-library name, and encourages you to keep your tests
close to the code they test. In the typical case, if using these
conventions, you can thus simply run \scheme{snow-chibi package
<lib-file>} without any other options.
\subsubsection{Other Implementations}
Although the command is called \scheme{snow-chibi}, it supports
several other R7RS implementations. The \scheme{implementations}
command tells you which you currently have installed. The following
are currently supported:
\itemlist[
\item{chibi - version >= 0.7.3}
\item{chicken - version >= 4.9.0 with the \scheme{r7rs} egg}
\item{cyclone - version >= 0.5.3}
\item{foment - version >= 0.4}
\item{gauche - version >= 0.9.4}
\item{kawa - version >= 2.0; you need to add the install dir to the search path, e.g. \scheme{-Dkawa.import.path=/usr/local/share/kawa}}
\item{larceny - version 0.98; you need to add "lib/Snow" to the paths in startup.sch}
\item{sagittarius - version >= 0.98}
\item{reg-key - register an RSA key pair
\p{Register your key on the default snow host.}}
\item{upload files ... - upload a package
\p{Sign and upload to the default snow host.
A private key must be generated first.}}
]

610
eval.c
View file

File diff suppressed because it is too large Load diff

29
examples/echo-server-inet6.scm
View file

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

22
examples/echo-server-udp.scm
View file

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

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

435
gc.c
View file

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

789
gc_heap.c
View file

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

383
include/chibi/bignum.h
View file

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

21
include/chibi/eval.h
View file

@ -1,5 +1,5 @@
/* eval.h -- headers for eval library */
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
/* Copyright (c) 2009-2011 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#ifndef SEXP_EVAL_H
@ -46,6 +46,8 @@ enum sexp_opcode_classes {
SEXP_OPC_NUM_OP_CLASSES
};
SEXP_API struct sexp_opcode_struct* sexp_primitive_opcodes;
#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
SEXP_API const char** sexp_opcode_names;
#endif
@ -74,7 +76,7 @@ SEXP_API void sexp_bless_bytecode (sexp ctx, sexp bc);
#endif
SEXP_API sexp sexp_complete_bytecode (sexp ctx);
SEXP_API void sexp_shrink_bcode (sexp ctx, sexp_uint_t i);
SEXP_API void sexp_expand_bcode (sexp ctx, sexp_sint_t size);
SEXP_API void sexp_expand_bcode (sexp ctx, sexp_uint_t size);
SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
SEXP_API int sexp_param_index (sexp ctx, sexp lambda, sexp name);
@ -92,7 +94,6 @@ SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n,
SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value);
SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close);
SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
SEXP_API char* sexp_find_module_file_raw (sexp ctx, const char *file);
SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file);
SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
SEXP_API sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
@ -128,15 +129,13 @@ SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from
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_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
#if SEXP_USE_AUTO_FORCE
SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
#endif
#if SEXP_USE_UTF8_STRINGS
SEXP_API sexp sexp_read_utf8_char (sexp ctx, sexp port, int i);
SEXP_API void sexp_push_utf8_char (sexp ctx, int i, sexp port);
SEXP_API void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch);
SEXP_API sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i);
SEXP_API sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch);
@ -190,13 +189,10 @@ SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
#endif
SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name, int num_args, const char *fname, sexp_proc1 f, const char *param);
#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL)
#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d)
#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)
SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param);
#define sexp_env_key(x) sexp_car(x)
#define sexp_env_value(x) sexp_cdr(x)
@ -240,7 +236,6 @@ SEXP_API sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sex
SEXP_API sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req);
#else
SEXP_API sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port);
SEXP_API sexp sexp_stream_portp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
#endif
#if SEXP_USE_SIMPLIFY

341
include/chibi/features.h
View file

@ -1,5 +1,5 @@
/* features.h -- general feature configuration */
/* Copyright (c) 2009-2021 Alex Shinn. All rights reserved. */
/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
/* uncomment this to disable most features */
@ -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 */
@ -75,21 +64,9 @@
/* if you suspect a bug in the native GC. */
/* #define SEXP_USE_BOEHM 1 */
/* uncomment this to enable automatic file descriptor unification */
/* File descriptors as returned by C functions are raw integers, */
/* which are convereted to GC'ed first-class objects on the Scheme */
/* side. By default we assume that each fd is new, however if this */
/* option is enabled and an fd is returned which matches an existing */
/* open fd, they are assumed to refer to the same descriptor and */
/* unified. */
/* #define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 1 */
/* uncomment this to disable weak references */
/* #define SEXP_USE_WEAK_REFERENCES 0 */
/* uncomment this to enable heap regions for fixed-size chunks */
/* #define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 1 */
/* uncomment this to just malloc manually instead of any GC */
/* Mostly for debugging purposes, this is the no GC option. */
/* You can use just the read/write API and */
@ -104,11 +81,6 @@
/* go away and you're not working on your own C extension. */
/* #define SEXP_USE_CONSERVATIVE_GC 1 */
/* uncomment this to disable automatic running of finalizers */
/* You will need to close ports and file descriptors manually */
/* (as you should anyway) and some C extensions may break. */
/* #define SEXP_USE_FINALIZERS 0 */
/* uncomment this to add additional native checks to only mark objects in the heap */
/* #define SEXP_USE_SAFE_GC_MARK 1 */
@ -125,9 +97,6 @@
/* uncomment this to add very verbose debugging stats to the native GC */
/* #define SEXP_USE_DEBUG_GC 1 */
/* uncomment this to add instrumentation to the native GC */
/* #define SEXP_USE_TIME_GC 1 */
/* uncomment this to enable "safe" field accessors for primitive types */
/* The sexp union type fields are abstracted away with macros of the */
/* form sexp_<type>_<field>(<obj>), however these are just convenience */
@ -143,10 +112,6 @@
/* may be very slow and using CFLAGS=-O0 is recommended. */
/* #define SEXP_USE_SAFE_ACCESSORS 1 */
/* uncomment to install a default signal handler in main() for segfaults */
/* This will print a helpful backtrace. */
/* #define SEXP_USE_PRINT_BACKTRACE_ON_SEGFAULT 1 */
/* uncomment this to make the heap common to all contexts */
/* By default separate contexts can have separate heaps, */
/* and are thus thread-safe and independant. */
@ -188,27 +153,11 @@
/* uncomment this if you don't want 1## style approximate digits */
/* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */
/* uncomment this to disable a workaround for numeric formatting, */
/* to fix numbers in locales which don't use the '.' decimal sep */
/* #define SEXP_USE_PATCH_NON_DECIMAL_NUMERIC_FORMATS 0 */
/* uncomment this if you don't need extended math operations */
/* This includes the trigonometric and expt functions. */
/* Automatically disabled if you've disabled flonums. */
/* #define SEXP_USE_MATH 0 */
/* uncomment this to enable lenient matching of top-level bindings */
/* Historically, to match behavior with some other Schemes and in */
/* hopes of making it easier to use macros and modules, Chibi allowed */
/* top-level bindings with the same underlying symbol name to match */
/* with identifier=?. In particular, there still isn't a good way */
/* to handle the case where auxiliary syntax conflicts with some other */
/* binding without renaming one or the other (though SRFI 206 helps). */
/* However, if people make use of this you can write Chibi programs */
/* which don't work portably in other implementations, which has been */
/* a source of confusion, so the default has reverted to strict R7RS. */
/* #define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0 */
/* uncomment this to disable warning about references to undefined variables */
/* This is something of a hack, but can be quite useful. */
/* It's very fast and doesn't involve any separate analysis */
@ -231,11 +180,6 @@
/* uncomment this to disable extended char names as defined in R7RS */
/* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */
/* uncomment this to disable R7RS #<n>= and #<n># reader labels in source */
/* The (scheme read) and (scheme write) libraries always support */
/* this regardless. */
/* #define SEXP_USE_READER_LABELS 0 */
/* uncomment this to disable UTF-8 string support */
/* The default settings store strings in memory as UTF-8, */
/* and assumes strings passed to/from the C FFI are UTF-8. */
@ -246,32 +190,10 @@
/* Making them immutable allows for packed UTF-8 strings. */
/* #define SEXP_USE_MUTABLE_STRINGS 0 */
/* uncomment this to enable precomputed index->cursor tables for strings */
/* This makes string-ref faster at the expensive of making string */
/* construction (including string-append and I/O) slower. */
/* You can configure with SEXP_STRING_INDEX_TABLE_CHUNK_SIZE below, */
/* the default is caching every 64th index (<=12.5% string overhead). */
/* With a minimum of 1 you'd have up to 8x string overhead, and */
/* string-ref would still be slightly slower than string-cursors, */
/* and string-append would be marginally slower as well. */
/* */
/* In practice, the overhead of iterating over a string with */
/* string-ref isn't noticeable until about 10k chars. Times */
/* for iteration using the different approaches: */
/* */
/* impl\len 1000 10000 100000 1000000 */
/* string-ref (utf8) 1 97 9622 x */
/* string-ref (fast) 0 2 19 216 */
/* cursor-ref (srfi 130) 0 4 18 150 */
/* text-ref (srfi 135) 2 27 211 2006 */
/* */
/* #define SEXP_USE_STRING_INDEX_TABLE 1 */
/* uncomment this to cache a string cursor for string-ref calls */
/* The default is not to use a cache. The goal of caching is to */
/* soften the performance impact of repeated O(n) string-ref */
/* operations on the same string. */
/* #define SEXP_USE_STRING_REF_CACHE 1 */
/* uncomment this to base string ports on C streams */
/* This historic option enables string and custom ports backed */
/* by FILE* objects using memstreams and funopen/fopencookie. */
/* #define SEXP_USE_STRING_STREAMS 1 */
/* uncomment this to disable automatic closing of ports */
/* If enabled, the underlying FILE* for file ports will be */
@ -279,10 +201,11 @@
/* apply to stdin/stdout/stderr. */
/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */
/* uncomment this to use a 2010/01/01 epoch */
/* By default chibi uses the normal 1970 unix epoch in accordance */
/* with R7RS, but this can represent more times as fixnums. */
/* #define SEXP_USE_2010_EPOCH 1 */
/* uncomment this to use the normal 1970 unix epoch */
/* By default chibi uses an datetime epoch starting at */
/* 2010/01/01 00:00:00 in order to be able to represent */
/* more common times as fixnums. */
/* #define SEXP_USE_2010_EPOCH 0 */
/* uncomment this to disable stack overflow checks */
/* By default stacks are fairly small, so it's good to leave */
@ -301,7 +224,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 */
@ -327,15 +250,6 @@
#define SEXP_GROW_HEAP_RATIO 0.75
#endif
/* how much to expand the heap size by */
#ifndef SEXP_GROW_HEAP_FACTOR
#define SEXP_GROW_HEAP_FACTOR 2 /* 1.6180339887498948482 */
#endif
/* size of per-context stack that is used during gc cycles
* increase if you can affort extra unused memory */
#define SEXP_MARK_STACK_COUNT 1024
/* the default number of opcodes to run each thread for */
#ifndef SEXP_DEFAULT_QUANTUM
#define SEXP_DEFAULT_QUANTUM 500
@ -345,21 +259,12 @@
#define SEXP_MAX_ANALYZE_DEPTH 8192
#endif
/* The size of flexible arrays (empty arrays at the end of a struct */
/* representing the trailing data), when compiled with C++. Technically */
/* 0 is an illegal value here, and the C++ idiom is to use 1, but this */
/* breaks compatibility with C when computing the size of structs, and */
/* in practice all of the major C++ compilers support 0. */
#ifndef SEXP_FLEXIBLE_ARRAY_SIZE
#define SEXP_FLEXIBLE_ARRAY_SIZE 0
#endif
/************************************************************************/
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
/************************************************************************/
#ifndef SEXP_64_BIT
#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) || defined(__mips64__) || defined(__sparc64__) || defined(__arm64)
#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__)
#define SEXP_64_BIT 1
#else
#define SEXP_64_BIT 0
@ -375,51 +280,6 @@
#endif
#endif
/* Detect specific BSD */
#if SEXP_BSD
#if defined(__APPLE__)
#define SEXP_DARWIN 1
#define SEXP_FREEBSD 0
#define SEXP_NETBSD 0
#define SEXP_DRAGONFLY 0
#define SEXP_OPENBSD 0
#elif defined(__FreeBSD__)
#define SEXP_DARWIN 0
#define SEXP_FREEBSD 1
#define SEXP_NETBSD 0
#define SEXP_DRAGONFLY 0
#define SEXP_OPENBSD 0
#elif defined(__NetBSD__)
#define SEXP_DARWIN 0
#define SEXP_FREEBSD 0
#define SEXP_NETBSD 1
#define SEXP_DRAGONFLY 0
#define SEXP_OPENBSD 0
#elif defined(__DragonFly__)
#define SEXP_DARWIN 0
#define SEXP_FREEBSD 0
#define SEXP_NETBSD 0
#define SEXP_DRAGONFLY 1
#define SEXP_OPENBSD 0
#elif defined(__OpenBSD__)
#define SEXP_DARWIN 0
#define SEXP_FREEBSD 0
#define SEXP_NETBSD 0
#define SEXP_DRAGONFLY 0
#define SEXP_OPENBSD 1
#endif
#endif
/* for bignum support, need a double long to store long*long */
/* gcc supports uint128_t, otherwise we need a custom struct */
#ifndef SEXP_USE_CUSTOM_LONG_LONGS
#if SEXP_64_BIT && !defined(__GNUC__)
#define SEXP_USE_CUSTOM_LONG_LONGS 1
#else
#define SEXP_USE_CUSTOM_LONG_LONGS 0
#endif
#endif
#ifndef SEXP_USE_NO_FEATURES
#define SEXP_USE_NO_FEATURES 0
#endif
@ -428,19 +288,9 @@
#define SEXP_USE_PEDANTIC 0
#endif
/* this ensures public structs and enums are unchanged by feature toggles. */
/* should generally be left at 1. */
#ifndef SEXP_USE_STABLE_ABI
#define SEXP_USE_STABLE_ABI 1
#endif
#ifndef SEXP_USE_GREEN_THREADS
#if defined(_WIN32)
#define SEXP_USE_GREEN_THREADS 0
#else
#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES
#endif
#endif
#ifndef SEXP_USE_DEBUG_THREADS
#define SEXP_USE_DEBUG_THREADS 0
@ -471,28 +321,15 @@
#endif
#ifndef SEXP_USE_DL
#if defined(PLAN9)
#if defined(PLAN9) || defined(_WIN32)
#define SEXP_USE_DL 0
#else
#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
#endif
#endif
#ifndef SEXP_USE_STATIC_LIBS_EMPTY
#define SEXP_USE_STATIC_LIBS_EMPTY 0
#endif
#ifndef SEXP_USE_STATIC_LIBS
#define SEXP_USE_STATIC_LIBS SEXP_USE_STATIC_LIBS_EMPTY
#endif
/* don't include clibs.c - include separately or link */
#ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
#if defined(PLAN9) || SEXP_USE_STATIC_LIBS_EMPTY
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 0
#else
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 1
#endif
#define SEXP_USE_STATIC_LIBS 0
#endif
#ifndef SEXP_USE_FULL_SOURCE_INFO
@ -507,21 +344,9 @@
#define SEXP_USE_BOEHM 0
#endif
#ifdef SEXP_USE_UNIFY_FILENOS_BY_NUMBER
#define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 0
#endif
#ifndef SEXP_USE_WEAK_REFERENCES
#if SEXP_USE_UNIFY_FILENOS_BY_NUMBER
#define SEXP_USE_WEAK_REFERENCES 1
#else
#define SEXP_USE_WEAK_REFERENCES ! SEXP_USE_NO_FEATURES
#endif
#endif
#ifndef SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
#define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 0
#endif
#ifndef SEXP_USE_MALLOC
#define SEXP_USE_MALLOC 0
@ -539,14 +364,6 @@
#define SEXP_USE_DEBUG_GC 0
#endif
#ifndef SEXP_USE_TIME_GC
#if SEXP_USE_DEBUG_GC > 0 || defined(__linux) || SEXP_BSD
#define SEXP_USE_TIME_GC 1
#else
#define SEXP_USE_TIME_GC 0
#endif
#endif
#ifndef SEXP_USE_SAFE_GC_MARK
#define SEXP_USE_SAFE_GC_MARK SEXP_USE_DEBUG_GC > 1
#endif
@ -555,10 +372,6 @@
#define SEXP_USE_CONSERVATIVE_GC 0
#endif
#ifndef SEXP_USE_FINALIZERS
#define SEXP_USE_FINALIZERS 1
#endif
#ifndef SEXP_USE_TRACK_ALLOC_SOURCE
#define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
#endif
@ -567,18 +380,6 @@
#define SEXP_USE_TRACK_ALLOC_BACKTRACE SEXP_USE_TRACK_ALLOC_SOURCE
#endif
#ifndef SEXP_USE_TRACK_ALLOC_TIMES
#define SEXP_USE_TRACK_ALLOC_TIMES 0
#endif
#ifndef SEXP_USE_TRACK_ALLOC_SIZES
#define SEXP_USE_TRACK_ALLOC_SIZES 0
#endif
#ifndef SEXP_ALLOC_HISTOGRAM_BUCKETS
#define SEXP_ALLOC_HISTOGRAM_BUCKETS 32
#endif
#ifndef SEXP_BACKTRACE_SIZE
#define SEXP_BACKTRACE_SIZE 3
#endif
@ -616,7 +417,7 @@
#endif
#ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 1
#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
#endif
#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
@ -690,10 +491,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
@ -710,27 +507,15 @@
#define SEXP_USE_OBJECT_BRACE_LITERALS (SEXP_USE_TYPE_DEFS && !SEXP_USE_NO_FEATURES)
#endif
/* Dangerous without shared object detection. */
#ifndef SEXP_USE_TYPE_PRINTERS
#define SEXP_USE_TYPE_PRINTERS SEXP_USE_OBJECT_BRACE_LITERALS
#endif
#ifndef SEXP_USE_UNIFORM_VECTOR_LITERALS
#define SEXP_USE_UNIFORM_VECTOR_LITERALS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
#define SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS ! SEXP_USE_NO_FEATURES
#define SEXP_USE_TYPE_PRINTERS 0
#endif
#ifndef SEXP_USE_BYTEVECTOR_LITERALS
#define SEXP_USE_BYTEVECTOR_LITERALS SEXP_USE_UNIFORM_VECTOR_LITERALS
#define SEXP_USE_BYTEVECTOR_LITERALS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_BYTEVECTOR_HEX_LITERALS
#define SEXP_BYTEVECTOR_HEX_LITERALS SEXP_USE_BYTEVECTOR_LITERALS
#endif
#ifndef SEXP_USE_SELF_PARAMETER
#define SEXP_USE_SELF_PARAMETER 1
#endif
@ -783,10 +568,6 @@
#define SEXP_USE_EXTENDED_CHAR_NAMES ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_READER_LABELS
#define SEXP_USE_READER_LABELS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_UTF8_STRINGS
#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES
#endif
@ -802,20 +583,8 @@
#define SEXP_USE_PACKED_STRINGS 1
#endif
#if SEXP_USE_PACKED_STRINGS
#define SEXP_USE_STRING_INDEX_TABLE 0
#endif
#ifndef SEXP_USE_STRING_INDEX_TABLE
#define SEXP_USE_STRING_INDEX_TABLE 0
#endif
/* for every chunk_size indexes store the precomputed offset */
#ifndef SEXP_STRING_INDEX_TABLE_CHUNK_SIZE
#define SEXP_STRING_INDEX_TABLE_CHUNK_SIZE 64
#endif
#ifndef SEXP_USE_DISJOINT_STRING_CURSORS
#define SEXP_USE_DISJOINT_STRING_CURSORS SEXP_USE_UTF8_STRINGS
#ifndef SEXP_USE_STRING_STREAMS
#define SEXP_USE_STRING_STREAMS 0
#endif
#ifndef SEXP_USE_AUTOCLOSE_PORTS
@ -823,11 +592,7 @@
#endif
#ifndef SEXP_USE_GC_FILE_DESCRIPTORS
#ifdef PLAN9
#define SEXP_USE_GC_FILE_DESCRIPTORS 0
#else
#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM)
#endif
#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM && !defined(PLAN9))
#endif
#ifndef SEXP_USE_BIDIRECTIONAL_PORTS
@ -843,7 +608,7 @@
#endif
#ifndef SEXP_USE_2010_EPOCH
#define SEXP_USE_2010_EPOCH 0
#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_EPOCH_OFFSET
@ -880,10 +645,6 @@
#define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000
#endif
#ifndef SEXP_MAX_VECTOR_LENGTH
#define SEXP_MAX_VECTOR_LENGTH (SEXP_MAX_FIXNUM >> 1)
#endif
#ifndef SEXP_DEFAULT_EQUAL_DEPTH
#define SEXP_DEFAULT_EQUAL_DEPTH 10000
#endif
@ -892,21 +653,8 @@
#define SEXP_DEFAULT_EQUAL_BOUND 100000000
#endif
#ifndef SEXP_DEFAULT_WRITE_BOUND
#define SEXP_DEFAULT_WRITE_BOUND 10000
#endif
#ifndef SEXP_STRIP_SYNCLOS_BOUND
#define SEXP_STRIP_SYNCLOS_BOUND 10000
#endif
#ifndef SEXP_POLL_SLEEP_TIME
#define SEXP_POLL_SLEEP_TIME 5000
#define SEXP_POLL_SLEEP_TIME_MS 5
#endif
#ifndef SEXP_USE_IMAGE_LOADING
#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && SEXP_64_BIT && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_UNSAFE_PUSH
@ -944,17 +692,13 @@
#endif
#ifndef SEXP_USE_ALIGNED_BYTECODE
#if defined(__arm__) || defined(__sparc__) || defined(__sparc64__) || defined(__mips__) || defined(__mips64__)
#if defined(__arm__)
#define SEXP_USE_ALIGNED_BYTECODE 1
#else
#define SEXP_USE_ALIGNED_BYTECODE 0
#endif
#endif
#ifndef SEXP_USE_SIGNED_SHIFTS
#define SEXP_USE_SIGNED_SHIFTS 0
#endif
#ifdef PLAN9
#define strcasecmp cistrcmp
#define strncasecmp cistrncmp
@ -964,17 +708,6 @@
#define isinf(x) (isInf(x,1) || isInf(x,-1))
#define isnan(x) isNaN(x)
#elif defined(_WIN32)
#define SHUT_RD 0 /* SD_RECEIVE */
#define SHUT_WR 1 /* SD_SEND */
#define SHUT_RDWR 2 /* SD_BOTH */
#ifdef _MSC_VER
#define _CRT_SECURE_NO_WARNINGS 1
#define _CRT_NONSTDC_NO_DEPRECATE 1
#define _USE_MATH_DEFINES /* For M_LN10 */
#define strcasecmp _stricmp
#define strncasecmp _strnicmp
#pragma warning(disable:4146) /* unary minus operator to unsigned type */
#if _MSC_VER < 1900
#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val)
#define strcasecmp lstrcmpi
#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2)
@ -983,10 +716,6 @@
#define isnan(x) (x!=x)
#define isinf(x) (x > DBL_MAX || x < -DBL_MAX)
#endif
#elif !defined(__MINGW32__)
#error Unknown Win32 compiler!
#endif
#endif
#ifdef _WIN32
#define sexp_pos_infinity (DBL_MAX*DBL_MAX)
@ -1002,16 +731,12 @@
#define sexp_nan (0.0/0.0)
#endif
#ifdef _WIN32
#ifdef SEXP_STATIC_LIBRARY
#define SEXP_API extern
#else
#ifdef __MINGW32__
#ifdef BUILDING_DLL
#define SEXP_API __declspec(dllexport)
#else
#define SEXP_API __declspec(dllimport)
#endif
#endif
#else
#define SEXP_API extern
#endif

105
include/chibi/gc_heap.h
View file

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

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@"

92
include/chibi/sexp-hufftabs.h
View file

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

839
include/chibi/sexp.h Normal file → Executable file
View file

File diff suppressed because it is too large Load diff

4
js/exported_functions.json
View file

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

116
js/index.html
View file

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

2
js/post.js
View file

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

6
js/pre.js
View file

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

72
lib/chibi/accept.c
View file

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

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

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

447
lib/chibi/app.scm
View file

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

3
lib/chibi/app.sld
View file

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

33
lib/chibi/apropos.scm
View file

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

4
lib/chibi/apropos.sld
View file

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

30
lib/chibi/assert-test.sld
View file

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

115
lib/chibi/assert.sld
View file

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

298
lib/chibi/ast.c
View file

@ -1,35 +1,13 @@
/* ast.c -- interface to the Abstract Syntax Tree */
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include <chibi/eval.h>
#ifndef PLAN9
#include <stdlib.h>
#include <errno.h>
#endif
#ifdef _WIN32
#if defined(__MINGW32__) || defined(__MINGW64__)
/* Workaround MinGW header implementation */
errno_t getenv_s(size_t*, char*, size_t, const char*);
#endif
int setenv(const char *name, const char *value, int overwrite)
{
int errcode = 0;
if (!overwrite) {
size_t envsize = 0;
errcode = getenv_s(&envsize, NULL, 0, name);
if (errcode || envsize) return errcode;
}
return _putenv_s(name, value);
}
int unsetenv(const char *name)
{
return setenv(name, "", 1);
}
#endif
#if ! SEXP_USE_BOEHM
extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
#endif
@ -62,7 +40,7 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
sexp_gc_release2(ctx);
}
sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
sexp cell;
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
cell = sexp_env_cell(ctx, env, id, 0);
@ -72,55 +50,33 @@ sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, s
id = sexp_synclo_expr(id);
}
cell = sexp_env_cell(ctx, env, id, 0);
if (!cell && sexp_truep(createp))
if (!cell && createp)
cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
}
return cell ? cell : SEXP_FALSE;
}
sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
static sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return sexp_procedure_code(proc);
}
sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
static sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return sexp_procedure_vars(proc);
}
sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
static sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return sexp_make_fixnum(sexp_procedure_num_args(proc));
}
sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
static sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return sexp_make_boolean(sexp_procedure_variadic_p(proc));
}
sexp sexp_get_procedure_variable_transformer_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return sexp_make_boolean(sexp_procedure_variable_transformer_p(proc));
}
sexp sexp_get_procedure_flags (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return (sexp) (sexp_uint_t) sexp_procedure_flags(proc);
}
sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) {
sexp flags;
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc);
if (sexp_procedure_variable_transformer_p(base_proc))
return base_proc;
flags = sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER);
return sexp_make_procedure(ctx, flags,
sexp_make_fixnum(sexp_procedure_num_args(base_proc)),
sexp_procedure_code(base_proc),
sexp_procedure_vars(base_proc));
}
sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
if (! sexp_opcodep(op))
return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
else if (! sexp_opcode_name(op))
@ -147,7 +103,7 @@ static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
return res;
}
sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
sexp res;
if (!op)
return sexp_type_by_index(ctx, SEXP_OBJECT);
@ -161,7 +117,7 @@ sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
return sexp_translate_opcode_type(ctx, res);
}
sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
sexp res;
int p = sexp_unbox_fixnum(k);
if (! sexp_opcodep(op))
@ -180,7 +136,7 @@ sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, se
default:
res = sexp_opcode_arg3_type(op);
if (res && sexp_vectorp(res)) {
if (sexp_vector_length(res) > (unsigned)(sexp_unbox_fixnum(k)-2))
if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
else
res = sexp_type_by_index(ctx, SEXP_OBJECT);
@ -190,17 +146,17 @@ sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, se
return sexp_translate_opcode_type(ctx, res);
}
sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
return sexp_make_fixnum(sexp_opcode_class(op));
}
sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
return sexp_make_fixnum(sexp_opcode_code(op));
}
sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
sexp data;
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
data = sexp_opcode_data(op);
@ -211,41 +167,29 @@ sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
}
sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
return sexp_make_fixnum(sexp_opcode_num_args(op));
}
sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
return sexp_make_boolean(sexp_opcode_variadic_p(op));
}
sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
static sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
return sexp_make_fixnum(sexp_port_line(p));
}
sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
static sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
sexp_port_line(p) = sexp_unbox_fixnum(i);
return SEXP_VOID;
}
sexp sexp_get_port_sourcep (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
return sexp_make_boolean(sexp_port_sourcep(p));
}
sexp sexp_set_port_sourcep (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp b) {
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
sexp_assert_type(ctx, sexp_booleanp, SEXP_BOOLEAN, b);
sexp_port_sourcep(p) = sexp_truep(b);
return SEXP_VOID;
}
sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
if (!x)
return sexp_type_by_index(ctx, SEXP_OBJECT);
if (sexp_pointerp(x))
@ -268,43 +212,41 @@ sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
return sexp_type_by_index(ctx, SEXP_OBJECT);
}
sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp e2) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1);
if (sexp_truep(e2)) sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2);
sexp_env_parent(e1) = e2;
return SEXP_VOID;
static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
}
sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
static sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
}
sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
sexp_env_lambda(e) = lam;
return SEXP_VOID;
}
sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
return sexp_make_boolean(sexp_env_syntactic_p(e));
}
sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
sexp_env_syntactic_p(e) = sexp_truep(synp);
return SEXP_VOID;
}
sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
return sexp_env_cell_define(ctx, env, name, value, NULL);
}
sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
sexp_gc_var1(tmp);
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
@ -314,45 +256,38 @@ sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name,
return SEXP_VOID;
}
sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
return sexp_make_fixnum(sexp_core_code(c));
}
sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
return sexp_type_name(t);
}
sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
static sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
return sexp_type_cpl(t);
}
sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
static sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
return sexp_type_slots(t);
}
sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t))
: sexp_make_fixnum(sexp_type_field_eq_len_base(t));
}
sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE;
}
sexp sexp_type_printer_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp t, sexp p) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, p);
sexp_type_print(t) = p;
return SEXP_VOID;
}
sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
sexp t;
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
return SEXP_ZERO;
@ -360,40 +295,15 @@ sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
return sexp_make_fixnum(sexp_type_size_of_object(t, x));
}
sexp sexp_immutablep_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
return sexp_pointerp(x) ? sexp_make_boolean(sexp_immutablep(x)) : SEXP_TRUE;
}
sexp sexp_immutable_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp s) {
sexp res;
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, s);
#if SEXP_USE_PACKED_STRINGS
/* no sharing with packed strings */
res = sexp_c_string(ctx, sexp_string_data(s), sexp_string_size(s));
#else
res = sexp_alloc_type(ctx, string, SEXP_STRING);
sexp_string_bytes(res) = sexp_string_bytes(s);
sexp_string_offset(res) = sexp_string_offset(s);
sexp_string_size(res) = sexp_string_size(s);
sexp_copy_on_writep(s) = 1;
#endif
sexp_immutablep(res) = 1;
return res;
}
sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
sexp x = (sexp)sexp_unbox_fixnum(i);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
if (!x || sexp_pointerp(x))
if (sexp_pointerp(x))
return dflt;
return x;
}
sexp sexp_object_to_integer (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
return sexp_make_integer(ctx, (sexp_uint_t)x);
}
sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
sexp_lambda_name(res) = name;
sexp_lambda_params(res) = params;
@ -407,7 +317,7 @@ sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp pa
return res;
}
sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
sexp_lambda_name(res) = sexp_lambda_name(lambda);
sexp_lambda_params(res) = sexp_lambda_params(lambda);
@ -421,21 +331,21 @@ sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
return res;
}
sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
static sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
sexp_set_var(res) = var;
sexp_set_value(res) = value;
return res;
}
sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
static sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
sexp_ref_name(res) = name;
sexp_ref_cell(res) = cell;
return res;
}
sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
sexp_cnd_test(res) = test;
sexp_cnd_pass(res) = pass;
@ -443,26 +353,26 @@ sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass,
return res;
}
sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
static sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
sexp res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
sexp_seq_ls(res) = ls;
return res;
}
sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
sexp_lit_value(res) = value;
return res;
}
sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO);
sexp_macro_proc(res) = proc;
sexp_macro_env(res) = env;
return res;
}
sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
sexp ctx2 = ctx;
if (sexp_envp(e)) {
ctx2 = sexp_make_child_context(ctx, NULL);
@ -471,12 +381,12 @@ sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
return sexp_analyze(ctx2, x);
}
sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
return sexp_extend_env(ctx, env, vars, value);
}
sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
sexp_gc_var2(ls, res);
sexp_gc_preserve2(ctx, ls, res);
res = x;
@ -488,7 +398,7 @@ sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
return res;
}
sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
size_t sum_freed=0;
#if SEXP_USE_BOEHM
GC_gcollect();
@ -498,34 +408,20 @@ sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
return sexp_make_unsigned_integer(ctx, sum_freed);
}
sexp sexp_gc_count_op (sexp ctx, sexp self, sexp_sint_t n) {
return sexp_make_unsigned_integer(ctx, sexp_context_gc_count(ctx));
}
sexp sexp_gc_usecs_op (sexp ctx, sexp self, sexp_sint_t n) {
return sexp_make_unsigned_integer(ctx, sexp_context_gc_usecs(ctx));
}
#if SEXP_USE_GREEN_THREADS
sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P);
sexp_global(ctx, SEXP_G_ATOMIC_P) = new_val;
sexp_global(ctx, SEXP_G_ATOMIC_P) = new;
return res;
}
#endif
sexp sexp_thread_interrupt (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
sexp_context_interruptp(thread) = 1;
return sexp_make_boolean(ctx == thread);
}
sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
sexp ls;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = SEXP_NULL;
#if SEXP_USE_GREEN_THREADS
sexp ls;
for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls));
for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
@ -536,49 +432,15 @@ sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
return res;
}
sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y, sexp start) {
static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
const char *res;
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
sexp_assert_type(ctx, sexp_string_cursorp, SEXP_STRING_CURSOR, start);
if (sexp_unbox_string_cursor(start) > sexp_string_size(x))
return sexp_user_exception(ctx, self, "string-contains: start out of range", start);
res = strstr(sexp_string_data(x) + sexp_unbox_string_cursor(start), sexp_string_data(y));
return res ? sexp_make_string_cursor(res-sexp_string_data(x)) : SEXP_FALSE;
res = strstr(sexp_string_data(x), sexp_string_data(y));
return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE;
}
sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dst);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, src);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sfrom);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sstart);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
if (from < 0 || from > to)
return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
if (start < 0 || start > (sexp_sint_t)sexp_string_size(src))
return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
if (end < start || end > (sexp_sint_t)sexp_string_size(src))
return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
pfrom = (unsigned char*)sexp_string_data(dst) + from;
pto = (unsigned char*)sexp_string_data(dst) + to;
pstart = (unsigned char*)sexp_string_data(src) + start;
pend = (unsigned char*)sexp_string_data(src) + end;
for ( ; pfrom < pto && pstart < pend; ++pfrom, ++pstart)
*pfrom = *pstart;
/* adjust for incomplete trailing chars */
prev = (unsigned char*)sexp_string_utf8_prev(pfrom);
if (sexp_utf8_initial_byte_count(*prev) > pfrom - prev) {
for (p = prev; p < pfrom; ++p)
*p = '\0';
pstart -= pfrom - prev;
}
return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
}
sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
#ifdef PLAN9
return SEXP_FALSE;
#else
@ -586,7 +448,7 @@ sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
#endif
}
sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
#ifdef PLAN9
return SEXP_FALSE;
#else
@ -601,32 +463,25 @@ sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
#endif
}
sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
static sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
return sexp_free_vars(ctx, x, SEXP_NULL);
}
sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
static sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
}
sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
return sexp_make_boolean(unsetenv(sexp_string_data(name)));
}
sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
sexp_exception_message(res) = SEXP_TRAMPOLINE;
return res;
}
#define sexp_define_type(ctx, name, tag) \
sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag));
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
sexp_gc_var2(sym, str);
if (!(sexp_version_compatible(ctx, version, sexp_version)
&& sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
return SEXP_ABI_ERROR;
@ -659,7 +514,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
sexp_define_type(ctx, "Cnd", SEXP_CND);
sexp_define_type(ctx, "Set", SEXP_SET);
sexp_define_type(ctx, "Set-Syn", SEXP_SET_SYN);
sexp_define_type(ctx, "Ref", SEXP_REF);
sexp_define_type(ctx, "Seq", SEXP_SEQ);
sexp_define_type(ctx, "Lit", SEXP_LIT);
@ -677,6 +531,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);
@ -700,28 +555,22 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!");
sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!");
sexp_define_accessors(ctx, env, SEXP_SET, 2, "set-source", "set-source-set!");
sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!");
sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!");
sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!");
sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 0, "bytecode-name", "bytecode-name-set!");
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-literals", NULL);
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-source", NULL);
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-name", "bytecode-name-set!");
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-literals", NULL);
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 4, "bytecode-source", NULL);
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL);
sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL);
sexp_define_accessors(ctx, env, SEXP_MACRO, 1, "macro-env", NULL);
sexp_define_accessors(ctx, env, SEXP_MACRO, 2, "macro-source", NULL);
sexp_define_accessors(ctx, env, SEXP_MACRO, 3, "macro-aux", "macro-aux-set!");
sexp_define_foreign(ctx, env, "make-procedure", 4, sexp_make_procedure_op);
sexp_define_foreign(ctx, env, "procedure-code", 1, sexp_get_procedure_code);
sexp_define_foreign(ctx, env, "procedure-vars", 1, sexp_get_procedure_vars);
sexp_define_foreign(ctx, env, "procedure-arity", 1, sexp_get_procedure_arity);
sexp_define_foreign(ctx, env, "procedure-variadic?", 1, sexp_get_procedure_variadic_p);
sexp_define_foreign(ctx, env, "procedure-variable-transformer?", 1, sexp_get_procedure_variable_transformer_p);
sexp_define_foreign(ctx, env, "procedure-flags", 1, sexp_get_procedure_flags);
sexp_define_foreign(ctx, env, "make-variable-transformer", 1, sexp_make_variable_transformer_op);
sexp_define_foreign(ctx, env, "copy-lambda", 1, sexp_copy_lambda);
sexp_define_foreign_opt(ctx, env, "make-lambda", 4, sexp_make_lambda_op, SEXP_NULL);
sexp_define_foreign_opt(ctx, env, "make-cnd", 3, sexp_make_cnd_op, SEXP_VOID);
@ -744,15 +593,12 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
sexp_define_foreign(ctx, env, "port-line", 1, sexp_get_port_line);
sexp_define_foreign(ctx, env, "port-line-set!", 2, sexp_set_port_line);
sexp_define_foreign(ctx, env, "port-source?", 1, sexp_get_port_sourcep);
sexp_define_foreign(ctx, env, "port-source?-set!", 2, sexp_set_port_sourcep);
sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of);
sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op);
sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op);
sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op);
sexp_define_foreign(ctx, env, "type-num-slots", 1, sexp_type_num_slots_op);
sexp_define_foreign(ctx, env, "type-printer", 1, sexp_type_printer_op);
sexp_define_foreign(ctx, env, "type-printer-set!", 2, sexp_type_printer_set_op);
sexp_define_foreign(ctx, env, "env-parent-set!", 2, sexp_env_parent_set_op);
sexp_define_foreign(ctx, env, "env-lambda", 1, sexp_env_lambda_op);
sexp_define_foreign(ctx, env, "env-lambda-set!", 2, sexp_env_lambda_set_op);
@ -762,31 +608,17 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
sexp_define_foreign(ctx, env, "immutable?", 1, sexp_immutablep_op);
sexp_define_foreign(ctx, env, "immutable-string", 1, sexp_immutable_string_op);
sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
sexp_define_foreign_opt(ctx, env, "object->integer", 1, sexp_object_to_integer, SEXP_FALSE);
sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
sexp_define_foreign(ctx, env, "gc-count", 0, sexp_gc_count_op);
sexp_define_foreign(ctx, env, "gc-usecs", 0, sexp_gc_usecs_op);
#if SEXP_USE_GREEN_THREADS
sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
#endif
sexp_define_foreign(ctx, env, "%thread-interrupt!", 1, sexp_thread_interrupt);
sexp_define_foreign(ctx, env, "thread-list", 0, sexp_thread_list);
sexp_define_foreign_opt(ctx, env, "string-contains", 3, sexp_string_contains, sexp_make_string_cursor(0));
sexp_define_foreign(ctx, env, "string-cursor-copy!", 5, sexp_string_cursor_copy);
sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
sexp_define_foreign(ctx, env, "errno", 0, sexp_errno);
sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv);
sexp_define_foreign(ctx, env, "unsetenv", 1, sexp_unsetenv);
sexp_define_foreign(ctx, env, "abort", 1, sexp_abort);
sexp_gc_preserve2(ctx, sym, str);
sym = sexp_intern(ctx, "chibi-version", -1);
str = sexp_c_string(ctx, sexp_version, -1);
sexp_immutablep(str) = 1;
sexp_env_define(ctx, env, sym, str);
sexp_gc_release2(ctx);
return SEXP_VOID;
}

119
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
@ -149,32 +121,32 @@
;;> used in the \scheme{match} \scheme{($ ...)} syntax.
;;> \itemlist[
;;> \item{\scheme{Object} - the parent of all types}
;;> \item{\scheme{Number} - abstract numeric type}
;;> \item{\scheme{Bignum} - arbitrary precision exact integers}
;;> \item{\scheme{Flonum} - inexact real numbers}
;;> \item{\scheme{Integer} - abstract integer type}
;;> \item{\scheme{Symbol} - symbols}
;;> \item{\scheme{Char} - character}
;;> \item{\scheme{Boolean} - \scheme{#t} or \scheme{#f}}
;;> \item{\scheme{String} - strings of characters}
;;> \item{\scheme{Byte-Vector} - uniform vector of octets}
;;> \item{\scheme{Pair} - a \var{car} and \var{cdr}, the basis for lists}
;;> \item{\scheme{Vector} - vectors}
;;> \item{\scheme{Opcode} - a primitive opcode or C function}
;;> \item{\scheme{Procedure} - a closure}
;;> \item{\scheme{Bytecode} - the compiled code for a closure}
;;> \item{\scheme{Env} - an environment structure}
;;> \item{\scheme{Macro} - a macro object, usually not first-class}
;;> \item{\scheme{Lam} - a lambda AST type}
;;> \item{\scheme{Cnd} - an conditional AST type (i.e. \scheme{if})}
;;> \item{\scheme{Ref} - a reference AST type}
;;> \item{\scheme{Set} - a mutation AST type (i.e. \scheme{set!})}
;;> \item{\scheme{Seq} - a sequence AST type}
;;> \item{\scheme{Lit} - a literal AST type}
;;> \item{\scheme{Sc} - a syntactic closure}
;;> \item{\scheme{Context} - a context object (including threads)}
;;> \item{\scheme{Exception} - an exception object}
;;> \item{\scheme{<object>} - the parent of all types}
;;> \item{\scheme{<number>} - abstract numeric type}
;;> \item{\scheme{<bignum>} - arbitrary precision exact integers}
;;> \item{\scheme{<flonum>} - inexact real numbers}
;;> \item{\scheme{<integer>} - abstract integer type}
;;> \item{\scheme{<symbol>} - symbols}
;;> \item{\scheme{<char>} - character}
;;> \item{\scheme{<boolean>} - \scheme{#t} or \scheme{#f}}
;;> \item{\scheme{<string>} - strings of characters}
;;> \item{\scheme{<byte-vector>} - uniform vector of octets}
;;> \item{\scheme{<pair>} - a \var{car} and \var{cdr}, the basis for lists}
;;> \item{\scheme{<vector>} - vectors}
;;> \item{\scheme{<opcode>} - a primitive opcode or C function}
;;> \item{\scheme{<procedure>} - a closure}
;;> \item{\scheme{<bytecode>} - the compiled code for a closure}
;;> \item{\scheme{<env>} - an environment structure}
;;> \item{\scheme{<macro>} - a macro object, usually not first-class}
;;> \item{\scheme{<lam>} - a lambda AST type}
;;> \item{\scheme{<cnd>} - an conditional AST type (i.e. \scheme{if})}
;;> \item{\scheme{<ref>} - a reference AST type}
;;> \item{\scheme{<set>} - a mutation AST type (i.e. \scheme{set!})}
;;> \item{\scheme{<seq>} - a sequence AST type}
;;> \item{\scheme{<lit>} - a literal AST type}
;;> \item{\scheme{<sc>} - a syntactic closure}
;;> \item{\scheme{<context>} - a context object (including threads)}
;;> \item{\scheme{<exception>} - an exception object}
;;> ]
;;> The following extended type predicates may also be used to test
@ -250,8 +222,6 @@
;;> \item{\scheme{(macro-procedure f)} - the macro procedure}
;;> \item{\scheme{(macro-env f)} - the environment the macro was defined in}
;;> \item{\scheme{(macro-source f)} - the source location the macro was defined in}
;;> \item{\scheme{(macro-aux f)} - custom auxiliary data stored with the macro}
;;> \item{\scheme{(macro-aux-set! f x)}}
;;> ]
;;> \subsection{Bytecode Objects}
@ -381,42 +351,11 @@
;;> Returns the interpretation of the integer \var{n} as
;;> an immediate object, useful for debugging.
;;> \procedure{(string-contains str pat [start])}
;;> \procedure{(string-contains str pat)}
;;> Returns the first string cursor of \var{pat} in \var{str},
;;> of \scheme{#f} if it's not found.
(cond-expand
(safe-string-cursors
(define orig-string-contains string-contains)
(set! string-contains
(lambda (str pat . o)
(let ((res
(if (pair? o)
(orig-string-contains str pat (string-cursor-where (car o)))
(orig-string-contains str pat))))
(and res (make-string-cursor str res (string-size str)))))))
(else
))
;;> \procedure{(string-cursor-copy! dst src from start end)}
;;> Copies the characters from \var{src}[\var{start}..\var{end}]
;;> to \var{dst} starting at \var{from}.
;;> \procedure{(safe-setenv name value)}
;;> Equivalent to \scheme{setenv} but does nothing and returns
;;> \scheme{#f} if \var{value} is a function definition. Used to
;;> circumvent the vulnerability of the shellshock bug.
(define (safe-setenv name value)
(define (function-def? str)
(and (> (string-size value) 5)
(equal? "() {" (substring value 0 4))))
(and (not (function-def? value))
(setenv name value)))
;;> \procedure{(atomically expr)}
;;> Run \var{expr} atomically, disabling yields. Ideally should only be
@ -436,7 +375,3 @@
(else
(define-syntax atomically
(syntax-rules () ((atomically . body) (begin . body))))))
(define (thread-interrupt! thread)
(if (%thread-interrupt! thread)
(yield!)))

29
lib/chibi/ast.sld
View file

@ -1,12 +1,11 @@
(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
Context Lam Cnd Set Set-Syn Ref Seq Lit Sc Exception Core
Context Lam Cnd Set Ref Seq Lit Sc Exception Core
syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core?
environment? bytecode? exception? macro? context? file-descriptor?
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
@ -21,29 +20,23 @@
lambda-source-set!
cnd-test cnd-pass cnd-fail
cnd-test-set! cnd-pass-set! cnd-fail-set!
set-var set-value set-var-set! set-value-set! set-source set-source-set!
set-var set-value set-var-set! set-value-set!
ref-name ref-cell ref-name-set! ref-cell-set!
seq-ls seq-ls-set! lit-value lit-value-set!
exception-kind exception-message exception-irritants exception-source
opcode-name opcode-num-params opcode-return-type opcode-param-type
opcode-class opcode-code opcode-data opcode-variadic? opcode?
macro-procedure macro-env macro-source macro-aux macro-aux-set!
opcode-class opcode-code opcode-data opcode-variadic?
macro-procedure macro-env macro-source
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?
bytecode-name bytecode-literals bytecode-source
port-line port-line-set! port-source? port-source?-set!
port-line port-line-set!
extend-env env-parent env-parent-set! env-lambda env-lambda-set!
env-define! env-push! env-syntactic? env-syntactic?-set! core-code
type-name type-cpl type-parent type-slots type-num-slots
type-printer type-printer-set!
object-size object->integer integer->immediate gc gc-usecs gc-count
atomically thread-list abort
string-contains string-cursor-copy! errno integer->error-string
flatten-dot update-free-vars! setenv unsetenv safe-setenv
immutable? immutable-string make-immutable!
thread-interrupt!
chibi-version)
type-name type-cpl type-parent type-slots type-num-slots type-printer
object-size integer->immediate gc atomically thread-list
string-contains errno integer->error-string
flatten-dot update-free-vars! setenv unsetenv)
(import (chibi))
(include-shared "ast")
(include "ast.scm"))

42
lib/chibi/base64-test.sld
View file

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

61
lib/chibi/base64.scm
View file

@ -141,18 +141,18 @@
dst
j
(bitwise-ior (arithmetic-shift b1 2)
(bit-field b2 4 6)))
(extract-bit-field 2 4 b2)))
(bytevector-u8-set!
dst
(+ j 1)
(bitwise-ior
(arithmetic-shift (bit-field b2 0 4) 4)
(bit-field b3 2 6)))
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
(extract-bit-field 4 2 b3)))
(bytevector-u8-set!
dst
(+ j 2)
(bitwise-ior
(arithmetic-shift (bit-field b3 0 2) 6)
(arithmetic-shift (extract-bit-field 2 0 b3) 6)
c))
(lp (+ i 1) (+ j 3)
*outside-char* *outside-char* *outside-char*)))))))
@ -172,7 +172,7 @@
(bytevector-u8-set! dst
j
(bitwise-ior (arithmetic-shift b1 2)
(bit-field b2 4 6)))
(extract-bit-field 2 4 b2)))
(cond
((eqv? b3 *outside-char*)
(+ j 1))
@ -180,8 +180,8 @@
(bytevector-u8-set! dst
(+ j 1)
(bitwise-ior
(arithmetic-shift (bit-field b2 0 4) 4)
(bit-field b3 2 6)))
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
(extract-bit-field 4 2 b3)))
(+ j 2))))))
;;> Variation of the above to read and write to ports.
@ -193,15 +193,14 @@
(current-output-port))))
(cond
((not (binary-port? in))
(let ((str (port->string in)))
(write-string (base64-decode-string str) out)))
(write-string (base64-decode-string (port->string in)) out))
(else
(let ((src (make-bytevector decode-src-length))
(dst (make-bytevector decode-dst-length)))
(let lp ((offset 0))
(let ((src-len
(+ offset
(read-bytevector! src in offset decode-src-length))))
(read-bytevector! decode-src-length src in offset))))
(cond
((= src-len decode-src-length)
;; read a full chunk: decode, write and loop
@ -210,12 +209,12 @@
(lambda (src-offset dst-len b1 b2 b3)
(cond
((and (< src-offset src-len)
(eqv? #x3D (bytevector-u8-ref src src-offset)))
(eqv? #\= (string-ref src src-offset)))
;; done
(let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
(write-bytevector dst out 0 dst-len)))
((eqv? b1 *outside-char*)
(write-bytevector dst out 0 dst-len)
(write-string dst out 0 dst-len)
(lp 0))
(else
(write-bytevector dst out 0 dst-len)
@ -238,7 +237,7 @@
src 0 src-len dst
(lambda (src-offset dst-len b1 b2 b3)
(let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
(write-bytevector dst out 0 dst-len)))))))))))))
(write-string dst out 0 dst-len)))))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; encoding
@ -259,7 +258,8 @@
res))
(define (base64-encode-bytevector! bv start end res)
(let ((limit (- end 2)))
(let* ((res-len (bytevector-length res))
(limit (- end 2)))
(let lp ((i start) (j 0))
(if (>= i limit)
(case (- end i)
@ -271,8 +271,7 @@
(+ j 1)
(enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
(bytevector-u8-set! res (+ j 2) (char->integer #\=))
(bytevector-u8-set! res (+ j 3) (char->integer #\=))
(+ j 4)))
(bytevector-u8-set! res (+ j 3) (char->integer #\=))))
((2)
(let ((b1 (bytevector-u8-ref bv i))
(b2 (bytevector-u8-ref bv (+ i 1))))
@ -282,15 +281,13 @@
(+ j 1)
(enc (bitwise-ior
(arithmetic-shift (bitwise-and #b11 b1) 4)
(bit-field b2 4 8))))
(extract-bit-field 4 4 b2))))
(bytevector-u8-set!
res
(+ j 2)
(enc (arithmetic-shift (bit-field b2 0 4) 2)))
(bytevector-u8-set! res (+ j 3) (char->integer #\=))
(+ j 4)))
(else
j))
(enc (arithmetic-shift (extract-bit-field 4 0 b2)
2)))
(bytevector-u8-set! res (+ j 3) (char->integer #\=)))))
(let ((b1 (bytevector-u8-ref bv i))
(b2 (bytevector-u8-ref bv (+ i 1)))
(b3 (bytevector-u8-ref bv (+ i 2))))
@ -300,13 +297,13 @@
(+ j 1)
(enc (bitwise-ior
(arithmetic-shift (bitwise-and #b11 b1) 4)
(bit-field b2 4 8))))
(extract-bit-field 4 4 b2))))
(bytevector-u8-set!
res
(+ j 2)
(enc (bitwise-ior
(arithmetic-shift (bit-field b2 0 4) 2)
(bit-field b3 6 8))))
(arithmetic-shift (extract-bit-field 4 0 b2) 2)
(extract-bit-field 2 6 b3))))
(bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
(lp (+ i 3) (+ j 4)))))))
@ -319,19 +316,17 @@
(current-output-port))))
(cond
((not (binary-port? in))
(let ((str (port->string in)))
(write-string (base64-encode-string str) out)))
(write-string (base64-encode-string (port->string in)) out))
(else
(let ((src (make-bytevector encode-src-length))
(dst (make-bytevector
(let ((src (make-string encode-src-length))
(dst (make-string
(arithmetic-shift (quotient encode-src-length 3) 2))))
(let lp ()
(let ((n (read-bytevector! src in 0 2048)))
(base64-encode-bytevector! src 0 n dst)
(write-bytevector dst out 0 (* 4 (quotient (+ n 2) 3)))
(write-bytevector dst out 0 (* 3 (quotient (+ n 3) 4)))
(if (= n 2048)
(lp)
(flush-output-port out)))))))))
(lp)))))))))
;;> Return a base64 encoded representation of the string \var{str} as
;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
@ -364,7 +359,7 @@
(string-append
prefix (substring str 0 first-max-col) "?=" nl "\t" prefix)
"")
(string-join (string-chop (substring str first-max-col len)
(string-concatenate (string-chop (substring str first-max-col len)
effective-max-col)
(string-append "?=" nl "\t" prefix))
"?=")))))

33
lib/chibi/base64.sld
View file

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

52
lib/chibi/binary-record-chicken.scm
View file

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

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

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

@ -1,160 +1,265 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Binary Records
;; Record types with user-specified binary formats.
;; A work in progress, but sufficient for tar files.
;;> \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 (assert-read-u8 in i)
(let ((i2 (read-u8 in)))
(if (not (eqv? i i2))
(error "unexpected value: " i i2)
i2)))
(define (assert-read-char in ch)
(let ((ch2 (read-char in)))
(if (not (eqv? ch ch2))
(error "unexpected value: " ch ch2)
ch2)))
(define (assert-read-string in s)
(let ((s2 (read-string (string-length s) in)))
(if (not (equal? s s2))
(error "unexpected value: " s s2)
s2)))
(define (assert-read-bytevector in bv)
(let ((bv2 (read-bytevector (bytevector-length bv) in)))
(if (not (equal? bv bv2))
(error "unexpected value: " bv bv2)
bv2)))
(define (assert-read-integer in len radix)
(let* ((s (string-trim (read-string len in)
(lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
(n (if (equal? s "") 0 (string->number s radix))))
(or n (error "invalid number syntax: " s))))
(define (read-padded-string in len pad)
(string-trim-right (read-string len in) pad))
(define (expand-read rename in spec)
(case (car spec)
((literal)
(let ((val (cadr spec)))
(cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
((char? val) `(,(rename 'assert-read-char) ,in ,val))
((string? val) `(,(rename 'assert-read-string) ,in ,val))
((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
(else (error "unknown binary literal: " val)))))
((octal)
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
((decimal)
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
((hexadecimal)
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
((fixed-string)
(let ((len (cadr spec)))
`(,(rename 'read-string) ,len ,in)))
((padded-string)
(let ((len (cadr spec))
(pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
`(,(rename 'read-padded-string) ,in ,len ,pad)))
(else
(error "unknown binary format: " spec))))
(define (string-pad-left str len . o)
(let ((diff (- len (string-length str)))
(pad-ch (if (pair? o) (car o) #\space)))
(if (positive? diff)
(string-append (make-string diff pad-ch) str)
str)))
(define (string-pad-right str len . o)
(let ((diff (- len (string-length str)))
(pad-ch (if (pair? o) (car o) #\space)))
(if (positive? diff)
(string-append str (make-string diff pad-ch))
str)))
(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
(let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch)))
(cond
((>= (string-length s) len)
(error "number too large for width" n radix len))
(else
(write-string s out)
(write-char right-pad-ch out)))))
(define (expand-write rename out val spec)
(let ((_if (rename 'if))
(_not (rename 'not))
(_let (rename 'let))
(_string-length (rename 'string-length))
(_write-string (rename 'write-string))
(_write-bytevector (rename 'write-bytevector))
(_error (rename 'error))
(_> (rename '>))
(_= (rename '=)))
(case (car spec)
((literal)
(let ((val (cadr spec)))
(cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
((char? val) `(,(rename 'write-char) ,val ,out))
((string? val) `(,_write-string ,val ,out))
((bytevector? val) `(,_write-bytevector ,val ,out))
(else (error "unknown binary literal: " val)))))
((octal)
`(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
((decimal)
`(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
((hexadecimal)
`(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
((fixed-string)
(let ((len (cadr spec)))
`(,_if (,_not (,_= ,len (,_string-length ,val)))
(,_error "wrong field length: " ,val ,len)
(,_write-string ,val ,out))))
((padded-string)
(let ((len (cadr spec))
(pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
`(,_let ((l (,_string-length ,val)))
(,_if (,_> l ,len)
(,_error "field too large: " ,val ,len)
(,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
,out)))))
(else
(error "unknown binary format: " spec)))))
(define (expand-assert rename spec x v)
(let ((_if (rename 'if))
(_not (rename 'not))
(_error (rename 'error))
(_integer? (rename 'integer?))
(_string? (rename 'string?))
(_string-length (rename 'string-length))
(_> (rename '>)))
(case (car spec)
((literal) #t)
((octal decimal hexadecimal)
`(,_if (,_not (,_integer? ,v))
(,_error "expected an integer" ,v)))
((fixed-string padded-string)
(let ((len (cadr spec)))
`(,_if (,_not (,_string? ,v))
(,_error "expected a string" ,v)
(,_if (,_> (,_string-length ,v) ,len)
(,_error "string too long" ,v ,len)))))
(else (error "unknown binary format: " spec)))))
(define (expand-default rename spec)
(case (car spec)
((literal) (cadr spec))
((octal decimal hexadecimal) 0)
((fixed-string) (make-string (cadr spec) #\space))
((padded-string) "")
(else (error "unknown binary format: " spec))))
(define (param-ref ls key . o)
(cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
(define (symbol-append a b)
(string->symbol (string-append (symbol->string a) (symbol->string b))))
(define-record-type Field
(make-field name get set raw-set spec)
field?
(name field-name)
(get field-get)
(set field-set)
(raw-set field-raw-set)
(spec field-spec))
(define (extract-fields type ls)
(let lp ((ls ls) (res '()))
(cond
((null? ls)
(reverse res))
((not (pair? (car ls)))
(lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
(else
(let* ((name (caar ls))
(get (or (param-ref (car ls) 'getter)
(and (not (eq? name '_))
(symbol-append type (symbol-append '- name)))))
(set (or (param-ref (car ls) 'setter)
(and (not (eq? name '_))
(symbol-append (symbol-append type '-)
(symbol-append name '-set!)))))
(raw-set (and set (symbol-append '% set)))
(spec (cadr (car ls))))
(lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
(define-syntax define-binary-record-type
(syntax-rules ()
((define-binary-record-type name x ...)
(defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
() () ()))))
(define-syntax defrec
(syntax-rules (make: pred: read: write: block:)
((defrec () n m p r w
((field-tmp field-read field-read-expr field-write field-write-expr field-get) ...)
((field getter . s) ...)
(def-setter ...))
(begin
(define-record-type n (m field ...) p
(field getter . s) ...)
(define r
(let ((field-read field-read-expr) ...)
(lambda (in)
(let* ((field-tmp (field-read in)) ...)
(m field ...)))))
(define w
(let ((field-write field-write-expr) ...)
(lambda (x out)
(field-write (field-get x) out) ...)))
def-setter ...)
;; workaround for impls which strip hygiene from top-level defs
;; for some reason, works in chicken but not across libraries
;;
;; (begin
;; (define-values (n m p getter ... setter ...)
;; (let ()
;; (define-record-type n (m field ...) p
;; (field getter . s) ...)
;; (def setter val) ...
;; (values (record-rtd n) m p getter ... setter ...)))
;; (define r
;; (let ((field-read field-read-expr) ...)
;; (lambda (in)
;; (let* ((field-tmp (field-read in)) ...)
;; (m field ...)))))
;; (define w
;; (let ((field-write field-write-expr) ...)
;; (lambda (x out)
;; (field-write (field-get x) out) ...))))
)
((defrec ((make: x) . rest) n m p r w b f s)
(defrec rest n x p r w b f s))
((defrec ((pred: x) . rest) n m p r w b f s)
(defrec rest n m x r w b f s))
((defrec ((read: x) . rest) n m p r w b f s)
(defrec rest n m p x w b f s))
((defrec ((write: x) . rest) n m p r w b f s)
(defrec rest n m p r x b f s))
((defrec ((block: (field (type . args) getter setter) . fields) . rest) n m p r w b f s)
(defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w b f s))
((defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w
(b ...) (f ...) (s ...))
(defrec ((block: . fields) . rest) n m p r w
(b ...
(field read-tmp (type read: args) write-tmp (type write: args) getter))
(f ...
(field getter tmp-setter))
(s ...
(define setter
(let ((pred? (type pred: args)))
(lambda (x val)
(if (not (pred? val))
(error "invalid val for" 'field val))
(tmp-setter x val)))))))
((defrec ((block: (field (type . args) getter) . fields) . rest) n m p r w
(b ...) (f ...) s)
(defrec ((block: . fields) . rest) n m p r w
(b ...
(field read-tmp (type read: args) write-tmp (type write: args) getter))
(f ...
(field getter))
s))
((defrec ((block: (field . x)) . rest) n m p r w b f s)
(syntax-error "invalid field in block" (field . x)))
((defrec ((block: data . fields) . rest) n m p r w (b ...) f s)
(defrec ((block: . fields) . rest) n m p r w
(b ...
(tmp-data read-tmp (read-literal 'data) write-tmp (write-literal 'data) (lambda (x) x)))
f
s))
((defrec ((block:) . rest) n m p r w b f s)
(defrec rest n m p r w b f s))
))
(er-macro-transformer
(lambda (expr rename compare)
(let ((name (cadr expr))
(ls (cddr expr)))
(if (not (and (identifier? name) (every list? ls)))
(error "invalid syntax: " expr))
(let* ((type (or (param-ref ls 'type) (symbol-append 'type- name)))
(pred (or (param-ref ls 'predicate) (symbol-append name '?)))
(make (or (param-ref ls 'make) (symbol-append 'make- name)))
(make-spec (if (pair? make) make (list make)))
(%make (rename (symbol-append '% (car make-spec))))
(%%make (rename (symbol-append '%% (car make-spec))))
(reader (or (param-ref ls 'read) (symbol-append 'read- name)))
(writer (or (param-ref ls 'write) (symbol-append 'write- name)))
(block (assq 'block ls))
(_begin (rename 'begin))
(_define (rename 'define))
(_define-record-type (rename 'define-record-type))
(_let (rename 'let)))
(if (not block)
(error "missing binary record block: " expr))
(let* ((fields (extract-fields name (cdr block)))
(named-fields (filter (lambda (f) (not (eq? '_ (field-name f))))
fields)))
`(,_begin
(,_define ,name ',ls)
(,_define-record-type
,type (,%%make) ,pred
,@(map
(lambda (f)
`(,(field-name f) ,(field-get f) ,(field-raw-set f)))
named-fields))
,@(map
(lambda (f)
`(,_define (,(field-set f) x v)
,(expand-assert rename (field-spec f) 'x 'v)
(,(field-raw-set f) x v)))
named-fields)
(,_define (,%make)
(let ((res (,%%make)))
,@(map
(lambda (f)
`(,(field-raw-set f)
res
,(expand-default rename (field-spec f))))
named-fields)
res))
(,_define ,make-spec
(,_let ((res (,%make)))
,@(map
(lambda (x)
(let ((field (find (lambda (f) (eq? x (field-name f)))
fields)))
`(,(field-set field) res ,x)))
(cdr make-spec))
res))
(,_define (,reader in)
(,_let ((res (,%make)))
,@(map
(lambda (f)
(if (eq? '_ (field-name f))
(expand-read rename 'in (field-spec f))
`(,(field-set f)
res
,(expand-read rename 'in (field-spec f)))))
fields)
res))
(,_define (,writer x out)
,@(map
(lambda (f)
(expand-write rename
'out
`(,(field-get f) x)
(field-spec f)))
fields)))))))))

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

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

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

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

81
lib/chibi/bytevector-test.sld
View file

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

94
lib/chibi/bytevector.scm
View file

@ -1,83 +1,28 @@
;;> \section{Additional accessors}
;;> Retrieve a 16-bit unsigned integer value from the given bytevector
;;> \var{bv} at offset \var{i}, in little-endian order.
(define (bytevector-u16-ref-le str i)
(+ (bytevector-u8-ref str i)
(arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8)))
(define (bytevector-u16-ref-le bv i)
(+ (bytevector-u8-ref bv i)
(arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 8)))
(define (bytevector-u16-ref-be str i)
(+ (arithmetic-shift (bytevector-u8-ref str i) 8)
(bytevector-u8-ref str (+ i 1))))
;;> Retrieve a 16-bit unsigned integer value from the given bytevector
;;> \var{bv} at offset \var{i}, in big-endian order.
(define (bytevector-u32-ref-le str i)
(+ (bytevector-u8-ref str i)
(arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8)
(arithmetic-shift (bytevector-u8-ref str (+ i 2)) 16)
(arithmetic-shift (bytevector-u8-ref str (+ i 3)) 24)))
(define (bytevector-u16-ref-be bv i)
(+ (arithmetic-shift (bytevector-u8-ref bv i) 8)
(bytevector-u8-ref bv (+ i 1))))
;;> Retrieve a 32-bit unsigned integer value from the given bytevector
;;> \var{bv} at offset \var{i}, in little-endian order.
(define (bytevector-u32-ref-le bv i)
(+ (bytevector-u8-ref bv i)
(arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 8)
(arithmetic-shift (bytevector-u8-ref bv (+ i 2)) 16)
(arithmetic-shift (bytevector-u8-ref bv (+ i 3)) 24)))
;;> Retrieve a 32-bit unsigned integer value from the given bytevector
;;> \var{bv} at offset \var{i}, in big-endian order.
(define (bytevector-u32-ref-be bv i)
(+ (arithmetic-shift (bytevector-u8-ref bv i) 24)
(arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 16)
(arithmetic-shift (bytevector-u8-ref bv (+ i 2)) 8)
(bytevector-u8-ref bv (+ i 3))))
;;> \section{Bignum encodings}
;;> A BER compressed integer (X.209) is an unsigned integer in base 128,
;;> most significant digit first, where the high bit is set on all but the
;;> final (least significant) byte. Thus any size integer can be
;;> encoded, but the encoding is efficient and small integers don't take
;;> up any more space than they would in normal char/short/int encodings.
(define (bytevector-ber-ref bv . o)
(let ((end (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(bytevector-length bv))))
(let lp ((acc 0) (i (if (pair? o) (car o) 0)))
(if (>= i end)
(error "unterminated ber integer in bytevector" bv)
(let ((b (bytevector-u8-ref bv i)))
(if (< b 128)
(+ acc b)
(lp (arithmetic-shift (+ acc (bitwise-and b 127)) 7)
(+ i 1))))))))
(define (bytevector-ber-set! bv n . o)
;;(assert (integer? number) (not (negative? number)))
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(bytevector-length bv))))
(let lp ((n (arithmetic-shift n -7))
(ls (list (bitwise-and n 127))))
(if (zero? n)
(do ((i start (+ i 1))
(ls ls (cdr ls)))
((null? ls))
(if (>= i end)
(error "integer doesn't fit in bytevector as ber"
bv n start end)
(bytevector-u8-set! bv i (car ls))))
(lp (arithmetic-shift n -7)
(cons (+ 128 (bitwise-and n 127)) ls))))))
(define (bytevector-u32-ref-be str i)
(+ (arithmetic-shift (bytevector-u8-ref str i) 24)
(arithmetic-shift (bytevector-u8-ref str (+ i 1)) 16)
(arithmetic-shift (bytevector-u8-ref str (+ i 2)) 8)
(bytevector-u8-ref str (+ i 3))))
;;> \section{Integer conversion}
;;> Convert an unsigned integer \var{n} to a bytevector representing
;;> the base-256 big-endian form (the zero index holds the MSB).
(define (integer->bytevector n)
(cond
((zero? n)
@ -95,10 +40,6 @@
(bytevector-u8-set! bv i (car ls))))
(lp (quotient n 256) (cons (remainder n 256) res)))))))
;;> The inverse of \scheme{integer->bytevector}. Convert a bytevector
;;> representing the base-256 big-endian form (the zero index holds
;;> the MSB) to the corresponding unsigned integer.
(define (bytevector->integer bv)
(let ((len (bytevector-length bv)))
(let lp ((i 0) (n 0))
@ -108,9 +49,6 @@
(+ (arithmetic-shift n 8)
(bytevector-u8-ref bv i)))))))
;;> Utility to pad a bytevector with zeros. Padding is added to the
;;> left so as not to change the big-endian value.
(define (bytevector-pad-left bv len)
(let ((diff (- len (bytevector-length bv))))
(if (positive? diff)

36
lib/chibi/bytevector.sld
View file

@ -1,41 +1,11 @@
;;> Additional bytevector utilities.
(define-library (chibi bytevector)
(export
bytevector-u16-ref-le bytevector-u16-ref-be
bytevector-u32-ref-le bytevector-u32-ref-be
bytevector-ber-ref bytevector-ber-set!
bytevector-pad-left
integer->bytevector bytevector->integer
integer->hex-string hex-string->integer
bytevector->hex-string hex-string->bytevector
bytevector-ieee-single-ref
bytevector-ieee-single-native-ref
bytevector-ieee-single-set!
bytevector-ieee-single-native-set!
bytevector-ieee-double-ref
bytevector-ieee-double-native-ref
bytevector-ieee-double-set!
bytevector-ieee-double-native-set!
)
(import (scheme base) (scheme inexact))
(cond-expand
(big-endian
(begin
(define-syntax native-endianness
(syntax-rules () ((_) 'big)))))
(else
(begin
(define-syntax native-endianness
(syntax-rules () ((_) 'little))))))
(cond-expand
((library (srfi 151)) (import (srfi 151)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(include "bytevector.scm")
(cond-expand
(chibi
(import (except (scheme bytevector) bytevector-copy!)))
(else
(include "ieee-754.scm"))))
bytevector->hex-string hex-string->bytevector)
(import (scheme base) (srfi 33))
(include "bytevector.scm"))

2
lib/chibi/channel.scm
View file

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

5
lib/chibi/channel.sld
View file

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

4
lib/chibi/char-set.sld
View file

@ -1,8 +1,6 @@
;;> A minimal character set library.
(define-library (chibi char-set)
(import (chibi char-set base) (chibi char-set extras))
(import (chibi) (chibi char-set base) (chibi char-set extras))
(export
Char-Set char-set? char-set-contains?
char-set ucs-range->char-set char-set-copy char-set-size

24
lib/chibi/char-set/ascii.scm
View file

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

19
lib/chibi/char-set/base.sld
View file

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

14
lib/chibi/char-set/boundary.sld
View file

@ -1,19 +1,11 @@
;; Character sets for Unicode boundaries, TR29.
;; This code is written by Alex Shinn and placed in the
;; Public Domain. All warranties are disclaimed.
;;> Char-sets used for
;;> \hyperlink["http://unicode.org/reports/tr29/"]{TR29} word
;;> boundaries.
(define-library (chibi char-set boundary)
(cond-expand
(chibi (import (chibi)))
(else (import (scheme base))))
(cond-expand
((library (chibi char-set)) (import (chibi char-set)))
(chibi
(import (chibi) (chibi char-set)))
(else
(import (srfi 14))
(import (scheme base) (srfi 14))
(begin (define (immutable-char-set cs) cs))))
(export char-set:regional-indicator
char-set:extend-or-spacing-mark

20
lib/chibi/char-set/extras.scm
View file

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

5
lib/chibi/char-set/extras.sld
View file

@ -1,9 +1,6 @@
(define-library (chibi char-set extras)
(cond-expand
(chibi (import (chibi)))
(else (import (scheme base))))
(import (chibi iset) (chibi char-set base))
(import (chibi) (chibi iset) (chibi char-set base))
(include "extras.scm")
(export
char-set ucs-range->char-set char-set-copy char-set-size

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

File diff suppressed because one or more lines are too long

18
lib/chibi/config.scm
View file

@ -76,18 +76,13 @@
;;> Returns true iff \var{x} is a config object.
(define-record-type Config
(%make-conf alist parent source timestamp)
(make-conf alist parent source timestamp)
conf?
(alist conf-alist conf-alist-set!)
(parent conf-parent conf-parent-set!)
(source conf-source conf-source-set!)
(timestamp conf-timestamp conf-timestamp-set!))
(define (make-conf alist parent source timestamp)
(if (not (alist? alist))
(error "config requires an alist" alist)
(%make-conf alist parent source timestamp)))
(define (assq-tail key alist)
(let lp ((ls alist))
(and (pair? ls)
@ -111,12 +106,7 @@
(else (lp (cdr ls) (cons (car ls) rev))))))
(define (read-from-file file . opt)
(guard (exn
(else
(warn "couldn't load config:" file)
(print-exception exn)
(print-stack-trace exn)
(and (pair? opt) (car opt))))
(guard (exn (else (and (pair? opt) (car opt))))
(call-with-input-file file read)))
(define (alist? x)
@ -297,7 +287,7 @@
(define (conf-get-multi config key)
(if (not config)
'()
(append (conf-get-list (conf-head config) key)
(append (conf-get-list (conf-head config))
(conf-get-multi (conf-parent config) key))))
;;> Extends the config with anadditional alist.
@ -461,7 +451,7 @@
(every* (lambda (x)
(and (pair? x)
(conf-verify-match key-def (car x) warn)
(conf-verify-match val-def (cell-value) warn)))
(conf-verify-match val-def (cell-value x) warn)))
(cell-list)))))
((conf)
(and (alist? (cell-list))

16
lib/chibi/config.sld
View file

@ -10,18 +10,6 @@
;; This is only used for config verification, it's acceptable to
;; substitute file existence for the stronger directory check.
(cond-expand
(chibi
(import (only (meta) warn))
(import (only (chibi) print-exception print-stack-trace))
(import (only (chibi filesystem) file-directory?)))
(else
(begin
(define file-directory? file-exists?)
(define (print-exception exn) (write exn))
(define (print-stack-trace . o) #f)
(define (warn msg . args)
(let ((err (current-error-port)))
(display msg err)
(for-each (lambda (x) (display " " err) (write x err)) args)
(newline err))))))
(chibi (import (only (chibi filesystem) file-directory?)))
(else (begin (define file-directory? file-exists?))))
(include "config.scm"))

39
lib/chibi/crypto/crypto.stub
View file

@ -1,39 +0,0 @@
(c-include-verbatim "sha2.c")
;; \procedure{(start-sha type)}
;;
;; Allocates a new opaque computation context for a SHA-\var{type}
;; digest, where \var{type} can be one of the following constants:
;; \scheme{type-sha-224}, \scheme{type-sha-256}.
(define-c-struct sha_context)
(define-c sexp (start-sha "sexp_start_sha")
((value ctx sexp) (value self sexp) unsigned-int (value NULL sha_context)))
(define-c-const unsigned-int (type-sha-224 "SHA_TYPE_224"))
(define-c-const unsigned-int (type-sha-256 "SHA_TYPE_256"))
;; \procedure{(add-sha-data! sha-context data)}
;;
;; Adds a new piece of data into the given context. \var{data} can be
;; a bytevector or a string. Bytevectors are added as sequences bytes.
;; Strings are added as sequences of byte representations of their
;; chars (which is either UTF-8 or ASCII code point sequence, depending
;; on whether Chibi was compiled with Unicode support).
;;
;; It is an error to add more data into a context that was finalized
;; by \scheme{get-sha}. This procedure returns an unspecified value.
(define-c sexp (add-sha-data! "sexp_add_sha_data")
((value ctx sexp) (value self sexp) sha_context sexp))
;; \procedure{(get-sha sha-context)}
;;
;; Finalizes computation and returns resulting SHA-2 digest as a hex
;; string (in lowercase). It is not possible to add more data with
;; \scheme{add-sha-data!} after this call. Though, digest string can
;; be retrieved multiple times from the same computation context.
(define-c sexp (get-sha "sexp_get_sha")
((value ctx sexp) (value self sexp) sha_context))

13
lib/chibi/crypto/md5-test.sld
View file

@ -1,13 +0,0 @@
(define-library (chibi crypto md5-test)
(export run-tests)
(import (scheme base) (chibi crypto md5) (chibi test))
(begin
(define (run-tests)
(test-begin "md5")
(test "d41d8cd98f00b204e9800998ecf8427e"
(md5 ""))
(test "900150983cd24fb0d6963f7d28e17f72"
(md5 "abc"))
(test "9e107d9d372bb6826bd81d3542a419d6"
(md5 "The quick brown fox jumps over the lazy dog"))
(test-end))))

4
lib/chibi/crypto/md5.scm
View file

@ -130,10 +130,6 @@
#xffef #xf47d #x8584 #x5dd1 #x6fa8 #x7e4f #xfe2c #xe6e0 #xa301 #x4314
#x4e08 #x11a1 #xf753 #x7e82 #xbd3a #xf235 #x2ad7 #xd2bb #xeb86 #xd391))
;;> Returns the md5 checksum of \var{src} as a lowercase hex-string.
;;> \var{src} can be any of a string (interpreted as utf8), a
;;> bytevector, or a binary input port.
(define (md5 src)
(let ((in (cond ((string? src) (open-input-bytevector (string->utf8 src)))
((bytevector? src) (open-input-bytevector src))

9
lib/chibi/crypto/md5.sld
View file

@ -1,12 +1,5 @@
;;> Implementation of the MD5 (Message Digest) cryptographic hash. In
;;> new applications SHA-2 should be preferred.
(define-library (chibi crypto md5)
(import (scheme base) (chibi bytevector))
(cond-expand
((library (srfi 151)) (import (srfi 151)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(import (scheme base) (srfi 33) (chibi bytevector))
(export md5)
(include "md5.scm"))

81
lib/chibi/crypto/rsa-test.sld
View file

@ -1,81 +0,0 @@
(define-library (chibi crypto rsa-test)
(export run-tests)
(import (scheme base)
(chibi crypto rsa)
(chibi crypto sha2)
(chibi test))
(begin
(define (run-tests)
(define (test-key key)
(test #t (rsa-key? key))
(test #t (positive? (rsa-key-n key)))
(test #t (positive? (rsa-key-e key)))
(test #t (positive? (rsa-key-d key)))
(test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
(test-begin "rsa")
;; Verify an explicit key.
;; p = 61, q = 53
(let* ((priv-key (rsa-key-gen-from-primes 8 61 53))
(pub-key (rsa-pub-key priv-key)))
(test 439 (rsa-sign priv-key 42))
(test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
(let ((msg 42))
(test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg)))))
(let* ((priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
(pub-key2 (rsa-pub-key priv-key2)))
(let ((msg 42))
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
(let ((msg #u8(42)))
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
(let ((msg "*"))
(test msg (utf8->string (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg)))))
(let ((msg "*"))
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
(let ((msg #u8(42)))
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg)))))
;; Key generation.
(test-key (rsa-key-gen 8))
(test-key (rsa-key-gen 16))
(test-key (rsa-key-gen 32))
(test-key (rsa-key-gen-from-primes 32 2936546443 3213384203))
;; These are expensive to test. Times with -h1G:
;; (test-key (rsa-key-gen 128)) ; 0.04s
;; (test-key (rsa-key-gen 256)) ; 0.4s
;; (test-key (rsa-key-gen 512)) ; 4s
;; (test-key (rsa-key-gen 1024)) ; 92s
;; padding
(test #u8(8 8 8 8 8 8 8 8) (pkcs1-pad #u8()))
(test #u8(1 7 7 7 7 7 7 7) (pkcs1-pad #u8(1)))
(test #u8(1 2 6 6 6 6 6 6) (pkcs1-pad #u8(1 2)))
(test #u8(1 2 3 5 5 5 5 5) (pkcs1-pad #u8(1 2 3)))
(test #u8(1 2 3 4 4 4 4 4) (pkcs1-pad #u8(1 2 3 4)))
(test #u8(1 2 3 4 5 3 3 3) (pkcs1-pad #u8(1 2 3 4 5)))
(test #u8(1 2 3 4 5 6 2 2) (pkcs1-pad #u8(1 2 3 4 5 6)))
(test #u8(1 2 3 4 5 6 7 1) (pkcs1-pad #u8(1 2 3 4 5 6 7)))
(test #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8) (pkcs1-pad #u8(1 2 3 4 5 6 7 8)))
(test #u8() (pkcs1-unpad #u8(8 8 8 8 8 8 8 8)))
(test #u8(1) (pkcs1-unpad #u8(1 7 7 7 7 7 7 7)))
(test #u8(1 2) (pkcs1-unpad #u8(1 2 6 6 6 6 6 6)))
(test #u8(1 2 3) (pkcs1-unpad #u8(1 2 3 5 5 5 5 5)))
(test #u8(1 2 3 4) (pkcs1-unpad #u8(1 2 3 4 4 4 4 4)))
(test #u8(1 2 3 4 5) (pkcs1-unpad #u8(1 2 3 4 5 3 3 3)))
(test #u8(1 2 3 4 5 6) (pkcs1-unpad #u8(1 2 3 4 5 6 2 2)))
(test #u8(1 2 3 4 5 6 7) (pkcs1-unpad #u8(1 2 3 4 5 6 7 1)))
(test #u8(1 2 3 4 5 6 7 8) (pkcs1-unpad #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8)))
(test-end))))

8
lib/chibi/crypto/rsa.sld
View file

@ -1,13 +1,7 @@
;;> RSA public key cryptography implementation.
(define-library (chibi crypto rsa)
(import (scheme base) (srfi 27)
(import (scheme base) (srfi 27) (srfi 33)
(chibi bytevector) (chibi math prime))
(cond-expand
((library (srfi 151)) (import (srfi 151)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key
rsa-encrypt rsa-decrypt rsa-sign rsa-verify rsa-verify?
rsa-key? rsa-key-bits rsa-key-n rsa-key-e rsa-key-d

24
lib/chibi/crypto/sha2-native.scm
View file

@ -1,24 +0,0 @@
;; sha2-native.scm -- SHA-2 digest algorithms native interface
;; Copyright (c) 2015 Alexei Lozovsky. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (process-sha-data! context src)
(cond ((or (bytevector? src) (string? src))
(add-sha-data! context src))
((input-port? src)
(let lp ((chunk (read-bytevector 1024 src)))
(unless (eof-object? chunk)
(add-sha-data! context chunk)
(lp (read-bytevector 1024 src)))))
(else
(error "unknown digest source: " src))))
(define (sha-224 src)
(let ((context (start-sha type-sha-224)))
(process-sha-data! context src)
(get-sha context)))
(define (sha-256 src)
(let ((context (start-sha type-sha-256)))
(process-sha-data! context src)
(get-sha context)))

83
lib/chibi/crypto/sha2-test.sld
View file

@ -1,83 +0,0 @@
(define-library (chibi crypto sha2-test)
(export run-tests)
(import (scheme base) (chibi crypto sha2) (chibi test))
(begin
(define (run-tests)
(test-begin "sha2")
(test "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
(sha-224 ""))
(test "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7"
(sha-224 "abc"))
(test "730e109bd7a8a32b1cb9d9a09aa2325d2430587ddbc0c38bad911525"
(sha-224 "The quick brown fox jumps over the lazy dog"))
(test "7c9da3bf97ccdeee630639aacdce35d3c136e514332a28e67097a4a4"
(sha-224 "Boundary test for 448 bits (-1) - 012345678901234567890"))
(test "35aebce593c857a2c817428340ff465922ffe43ed076d24553db1a24"
(sha-224 "Boundary test for 448 bits (0) - 0123456789012345678901"))
(test "3f8dbeb9c33981d7007e20641d506d048e89e98a9546ecccc3224d3b"
(sha-224 "Boundary test for 448 bits (+1) - 01234567890123456789012"))
(test "8b311209d5880800911d3e72ffe7e75ec33a6e83932d5cdd00c96327"
(sha-224 "Boundary test for 512 bits (-1) - 01234567890123456789012345678"))
(test "9b68fdc122e1cb38575ba97f54699d71eaf0e58ee88f9e653b31d6ce"
(sha-224 "Boundary test for 512 bits (0) - 012345678901234567890123456789"))
(test "52b28e31226ee5e6ada43e33194e11d8015abf8b5511c1631ad11aea"
(sha-224 "Boundary test for 512 bits (+1) - 0123456789012345678901234567890"))
(test "aa85fe2924d9c259f92e154fa88d0c845654fe69aa7dc1e3f7e4c789"
(sha-224 "Boundary test for 960 bits (-1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234"))
(test "dd8af6abfe24e78065afd1ae06220e8d46401db13f202109770ca2d2"
(sha-224 "Boundary test for 960 bits (0) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345"))
(test "5299a41ce9c6e8b405f42b193922fb4af3da16a1519610057baca20f"
(sha-224 "Boundary test for 960 bits (+1) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456"))
(test "cb88e45dc662233ef4e7171e9e1c4903bd6502dd25923105778ea82e"
(sha-224 "Boundary test for 1024 bits (-1) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901"))
(test "f41c907a7fd2fa3aec70815669fe467760f4fd15763a75192d2c9f45"
(sha-224 "Boundary test for 1024 bits (0) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012"))
(test "cc1501345f86b1ef60eaf3637f7a37c38c63252b5674d343a3cc4aea"
(sha-224 "Boundary test for 1024 bits (+1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123"))
(test "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
(sha-224 #u8()))
(test "ae40be26ae2072dd84f37c13a5f6af48e3c33ea1c08a5ef4a54b22e3"
(sha-224 #u8(1 2 3 4 5 6 7 8 9)))
(test "54e5eb52479c241cc4759318619f548994ae46979124cb9b1435db14"
(sha-224 (open-input-bytevector #u8(1 2 3 9))))
(test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
(sha-256 ""))
(test "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
(sha-256 "abc"))
(test "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592"
(sha-256 "The quick brown fox jumps over the lazy dog"))
(test "61f8fe4c4cdc8b3e10673933fcd0c5b1f6b46d3392550e42b265daefc7bc0d31"
(sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklm"))
(test "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
(sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"))
(test "f904e41d6488bc982a929e1f9307d9b47f12e6cc01ab42d109b083a780dbb70a"
(sha-256 "Boundary test for 448 bits (-1) - 012345678901234567890"))
(test "4621c7c067a12951ed5b0339a6c6811aec2dea4adcb2dcbb1383868765dbbc21"
(sha-256 "Boundary test for 448 bits (0) - 0123456789012345678901"))
(test "a62bd24e12494c5a213dc366fec9d79e2bd77789febf6b1437191f264ad0a7fe"
(sha-256 "Boundary test for 448 bits (+1) - 01234567890123456789012"))
(test "2c47adeb018cd5634aa3c121bf0e6d122789448568814e7243b19b6c26ac4860"
(sha-256 "Boundary test for 512 bits (-1) - 01234567890123456789012345678"))
(test "eb1018cf7e5f40ba45a711c4154584234e2194f10cc6fa7559a438bed9e4a388"
(sha-256 "Boundary test for 512 bits (0) - 012345678901234567890123456789"))
(test "714f030e4971ade8976564693a8fe202ca357e87cb1cb7391a9af3c45590f7c0"
(sha-256 "Boundary test for 512 bits (+1) - 0123456789012345678901234567890"))
(test "a745d68a9999da92558757735428346439e2af5668b188e9e4da7935e318335b"
(sha-256 "Boundary test for 960 bits (-1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234"))
(test "f2d7ad79e0360fbad145dd551db33548dc7cd253e6c56c975f2820e4c99dee51"
(sha-256 "Boundary test for 960 bits (0) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345"))
(test "9f0378e0ba55965bd17232f994710b786e9d72a88a806c0b10cd9d36a06e41ed"
(sha-256 "Boundary test for 960 bits (+1) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456"))
(test "483a36ca7824cc0d9bff2d63901301ba8ca7deb675628c71d8a08d52a0396cfe"
(sha-256 "Boundary test for 1024 bits (-1) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901"))
(test "8bd16f15e5f1b753650753497d09e1956137fba0cb2162a61dc6a2b49c7fcda3"
(sha-256 "Boundary test for 1024 bits (0) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012"))
(test "c6c960e1c106d214e82d58c12c44adb000903d2022ea2ce239f273294d3055e5"
(sha-256 "Boundary test for 1024 bits (+1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123"))
(test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
(sha-256 #u8()))
(test "47e4ee7f211f73265dd17658f6e21c1318bd6c81f37598e20a2756299542efcf"
(sha-256 #u8(1 2 3 4 5 6 7 8 9)))
(test "a745f3ca4f474d583c050eaf476ce76439d171ebe2b49d4af8b44f13ba71fb56"
(sha-256 (open-input-bytevector #u8(1 2 3 9))))
(test-end))))

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