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

721 changed files with 11332 additions and 93878 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

5
.hgignore
View file

@ -4,8 +4,6 @@ syntax: glob
*.s
*.o
*.so
*.so.*
*.pc
*.sch
*.sps
*.txt
@ -37,9 +35,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/*
tests/ffi/*.c
tests/ffi/*.stub

4
.travis.yml
View file

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

47
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,29 @@ 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

555
Makefile
View file

@ -1,198 +1,125 @@
# -*- 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 checkdefs
.DEFAULT_GOAL := all
CHIBI_VERSION ?= $(shell cat VERSION)
SOVERSION ?= $(CHIBI_VERSION)
SOVERSION_MAJOR ?= $(shell echo "$(SOVERSION)" | sed "s/\..*//")
CHIBI_FFI ?= $(CHIBI) -q tools/chibi-ffi
CHIBI_FFI ?= $(CHIBI) 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)" ./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)
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 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
IMAGE_FILES = lib/chibi.img lib/red.img lib/snow.img
HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html) doc/lib/srfi/166/base.html
META_FILES = lib/.chibi.meta lib/.srfi.meta lib/.scheme.meta
HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
########################################################################
# 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.
all: chibi-scheme$(EXE) all-libs chibi-scheme.pc $(META_FILES)
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
# Please run this if you want to contribute.
init-dev:
git config core.hooksPath .githooks
ifeq ($(SEXP_USE_DL),0)
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
XCFLAGS := -Wall -DSEXP_USE_DL=0 -g -g3 -Os $(CFLAGS)
else
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
XCFLAGS := -Wall -g -g3 -Os $(CFLAGS)
endif
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
all: chibi-scheme$(EXE) all-libs lib/chibi/ast$(SO)
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 $@ $<
gc-ulimit.o: gc.c $(BASE_INCLUDES)
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $<
sexp-ulimit.o: sexp.c $(BASE_INCLUDES)
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $<
main.o: main.c $(INCLUDES)
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
SEXP_OBJS = gc.o sexp.o bignum.o 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.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)
$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
libchibi-scheme$(SO_VERSIONED_SUFFIX): $(SEXP_OBJS) $(EVAL_OBJS)
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(LIBCHIBI_FLAGS) -o $@ $^ $(XLDFLAGS)
libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX): libchibi-scheme$(SO_VERSIONED_SUFFIX)
$(LN) $< $@
libchibi-scheme$(SO): libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
$(LN) $< $@
libchibi-scheme.a: $(SEXP_OBJS) $(EVAL_OBJS)
$(AR) rcs $@ $^
libchibi-scheme$(SO): $(SEXP_OBJS) $(EVAL_OBJS)
$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
$(CC) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) -lchibi-scheme
$(CC) $(XCPPFLAGS) $(XCFLAGS) -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
chibi-scheme.pc: chibi-scheme.pc.in
echo "# pkg-config" > chibi-scheme.pc
echo "prefix=$(PREFIX)" >> chibi-scheme.pc
echo "exec_prefix=\$${prefix}" >> chibi-scheme.pc
echo "libdir=$(LIBDIR)" >> chibi-scheme.pc
echo "includedir=\$${prefix}/include" >> chibi-scheme.pc
echo "version=$(CHIBI_VERSION)" >> chibi-scheme.pc
echo "" >> chibi-scheme.pc
cat chibi-scheme.pc.in >> chibi-scheme.pc
clibs.c: $(GENSTATIC) chibi-scheme$(EXE)
$(FIND) lib -name \*.sld | $(CHIBI) $(GENSTATIC) > $@
# 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/ast$(SO): lib/chibi/ast.c $(INCLUDES)
-$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< $(XLDFLAGS) -L. -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 $@
doc/lib/chibi/%.html: lib/chibi/%.sld $(CHIBI_DOC_DEPENDENCIES)
$(CHIBI_DOC) chibi.$* > $@
doc: doc/chibi.html doc-libs
%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
$(CHIBI_DOC) --html $< > $@
lib/.%.meta: lib/%/ tools/generate-install-meta.scm $(CHIBI_DEPENDENCIES)
-$(FIND) $< -name \*.sld | \
$(CHIBI) tools/generate-install-meta.scm $(CHIBI_VERSION) > $@
$(CHIBI_DOC) $< > $@
########################################################################
# Dist builds - rules to build generated files included in distribution
@ -205,25 +132,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
@ -237,7 +153,7 @@ checkdefs:
test-basic: chibi-scheme$(EXE)
@for f in tests/basic/*.scm; do \
$(CHIBI) -xchibi $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
$(CHIBI) -xscheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
if $(DIFF) -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \
echo "[PASS] $${f%.scm}"; \
else \
@ -251,43 +167,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-threads: chibi-scheme$(EXE) lib/srfi/18/threads$(SO) lib/srfi/39/param$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/time$(SO)
$(CHIBI) -xscheme tests/thread-tests.scm
test-ffi: chibi-scheme$(EXE)
$(CHIBI) tests/ffi/ffi-tests.scm
test-numbers: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/numeric-tests.scm
test-snow: chibi-scheme$(EXE) $(IMAGE_FILES)
$(CHIBI) tests/snow/snow-tests.scm
test-flonums: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/flonum-tests.scm
test-hash: chibi-scheme$(EXE) lib/srfi/69/hash$(SO)
$(CHIBI) -xscheme tests/hash-tests.scm
test-io: chibi-scheme$(EXE) lib/chibi/io/io$(SO)
$(CHIBI) -xscheme tests/io-tests.scm
test-match: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/match-tests.scm
test-loop: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/loop-tests.scm
test-sort: chibi-scheme$(EXE) lib/srfi/33/bit$(SO)
$(CHIBI) -xscheme tests/sort-tests.scm
test-srfi-1: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/srfi-1-tests.scm
test-records: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/record-tests.scm
test-weak: chibi-scheme$(EXE) lib/chibi/weak$(SO)
$(CHIBI) -xscheme tests/weak-tests.scm
test-unicode: chibi-scheme$(EXE)
$(CHIBI) -xchibi tests/unicode-tests.scm
$(CHIBI) -xscheme tests/unicode-tests.scm
test-division: chibi-scheme$(EXE)
$(CHIBI) tests/division-tests.scm
test-process: chibi-scheme$(EXE) lib/chibi/process$(SO)
$(CHIBI) -xscheme tests/process-tests.scm
test-system: chibi-scheme$(EXE) lib/chibi/system$(SO)
$(CHIBI) -xscheme tests/system-tests.scm
test-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) -xscheme tests/lib-tests.scm
test-r5rs: chibi-scheme$(EXE)
$(CHIBI) -xchibi tests/r5rs-tests.scm
test-r7rs: chibi-scheme$(EXE)
$(CHIBI) tests/r7rs-tests.scm
test-syntax: chibi-scheme$(EXE)
$(CHIBI) tests/syntax-tests.scm
test: test-r7rs
test-safe-string-cursors: chibi-scheme$(EXE)
$(CHIBI) -Dsafe-string-cursors tests/r7rs-tests.scm
$(CHIBI) -Dsafe-string-cursors tests/lib-tests.scm
test-all: test test-syntax test-libs test-ffi test-division
test-dist: test-all test-memory test-build
test: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/r5rs-tests.scm
bench-gabriel: chibi-scheme$(EXE)
./benchmarks/gabriel/run.sh
@ -296,264 +222,119 @@ 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 include/chibi/install.h \
$(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 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
$(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
$(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/
$(INSTALL) tools/chibi-doc $(DESTDIR)$(BINDIR)/
$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/term
$(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
$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
$(INSTALL) -m0644 lib/chibi/char-set/*.sld lib/chibi/char-set/*.scm $(DESTDIR)$(MODDIR)/chibi/char-set/
$(INSTALL) -m0644 lib/chibi/crypto/*.sld lib/chibi/crypto/*.scm $(DESTDIR)$(MODDIR)/chibi/crypto/
$(INSTALL) -m0644 lib/chibi/io/*.scm $(DESTDIR)$(MODDIR)/chibi/io/
$(INSTALL) -m0644 lib/chibi/iset/*.sld lib/chibi/iset/*.scm $(DESTDIR)$(MODDIR)/chibi/iset/
$(INSTALL) -m0644 lib/chibi/loop/*.scm $(DESTDIR)$(MODDIR)/chibi/loop/
$(INSTALL) -m0644 lib/chibi/match/*.scm $(DESTDIR)$(MODDIR)/chibi/match/
$(INSTALL) -m0644 lib/chibi/math/*.sld lib/chibi/math/*.scm $(DESTDIR)$(MODDIR)/chibi/math/
$(INSTALL) -m0644 lib/chibi/monad/*.sld lib/chibi/monad/*.scm $(DESTDIR)$(MODDIR)/chibi/monad/
$(INSTALL) -m0644 lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
$(INSTALL) -m0644 lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
$(INSTALL) -m0644 lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/
$(INSTALL) -m0644 lib/chibi/regexp/*.sld lib/chibi/regexp/*.scm $(DESTDIR)$(MODDIR)/chibi/regexp/
$(INSTALL) -m0644 lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
$(INSTALL) -m0644 lib/chibi/snow/*.sld lib/chibi/snow/*.scm $(DESTDIR)$(MODDIR)/chibi/snow/
$(INSTALL) -m0644 lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
$(INSTALL) -m0644 lib/chibi/text/*.sld lib/chibi/text/*.scm $(DESTDIR)$(MODDIR)/chibi/text/
$(INSTALL) -m0644 lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
$(INSTALL) -m0644 lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
$(INSTALL) -m0644 lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/
$(INSTALL) -m0644 lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/
$(INSTALL) -m0644 lib/srfi/1/*.sld $(DESTDIR)$(MODDIR)/srfi/1/
$(INSTALL) -m0644 lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
$(INSTALL) -m0644 lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
$(INSTALL) -m0644 lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
$(INSTALL) -m0644 lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
$(INSTALL) -m0644 lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
$(INSTALL) -m0644 lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
$(INSTALL) -m0644 lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
$(INSTALL) -m0644 lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
$(INSTALL) -m0644 lib/srfi/113/*.scm $(DESTDIR)$(MODDIR)/srfi/113/
$(INSTALL) -m0644 lib/srfi/117/*.scm $(DESTDIR)$(MODDIR)/srfi/117/
$(INSTALL) -m0644 lib/srfi/121/*.scm $(DESTDIR)$(MODDIR)/srfi/121/
$(INSTALL) -m0644 lib/srfi/125/*.scm $(DESTDIR)$(MODDIR)/srfi/125/
$(INSTALL) -m0644 lib/srfi/128/*.scm $(DESTDIR)$(MODDIR)/srfi/128/
$(INSTALL) -m0644 lib/srfi/129/*.scm $(DESTDIR)$(MODDIR)/srfi/129/
$(INSTALL) -m0644 lib/srfi/132/*.scm $(DESTDIR)$(MODDIR)/srfi/132/
$(INSTALL) -m0644 lib/srfi/133/*.scm $(DESTDIR)$(MODDIR)/srfi/133/
$(INSTALL) -m0644 lib/srfi/135/*.sld lib/srfi/135/*.scm $(DESTDIR)$(MODDIR)/srfi/135/
$(INSTALL) -m0644 lib/srfi/143/*.scm $(DESTDIR)$(MODDIR)/srfi/143/
$(INSTALL) -m0644 lib/srfi/144/*.scm $(DESTDIR)$(MODDIR)/srfi/144/
$(INSTALL) -m0644 lib/srfi/151/*.scm $(DESTDIR)$(MODDIR)/srfi/151/
$(INSTALL) -m0644 lib/srfi/159/*.scm $(DESTDIR)$(MODDIR)/srfi/159/
$(INSTALL) -m0644 lib/srfi/159/*.sld $(DESTDIR)$(MODDIR)/srfi/159/
$(INSTALL) -m0644 lib/srfi/160/*.sld $(DESTDIR)$(MODDIR)/srfi/160/
$(INSTALL) -m0644 lib/srfi/160/*.scm $(DESTDIR)$(MODDIR)/srfi/160/
$(INSTALL) -m0644 lib/srfi/166/*.sld $(DESTDIR)$(MODDIR)/srfi/166/
$(INSTALL) -m0644 lib/srfi/166/*.scm $(DESTDIR)$(MODDIR)/srfi/166/
$(INSTALL) -m0644 lib/srfi/146/*.sld $(DESTDIR)$(MODDIR)/srfi/146/
$(INSTALL) -m0644 lib/srfi/146/*.scm $(DESTDIR)$(MODDIR)/srfi/146/
$(INSTALL) -m0644 lib/srfi/179/*.sld $(DESTDIR)$(MODDIR)/srfi/179/
$(INSTALL) -m0644 lib/srfi/179/*.scm $(DESTDIR)$(MODDIR)/srfi/179/
$(INSTALL) -m0644 lib/srfi/211/*.sld $(DESTDIR)$(MODDIR)/srfi/211/
$(INSTALL) -m0644 lib/srfi/231/*.sld lib/srfi/231/*.scm $(DESTDIR)$(MODDIR)/srfi/231/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
$(INSTALL) lib/*.scm $(DESTDIR)$(MODDIR)/
$(INSTALL) lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
$(INSTALL) lib/chibi/char-set/*.sld lib/chibi/char-set/*.scm $(DESTDIR)$(MODDIR)/chibi/char-set/
$(INSTALL) lib/chibi/io/*.scm $(DESTDIR)$(MODDIR)/chibi/io/
$(INSTALL) lib/chibi/iset/*.sld lib/chibi/iset/*.scm $(DESTDIR)$(MODDIR)/chibi/iset/
$(INSTALL) lib/chibi/loop/*.scm $(DESTDIR)$(MODDIR)/chibi/loop/
$(INSTALL) lib/chibi/match/*.scm $(DESTDIR)$(MODDIR)/chibi/match/
$(INSTALL) lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
$(INSTALL) lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
$(INSTALL) lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
$(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
$(INSTALL) lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
$(INSTALL) lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/
$(INSTALL) lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/
$(INSTALL) lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
$(INSTALL) lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
$(INSTALL) lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
$(INSTALL) lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
$(INSTALL) lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
$(INSTALL) lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
$(INSTALL) lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
$(INSTALL) lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
$(INSTALL) lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
$(MKDIR) $(DESTDIR)$(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) $(CHIBI_COMPILED_LIBS) lib/chibi/ast$(SO) $(DESTDIR)$(BINMODDIR)/chibi/
$(INSTALL) $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
$(INSTALL) $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
$(INSTALL) lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
$(INSTALL) lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
$(INSTALL) lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
$(INSTALL) lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
$(INSTALL) lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
$(INSTALL) lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
$(INSTALL) lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
$(INSTALL) lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
$(MKDIR) $(DESTDIR)$(INCDIR)
$(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/
$(INSTALL) $(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) libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/
-$(INSTALL) libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/
$(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
$(INSTALL) doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
$(INSTALL) doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
$(INSTALL) doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
-if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
uninstall:
-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE)
-$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi
-$(RM) $(DESTDIR)$(BINDIR)/chibi-doc
-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi
-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi.scm
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_VERSIONED_SUFFIX)
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
-$(CD) $(DESTDIR)$(PREFIX) && $(RM) $(INCLUDES)
-$(RMDIR) $(DESTDIR)$(INCDIR)
-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.sld
-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.scm
-$(RM) $(DESTDIR)$(MODDIR)/.*.meta
-$(RM) $(DESTDIR)$(MODDIR)/*.img
-$(RM) $(DESTDIR)$(MODDIR)/*.sld $(DESTDIR)$(MODDIR)/*/*.sld $(DESTDIR)$(MODDIR)/*/*/*.sld
-$(RM) $(DESTDIR)$(MODDIR)/*.scm $(DESTDIR)$(MODDIR)/*/*.scm $(DESTDIR)$(MODDIR)/*/*/*.scm
-$(CD) $(DESTDIR)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
-$(CD) $(DESTDIR)$(BINMODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(BINMODDIR)/chibi/char-set
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(BINMODDIR)/chibi/crypto
-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm}
-$(RM) $(DESTDIR)$(MODDIR)/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*/*.{sld,scm}
-$(CD) $(DESTDIR)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%) chibi/ast$(SO)
-$(CD) $(DESTDIR)$(BINMODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%) chibi/ast$(SO)
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(BINMODDIR)/chibi/io
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(BINMODDIR)/chibi/iset
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(BINMODDIR)/chibi/loop
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(BINMODDIR)/chibi/match
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(BINMODDIR)/chibi/math
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(BINMODDIR)/chibi/monad
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(BINMODDIR)/chibi/regexp
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(BINMODDIR)/chibi/snow
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/text $(DESTDIR)$(BINMODDIR)/chibi/text
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/time $(DESTDIR)$(BINMODDIR)/scheme/time
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme $(DESTDIR)$(BINMODDIR)/scheme
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/33
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/39
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(BINMODDIR)/srfi/113
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(BINMODDIR)/srfi/117
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(BINMODDIR)/srfi/121
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(BINMODDIR)/srfi/125
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(BINMODDIR)/srfi/128
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(BINMODDIR)/srfi/129
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(BINMODDIR)/srfi/132
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(BINMODDIR)/srfi/133
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(BINMODDIR)/srfi/135
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(BINMODDIR)/srfi/143
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(BINMODDIR)/srfi/151
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(BINMODDIR)/srfi/144
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(BINMODDIR)/srfi/146
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(BINMODDIR)/srfi/159
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(BINMODDIR)/srfi/160
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(BINMODDIR)/srfi/166
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/179 $(DESTDIR)$(BINMODDIR)/srfi/179
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/211 $(DESTDIR)$(BINMODDIR)/srfi/211
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/231 $(DESTDIR)$(BINMODDIR)/srfi/231
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
dist: 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`; 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`; 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'`

151
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,86 +41,49 @@ 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
CLIBFLAGS = -dynamiclib
STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0
else
ifeq ($(PLATFORM),bsd)
SO = .so
EXE =
CLIBFLAGS = -fPIC
CLINKFLAGS = -shared
CLIBFLAGS = -fPIC -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
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
STATIC_LDFLAGS = -lm -ldl
CLIBFLAGS = -shared
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
STATICFLAGS = -DSEXP_USE_DL=0
LIBDL =
else
ifeq ($(PLATFORM),cygwin)
SO = .dll
EXE = .exe
CC = gcc
CLIBFLAGS =
CLINKFLAGS = -shared
CLIBFLAGS = -shared
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
STATIC_LDFLAGS = -lm -ldl
LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
else
SO = .so
EXE =
CLIBFLAGS = -fPIC
CLINKFLAGS = -shared
CLIBFLAGS = -fPIC -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 +91,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

60
Makefile.libs
View file

@ -9,56 +9,33 @@
# install configuration
CC ?= cc
AR ?= ar
CD ?= cd
RM ?= rm -f
LS ?= ls
CP ?= cp
LN ?= ln -sf
INSTALL ?= install
INSTALL_EXE ?= $(INSTALL)
MKDIR ?= $(INSTALL) -d
RMDIR ?= rmdir
TAR ?= tar
DIFF ?= diff
GIT ?= git
GREP ?= grep
FIND ?= find
SYMLINK ?= ln -s
LDCONFIG ?= ldconfig
# 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 ?=
CHIBI ?= chibi-scheme$(EXE)
CHIBI_FFI ?= chibi-ffi
CHIBI_DOC ?= chibi-doc
########################################################################
# System configuration - if not using GNU make, set PLATFORM and the
# flags from Makefile.detect (at least SO, EXE, CLIBFLAGS) as necessary.
@ -67,22 +44,19 @@ 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
lib/%$(SO): lib/%.c $(INCLUDES)
$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme
doc-libs: $(HTML_LIBS)
doc/lib/%.html: lib/%.sld $(CHIBI_DOC_DEPENDENCIES)
doc/lib/%.html: lib/%.sld
$(MKDIR) $(dir $@)
$(CHIBI_DOC) --html $(subst /,.,$*) > $@
$(CHIBI_DOC) $(subst /,.,$*) > $@
clean-libs:
$(RM) $(COMPILED_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 based on an extended subset of the current
draft R7RS Scheme, with support for all libraries. To get a pure R7RS
repl you can run
chibi-scheme -xscheme.base
or see the (chibi repl) library for more options.
Support for additional languages such as JavaScript, Go, Lua and Bash
are planned for future releases. Scheme is chosen as a substrate
because its first class continuations and guaranteed tail-call
optimization makes implementing other languages easy.
To build on most platforms just run "make && make test". This will
provide a shared library "libchibi-scheme", as well as a sample
"chibi-scheme" command-line repl. You can then run
sudo make PREFIX=/usr/local install
to install the binaries, leaving out the PREFIX for the default
/usr/local or specifying an alternate install location. If you want
to try out chibi-scheme without installing, be sure to set
LD_LIBRARY_PATH so it can find the shared libraries.
For more detailed documentation, run "make doc" and see the generated
"doc/chibi.html".

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
carbon

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.6.1

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"

809
bignum.c
View file

File diff suppressed because it is too large Load diff

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

7
chibi-scheme.pc.in
View file

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

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

17
doc/chibi-doc.1
View file

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

132
doc/chibi-scheme.1
View file

@ -6,16 +6,13 @@ chibi-scheme \- a tiny Scheme interpreter
.SH SYNOPSIS
.B chibi-scheme
[-qQrRfTV]
[-qrfV]
[-I
.I path
]
[-A
.I path
]
[-D
.I feature
]
[-m
.I module
]
@ -31,9 +28,6 @@ chibi-scheme \- a tiny Scheme interpreter
[-p
.I expr
]
[-t
.I module.id
]
[-d
.I image-file
]
@ -75,85 +69,29 @@ 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
.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]
The default language is an extended subset of the draft R7RS
(scheme base) module. To get exactly the base module, use
.I chibi-scheme -xscheme.base
.SH OPTIONS
Space is optional between options and their arguments. Options
without arguments may not be chained together.
To reduce the need for shell escapes, options with module arguments
(
.I -m
,
.I -x
and
.I -R
) are written in a dot notation, so that the module
.I (foo bar)
is written as
.I foo.bar
\[char46]
.TP 5
.BI -V
Prints the version information and exits.
.TP
.BI -q
"Quick" load, shortcut for
.I chibi-scheme -xchibi
This is a slightly different language from (scheme base),
which may load faster, and is guaranteed not to load any
additional shared libraries.
Don't load the initialization file. The resulting
environment will only contain the core syntactic forms
and primitives coded in C.
.TP
.BI -Q
Extra "quick" load, shortcut for
.I chibi-scheme -xchibi.primitive
The resulting environment will only contain the core syntactic
forms and primitives coded in C. This is very fast and guaranteed
not to load any external files, but is also very limited.
.TP
.BI -r [main]
.BI -r
Run the "main" procedure when the script finishes loading as in SRFI-22.
.TP
.BI -R [module]
Loads the given module and runs the "main" procedure it defines (which
need not be exported) with a single argument of the list of command-line
arguments as in SRFI-22. The name "main" can be overridden with the -r
option.
.I [module]
may be omitted, in which case it defaults to chibi.repl. Thus
.I chibi-scheme -R
is the recommended means to obtain the advanced REPL.
.TP
.BI -s
Strict mode, escalating warnings to fatal errors.
.TP
.BI -f
Change the reader to case-fold symbols as in R5RS.
.TP
.BI -T
Disables tail-call optimization. This can be useful for
debugging in some cases, but also makes it very likely to
overflow the stack.
.TP
.BI -h size[/max_size]
Specifies the initial size of the heap, in bytes,
optionally followed by the maximum size the heap can
@ -175,12 +113,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 +120,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
@ -209,12 +145,6 @@ Evaluates the Scheme expression
.I expr
then prints the result to stdout.
.TP
.BI -t module.id
Enables tracing for the given identifier
.I id
in the module
.I module.
.TP
.BI -d image-file
Dumps the current Scheme heap to
.I image-file
@ -225,35 +155,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
.TQ
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:
.TP
directories included with the -I path option
.TP
directories included from CHIBI_MODULE_PATH
.TP
system directories
.TP
directories included with -A path option
If CHIBI_MODULE_PATH is unset, the directories "./lib", and "." are
searched in order. Set to empty to only consider -I, system
directories and -A.
.TP
.B CHIBI_IGNORE_SYSTEM_PATH
If set to anything but "0", system directories (as listed above) are
not included in the search paths.
files, inserted before the system default load paths.
.SH AUTHORS
.PP
@ -261,9 +169,9 @@ Alex Shinn (alexshinn @ gmail . com)
.SH SEE ALSO
.PP
More detailed information can be found in the manual included in
doc/chibi.scrbl included in the distribution.
More detailed information can be found in the README file
included in the distribution.
The chibi-scheme home-page:
.br
https://github.com/ashinn/chibi-scheme/
http://code.google.com/p/chibi-scheme/

1579
doc/chibi.scrbl
View file

File diff suppressed because it is too large Load diff

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

18
examples/echo-server.scm Executable file → Normal file
View file

@ -1,26 +1,20 @@
#!/usr/bin/env chibi-scheme
;; Simple R7RS echo server, using the run-net-server utility from
;; (chibi net server).
;; Simple R7RS echo server, using (srfi 18) threads and the
;; run-net-server utility from (chibi net server).
(import (scheme base) (scheme write) (chibi net) (chibi net server))
(import (scheme base) (scheme write) (srfi 18) (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 ":") (write (sockaddr-port (address-info-address addr)))
(newline)
;; write and flush the response
(display "read: ") (write line) (newline)
(display line out)
(newline out)
(flush-output-port out)
(thread-yield!)
(echo-handler in out sock addr)))))
;; Start the server on *:5556 dispatching clients to echo-handler.
;; Start the server on localhost:5556 dispatching clients to echo-handler.
(run-net-server 5556 echo-handler)

3
examples/hello.scm
View file

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

26
examples/repl-server.scm
View file

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

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

455
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,16 +92,16 @@ 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)))
return sexp_heap_align(1);
t = sexp_object_type(ctx, x);
res = sexp_type_size_of_object(t, x) + SEXP_GC_PAD;
res = sexp_type_size_of_object(t, x);
#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;
@ -261,46 +194,25 @@ static void sexp_mark_one (sexp ctx, sexp* types, sexp x) {
if (!x || !sexp_pointerp(x) || !sexp_valid_object_p(ctx, x) || sexp_markedp(x))
return;
sexp_markedp(x) = 1;
if (sexp_contextp(x)) {
if (sexp_contextp(x))
for (saves=sexp_context_saves(x); saves; saves=saves->next)
if (saves->var) sexp_mark_one(ctx, types, *(saves->var));
}
t = types[sexp_pointer_tag(x)];
if (saves->var) sexp_mark(ctx, *(saves->var));
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) {
@ -311,18 +223,6 @@ int stack_references_pointer_p (sexp ctx, sexp x) {
return 0;
}
#if SEXP_USE_TRACK_ALLOC_BACKTRACE
void sexp_print_gc_trace(sexp ctx, sexp p) {
int i;
char **debug_text = backtrace_symbols(p->backtrace, SEXP_BACKTRACE_SIZE);
for (i=0; i < SEXP_BACKTRACE_SIZE; i++)
fprintf(stderr, SEXP_BANNER(" : %s"), debug_text[i]);
free(debug_text);
}
#else
#define sexp_print_gc_trace(ctx, p)
#endif
void sexp_conservative_mark (sexp ctx) {
sexp_heap h = sexp_context_heap(ctx);
sexp p, end;
@ -347,7 +247,6 @@ void sexp_conservative_mark (sexp ctx) {
if (p && sexp_pointerp(p)) {
fprintf(stderr, SEXP_BANNER("MISS: %p [%d]: %s"), p,
sexp_pointer_tag(p), sexp_pointer_source(p));
sexp_print_gc_trace(ctx, p);
fflush(stderr);
}
#endif
@ -364,16 +263,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 +295,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 +303,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 +333,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 +354,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 +374,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 +439,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 +484,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 +517,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
size = sexp_heap_align(size);
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)));
}
}
/* make a second pass to fix code references */
if (loadp) {
p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
q = heap->free_list;
while (p < end) {
/* find the next free list pointer */
for ( ; q && ((char*)q < (char*)p); q=q->next)
;
if ((char*)q == (char*)p) { /* this is a free block, skip it */
p = (sexp) (((char*)p) + q->size);
} else {
#if SEXP_USE_DL
if (sexp_opcodep(p) && sexp_opcode_func(p)) {
name = (sexp_opcode_data2(p) && sexp_stringp(sexp_opcode_data2(p))) ? sexp_opcode_data2(p) : sexp_opcode_name(p);
if (sexp_dlp(sexp_opcode_dl(p))) {
if (!sexp_dl_handle(sexp_opcode_dl(p)))
sexp_dl_handle(sexp_opcode_dl(p)) = dlopen(sexp_string_data(sexp_dl_file(sexp_opcode_dl(p))), RTLD_LAZY);
sexp_opcode_func(p) = dlsym(sexp_dl_handle(sexp_opcode_dl(p)), sexp_string_data(name));
} else {
sexp_opcode_func(p) = dlsym(SEXP_RTLD_DEFAULT, sexp_string_data(name));
}
} else
#endif
if (sexp_typep(p)) {
if (sexp_type_finalize(p)) {
/* TODO: handle arbitrary finalizers in images */
#if SEXP_USE_DL
if (sexp_type_tag(p) == SEXP_DL)
sexp_type_finalize(p) = SEXP_FINALIZE_DL;
else
#endif
sexp_type_finalize(p) = SEXP_FINALIZE_PORT;
}
}
t = types[sexp_pointer_tag(p)];
p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)));
}
}
}
}
sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
sexp_sint_t off;
sexp_heap to, from = sexp_context_heap(ctx);
/* validate input, creating a new heap if needed */
if (from->next) {
return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx);
} else if (! dst || sexp_not(dst)) {
to = sexp_make_heap(from->size, from->max_size);
if (!to) return sexp_global(ctx, SEXP_G_OOM_ERROR);
dst = (sexp) ((char*)ctx + ((char*)to - (char*)from));
} else if (! sexp_contextp(dst)) {
return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst);
} else if (sexp_context_heap(dst)->size < from->size) {
return sexp_user_exception(ctx, NULL, "destination context too small", dst);
} else {
to = sexp_context_heap(dst);
}
/* copy the raw data */
off = (char*)to - (char*)from;
memcpy(to, from, sexp_heap_pad_size(from->size));
/* adjust the pointers */
sexp_offset_heap_pointers(to, from, sexp_context_types(ctx) + off, flags);
return dst;
}
#endif
void sexp_gc_init (void) {
#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC
sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
#endif
#if SEXP_USE_GLOBAL_HEAP
sexp_global_heap = sexp_make_heap(size, SEXP_MAXIMUM_HEAP_SIZE, 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 +725,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 */

385
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);
@ -410,7 +34,6 @@ SEXP_API sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b);
SEXP_API sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b);
SEXP_API sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b);
SEXP_API sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e);
SEXP_API sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem);
SEXP_API sexp sexp_add (sexp ctx, sexp a, sexp b);
SEXP_API sexp sexp_sub (sexp ctx, sexp a, sexp b);
SEXP_API sexp sexp_mul (sexp ctx, sexp a, sexp b);
@ -419,15 +42,13 @@ 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);
SEXP_API sexp sexp_ratio_trunc (sexp ctx, sexp a);
SEXP_API sexp sexp_ratio_floor (sexp ctx, sexp a);
SEXP_API sexp sexp_ratio_ceiling (sexp ctx, sexp a);
SEXP_API sexp sexp_ratio_compare (sexp ctx, sexp a, sexp b);
#endif
#if SEXP_USE_COMPLEX
SEXP_API sexp sexp_make_complex (sexp ctx, sexp real, sexp image);

59
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
@ -15,7 +15,7 @@ extern "C" {
#define sexp_init_file "init-"
#define sexp_init_file_suffix ".scm"
#define sexp_meta_file "meta-7.scm"
#define sexp_meta_file "meta.scm"
#define sexp_leap_seconds_file "leap.txt"
enum sexp_core_form_names {
@ -46,18 +46,19 @@ enum sexp_opcode_classes {
SEXP_OPC_NUM_OP_CLASSES
};
SEXP_API struct sexp_opcode_struct* sexp_primitive_opcodes;
#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
SEXP_API const char** sexp_opcode_names;
#endif
/**************************** prototypes ******************************/
SEXP_API void sexp_warn (sexp ctx, const char *msg, sexp x);
SEXP_API void sexp_warn (sexp ctx, char *msg, sexp x);
SEXP_API void sexp_scheme_init (void);
SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size);
SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj);
SEXP_API sexp sexp_maybe_wrap_error (sexp ctx, sexp obj);
SEXP_API sexp sexp_analyze (sexp context, sexp x);
SEXP_API sexp sexp_simplify (sexp ctx, sexp self, sexp_sint_t n, sexp ast);
SEXP_API sexp sexp_make_lambda (sexp ctx, sexp params);
@ -74,33 +75,28 @@ 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);
SEXP_API int sexp_param_index (sexp lambda, sexp name);
SEXP_API sexp sexp_compile_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
SEXP_API sexp sexp_generate_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
SEXP_API sexp sexp_eval_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env);
SEXP_API sexp sexp_load_op (sexp context, sexp self, sexp_sint_t n, sexp expr, sexp env);
SEXP_API sexp sexp_exception_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn);
SEXP_API sexp sexp_make_env_op (sexp context, sexp self, sexp_sint_t n);
SEXP_API sexp sexp_make_null_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
SEXP_API sexp sexp_env_cell_define (sexp ctx, sexp env, sexp name, sexp value, sexp* varenv);
SEXP_API sexp sexp_make_primitive_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version);
SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value);
SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close);
SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
SEXP_API char* sexp_find_module_file_raw (sexp ctx, const char *file);
SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file);
SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
SEXP_API sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file);
SEXP_API sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env);
SEXP_API sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp);
SEXP_API sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n);
SEXP_API sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env);
SEXP_API sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n);
SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value);
SEXP_API sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp);
@ -115,37 +111,27 @@ SEXP_API sexp sexp_open_output_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp
SEXP_API sexp sexp_open_binary_input_file(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_open_binary_output_file(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line);
SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
SEXP_API sexp sexp_env_cell (sexp ctx, sexp env, sexp sym, int localp);
SEXP_API sexp sexp_env_ref (sexp ctx, sexp env, sexp sym, sexp dflt);
SEXP_API sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp env);
SEXP_API sexp sexp_env_cell (sexp env, sexp sym, int localp);
SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
#if SEXP_USE_RENAME_BINDINGS
SEXP_API sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value);
#endif
SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res);
SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, 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);
#endif
#if SEXP_USE_GREEN_THREADS
SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val);
#endif
SEXP_API sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n);
SEXP_API sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp val);
#endif
SEXP_API sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp ci);
#if SEXP_USE_RATIOS
SEXP_API sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
@ -170,33 +156,28 @@ SEXP_API sexp sexp_asin(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_acos(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_atan(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_exact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_inexact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_round(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_trunc(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_floor(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_ceiling(sexp ctx, sexp self, sexp_sint_t n, sexp x);
#endif
SEXP_API sexp sexp_expt_op(sexp ctx, sexp self, sexp_sint_t n, sexp z1, sexp z2);
SEXP_API sexp sexp_exact_to_inexact(sexp ctx, sexp self, sexp_sint_t n, sexp i);
SEXP_API sexp sexp_inexact_to_exact(sexp ctx, sexp self, sexp_sint_t n, sexp x);
#if SEXP_USE_NATIVE_X86
SEXP_API sexp sexp_write_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp ch, sexp out);
SEXP_API sexp sexp_newline_op(sexp ctx, sexp self, sexp_sint_t n, sexp out);
SEXP_API sexp sexp_read_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
SEXP_API sexp sexp_peek_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
SEXP_API sexp sexp_exact_to_inexact(sexp ctx, sexp self, sexp_sint_t n, sexp i);
SEXP_API sexp sexp_inexact_to_exact(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
#endif
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)
@ -238,9 +219,6 @@ SEXP_API sexp sexp_9p_req_fid (sexp ctx, sexp self, sexp_sint_t n, sexp req);
SEXP_API sexp sexp_9p_req_newfid (sexp ctx, sexp self, sexp_sint_t n, sexp req);
SEXP_API sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sexp err);
SEXP_API sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req);
#else
SEXP_API sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port);
SEXP_API sexp sexp_stream_portp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
#endif
#if SEXP_USE_SIMPLIFY
@ -254,8 +232,7 @@ SEXP_API int sexp_rest_unused_p (sexp lambda);
#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx, NULL, 4, f, n, b, v)
#define sexp_make_env(ctx) sexp_make_env_op(ctx, NULL, 0)
#define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx, NULL, 0, v)
#define sexp_make_primitive_env(ctx, v) sexp_make_primitive_env_op(ctx, NULL, 1, v)
#define sexp_make_standard_env(ctx, v) sexp_make_standard_env_op(ctx, NULL, 1, v)
#define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx, NULL, 0)
#define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx, NULL, 1, d, a)
#define sexp_eval(ctx, x, e) sexp_eval_op(ctx, NULL, 2, x, e)
#define sexp_load(ctx, f, e) sexp_load_op(ctx, NULL, 2, f, e)

394
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,30 +81,18 @@
/* go away and you're not working on your own C extension. */
/* #define SEXP_USE_CONSERVATIVE_GC 1 */
/* uncomment this to disable automatic running of finalizers */
/* You will need to close ports and file descriptors manually */
/* (as you should anyway) and some C extensions may break. */
/* #define SEXP_USE_FINALIZERS 0 */
/* uncomment this to add additional native checks to only mark objects in the heap */
/* #define SEXP_USE_SAFE_GC_MARK 1 */
/* uncomment this to track what C source line each object is allocated from */
/* #define SEXP_USE_TRACK_ALLOC_SOURCE 1 */
/* uncomment this to take a short backtrace of where each object is */
/* allocated from */
/* #define SEXP_USE_TRACK_ALLOC_BACKTRACE 1 */
/* uncomment this to add additional native gc checks to verify a magic header */
/* #define SEXP_USE_HEADER_MAGIC 1 */
/* uncomment this to add very verbose debugging stats to the native GC */
/* #define SEXP_USE_DEBUG_GC 1 */
/* uncomment this to add instrumentation to the native GC */
/* #define SEXP_USE_TIME_GC 1 */
/* uncomment this to enable "safe" field accessors for primitive types */
/* The sexp union type fields are abstracted away with macros of the */
/* form sexp_<type>_<field>(<obj>), however these are just convenience */
@ -143,10 +108,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 +149,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 +176,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 +186,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 +197,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 +220,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,39 +246,17 @@
#define SEXP_GROW_HEAP_RATIO 0.75
#endif
/* how much to expand the heap size by */
#ifndef SEXP_GROW_HEAP_FACTOR
#define SEXP_GROW_HEAP_FACTOR 2 /* 1.6180339887498948482 */
#endif
/* size of per-context stack that is used during gc cycles
* increase if you can affort extra unused memory */
#define SEXP_MARK_STACK_COUNT 1024
/* the default number of opcodes to run each thread for */
#ifndef SEXP_DEFAULT_QUANTUM
#define SEXP_DEFAULT_QUANTUM 500
#endif
#ifndef SEXP_MAX_ANALYZE_DEPTH
#define SEXP_MAX_ANALYZE_DEPTH 8192
#endif
/* The size of flexible arrays (empty arrays at the end of a struct */
/* representing the trailing data), when compiled with C++. Technically */
/* 0 is an illegal value here, and the C++ idiom is to use 1, but this */
/* breaks compatibility with C when computing the size of structs, and */
/* in practice all of the major C++ compilers support 0. */
#ifndef SEXP_FLEXIBLE_ARRAY_SIZE
#define SEXP_FLEXIBLE_ARRAY_SIZE 0
#endif
/************************************************************************/
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
/************************************************************************/
#ifndef SEXP_64_BIT
#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) || defined(__mips64__) || defined(__sparc64__) || defined(__arm64)
#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64)
#define SEXP_64_BIT 1
#else
#define SEXP_64_BIT 0
@ -375,51 +272,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 +280,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
@ -458,10 +300,6 @@
#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES
#endif
#ifndef sexp_default_user_module_path
#define sexp_default_user_module_path "./lib:."
#endif
#ifndef SEXP_USE_TYPE_DEFS
#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES
#endif
@ -471,28 +309,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 +332,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 +352,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,42 +360,14 @@
#define SEXP_USE_CONSERVATIVE_GC 0
#endif
#ifndef SEXP_USE_FINALIZERS
#define SEXP_USE_FINALIZERS 1
#endif
#ifndef SEXP_USE_TRACK_ALLOC_SOURCE
#define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
#endif
#ifndef SEXP_USE_TRACK_ALLOC_BACKTRACE
#define SEXP_USE_TRACK_ALLOC_BACKTRACE SEXP_USE_TRACK_ALLOC_SOURCE
#endif
#ifndef SEXP_USE_TRACK_ALLOC_TIMES
#define SEXP_USE_TRACK_ALLOC_TIMES 0
#endif
#ifndef SEXP_USE_TRACK_ALLOC_SIZES
#define SEXP_USE_TRACK_ALLOC_SIZES 0
#endif
#ifndef SEXP_ALLOC_HISTOGRAM_BUCKETS
#define SEXP_ALLOC_HISTOGRAM_BUCKETS 32
#endif
#ifndef SEXP_BACKTRACE_SIZE
#define SEXP_BACKTRACE_SIZE 3
#endif
#ifndef SEXP_USE_HEADER_MAGIC
#define SEXP_USE_HEADER_MAGIC 0
#endif
#ifndef SEXP_GC_PAD
#define SEXP_GC_PAD 0
#endif
#ifndef SEXP_USE_SAFE_ACCESSORS
#define SEXP_USE_SAFE_ACCESSORS 0
#endif
@ -616,26 +393,18 @@
#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
#define SEXP_USE_RENAME_BINDINGS 1
#else
#ifndef SEXP_USE_RENAME_BINDINGS
#define SEXP_USE_RENAME_BINDINGS 1
#define SEXP_USE_RENAME_BINDINGS 0
#endif
#endif
#ifndef SEXP_USE_SPLICING_LET_SYNTAX
#define SEXP_USE_SPLICING_LET_SYNTAX 0
#endif
#ifndef SEXP_USE_FLAT_SYNTACTIC_CLOSURES
#define SEXP_USE_FLAT_SYNTACTIC_CLOSURES 0
#endif
#ifndef SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
#if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
#define SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS 0
#endif
@ -690,10 +459,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 +475,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 +536,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 +551,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 +560,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 +576,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,33 +613,12 @@
#define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000
#endif
#ifndef SEXP_MAX_VECTOR_LENGTH
#define SEXP_MAX_VECTOR_LENGTH (SEXP_MAX_FIXNUM >> 1)
#endif
#ifndef SEXP_DEFAULT_EQUAL_DEPTH
#define SEXP_DEFAULT_EQUAL_DEPTH 10000
#endif
#ifndef SEXP_DEFAULT_EQUAL_BOUND
#define SEXP_DEFAULT_EQUAL_BOUND 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
#define SEXP_DEFAULT_EQUAL_BOUND 100000
#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
@ -917,15 +629,6 @@
#define SEXP_USE_MAIN_HELP ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_MAIN_ERROR_ADVISE
#define SEXP_USE_MAIN_ERROR_ADVISE ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_SEND_FILE
#define SEXP_USE_SEND_FILE 0
/* #define SEXP_USE_SEND_FILE (__linux || SEXP_BSD) */
#endif
#if SEXP_USE_NATIVE_X86
#undef SEXP_USE_BOEHM
#define SEXP_USE_BOEHM 1
@ -944,17 +647,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 +663,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 +671,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,18 +686,14 @@
#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
#define SEXP_API
#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',
};

941
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');

77
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;
@ -88,23 +39,3 @@ sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
#endif
return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
}
/* Additional utilities. */
sexp sexp_sockaddr_name (sexp ctx, sexp self, struct sockaddr* addr) {
char buf[INET6_ADDRSTRLEN];
/* struct sockaddr_in *sa = (struct sockaddr_in *)addr; */
/* unsigned char *ptr = (unsigned char *)&(sa->sin_addr); */
/* snprintf(buf, sizeof(buf), "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
inet_ntop(addr->sa_family,
(addr->sa_family == AF_INET6 ?
(void*)(&(((struct sockaddr_in6 *)addr)->sin6_addr)) :
(void*)(&(((struct sockaddr_in *)addr)->sin_addr))),
buf, INET6_ADDRSTRLEN);
return sexp_c_string(ctx, buf, -1);
}
int sexp_sockaddr_port (sexp ctx, sexp self, struct sockaddr* addr) {
struct sockaddr_in *sa = (struct sockaddr_in *)addr;
return ntohs(sa->sin_port);
}

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

557
lib/chibi/app.scm
View file

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

14
lib/chibi/app.sld
View file

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

423
lib/chibi/ast.c
View file

@ -1,40 +1,18 @@
/* 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
static void sexp_define_type_predicate (sexp ctx, sexp env, const char *cname, sexp_uint_t type) {
static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) {
sexp_gc_var2(name, op);
sexp_gc_preserve2(ctx, name, op);
name = sexp_c_string(ctx, cname, -1);
@ -44,8 +22,7 @@ static void sexp_define_type_predicate (sexp ctx, sexp env, const char *cname, s
}
static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
sexp_uint_t cindex,
const char* get, const char *set) {
sexp_uint_t cindex, char* get, char *set) {
sexp type, index;
sexp_gc_var2(name, op);
sexp_gc_preserve2(ctx, name, op);
@ -62,65 +39,28 @@ 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 cell;
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
cell = sexp_env_cell(ctx, env, id, 0);
if (! cell) {
if (sexp_synclop(id)) {
cell = sexp_env_cell(env, id, 0);
while ((! cell) && sexp_synclop(id)) {
env = sexp_synclo_env(id);
id = sexp_synclo_expr(id);
}
cell = sexp_env_cell(ctx, env, id, 0);
if (!cell && sexp_truep(createp))
cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
}
return cell ? cell : SEXP_FALSE;
}
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) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return sexp_make_fixnum(sexp_procedure_num_args(proc));
}
sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return sexp_make_boolean(sexp_procedure_variadic_p(proc));
}
sexp sexp_get_procedure_variable_transformer_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return sexp_make_boolean(sexp_procedure_variable_transformer_p(proc));
}
sexp sexp_get_procedure_flags (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
return (sexp) (sexp_uint_t) sexp_procedure_flags(proc);
}
sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) {
sexp flags;
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc);
if (sexp_procedure_variable_transformer_p(base_proc))
return base_proc;
flags = sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER);
return sexp_make_procedure(ctx, flags,
sexp_make_fixnum(sexp_procedure_num_args(base_proc)),
sexp_procedure_code(base_proc),
sexp_procedure_vars(base_proc));
}
sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
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 +87,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 +101,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 +120,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 +130,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,43 +151,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) {
if (!x)
return sexp_type_by_index(ctx, SEXP_OBJECT);
static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
if (sexp_pointerp(x))
return sexp_object_type(ctx, x);
else if (sexp_fixnump(x))
@ -268,91 +194,38 @@ 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;
}
sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
static sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
}
sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
sexp_env_lambda(e) = lam;
return SEXP_VOID;
}
sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
return sexp_make_boolean(sexp_env_syntactic_p(e));
}
sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
sexp_env_syntactic_p(e) = sexp_truep(synp);
return SEXP_VOID;
}
sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
return sexp_env_cell_define(ctx, env, name, value, NULL);
}
sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
sexp_gc_var1(tmp);
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
sexp_gc_preserve1(ctx, tmp);
sexp_env_push(ctx, env, tmp, name, value);
sexp_gc_release1(ctx);
return SEXP_VOID;
}
sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
return sexp_make_fixnum(sexp_core_code(c));
}
sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
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 +233,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 +255,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 +269,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 +291,19 @@ 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) {
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 +312,7 @@ 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) {
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 +324,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,95 +334,23 @@ 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) {
#ifdef SEXP_USE_GREEN_THREADS
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_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = SEXP_NULL;
#if SEXP_USE_GREEN_THREADS
sexp ls;
for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls));
for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls));
#endif
if (sexp_not(sexp_memq(ctx, ctx, res))) sexp_push(ctx, res, ctx);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y, sexp start) {
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) {
#ifdef PLAN9
return SEXP_FALSE;
#else
return sexp_make_fixnum(errno);
#endif
}
sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
#ifdef PLAN9
return SEXP_FALSE;
#else
@ -601,46 +365,22 @@ 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) {
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
}
sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
return sexp_make_boolean(unsetenv(sexp_string_data(name)));
}
sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
sexp_exception_message(res) = SEXP_TRAMPOLINE;
return res;
}
#define sexp_define_type(ctx, name, tag) \
sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag));
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
sexp_gc_var2(sym, str);
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {
if (!(sexp_version_compatible(ctx, version, sexp_version)
&& sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
return SEXP_ABI_ERROR;
return sexp_global(ctx, SEXP_G_ABI_ERROR);
sexp_define_type(ctx, "Object", SEXP_OBJECT);
sexp_define_type(ctx, "Number", SEXP_NUMBER);
sexp_define_type(ctx, "Bignum", SEXP_BIGNUM);
sexp_define_type(ctx, "Flonum", SEXP_FLONUM);
sexp_define_type(ctx, "Integer", SEXP_FIXNUM);
#if SEXP_USE_RATIOS
sexp_define_type(ctx, "Ratio", SEXP_RATIO);
#endif
#if SEXP_USE_COMPLEX
sexp_define_type(ctx, "Complex", SEXP_COMPLEX);
#endif
sexp_define_type(ctx, "Symbol", SEXP_SYMBOL);
sexp_define_type(ctx, "Char", SEXP_CHAR);
sexp_define_type(ctx, "Boolean", SEXP_BOOLEAN);
@ -650,7 +390,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_type(ctx, "Vector", SEXP_VECTOR);
sexp_define_type(ctx, "Input-Port", SEXP_IPORT);
sexp_define_type(ctx, "Output-Port", SEXP_OPORT);
sexp_define_type(ctx, "File-Descriptor", SEXP_FILENO);
sexp_define_type(ctx, "Opcode", SEXP_OPCODE);
sexp_define_type(ctx, "Procedure", SEXP_PROCEDURE);
sexp_define_type(ctx, "Bytecode", SEXP_BYTECODE);
@ -659,14 +398,12 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
sexp_define_type(ctx, "Cnd", SEXP_CND);
sexp_define_type(ctx, "Set", SEXP_SET);
sexp_define_type(ctx, "Set-Syn", SEXP_SET_SYN);
sexp_define_type(ctx, "Ref", SEXP_REF);
sexp_define_type(ctx, "Seq", SEXP_SEQ);
sexp_define_type(ctx, "Lit", SEXP_LIT);
sexp_define_type(ctx, "Sc", SEXP_SYNCLO);
sexp_define_type(ctx, "Context", SEXP_CONTEXT);
sexp_define_type(ctx, "Exception", SEXP_EXCEPTION);
sexp_define_type(ctx, "Core", SEXP_CORE);
sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV);
sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE);
sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO);
@ -677,10 +414,10 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE);
sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE);
sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT);
sexp_define_type_predicate(ctx, env, "file-descriptor?", SEXP_FILENO);
sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION);
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", NULL);
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", NULL);
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", NULL);
@ -700,28 +437,21 @@ 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, 1, "bytecode-name", "bytecode-name-set!");
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-literals", NULL);
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-source", NULL);
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", NULL);
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL);
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", 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);
@ -729,11 +459,10 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_foreign(ctx, env, "make-set", 2, sexp_make_set_op);
sexp_define_foreign(ctx, env, "make-lit", 1, sexp_make_lit_op);
sexp_define_foreign(ctx, env, "make-seq", 1, sexp_make_seq);
sexp_define_foreign(ctx, env, "make-macro", 2, sexp_make_macro_op);
sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE);
sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize);
sexp_define_foreign(ctx, env, "extend-env", 3, sexp_extend_env_op);
sexp_define_foreign_opt(ctx, env, "env-cell", 3, sexp_get_env_cell, SEXP_FALSE);
sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env);
sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell);
sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
sexp_define_foreign(ctx, env, "opcode-class", 1, sexp_get_opcode_class);
sexp_define_foreign(ctx, env, "opcode-code", 1, sexp_get_opcode_code);
@ -744,49 +473,21 @@ 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);
sexp_define_foreign(ctx, env, "env-syntactic?", 1, sexp_env_syntactic_op);
sexp_define_foreign(ctx, env, "env-syntactic?-set!", 2, sexp_env_syntactic_set_op);
sexp_define_foreign(ctx, env, "env-define!", 3, sexp_env_define_op);
sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
sexp_define_foreign(ctx, env, "environment-parent", 1, sexp_env_parent_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
#ifdef 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, "errno", 0, sexp_errno);
sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
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;
}

391
lib/chibi/ast.scm
View file

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

42
lib/chibi/ast.sld
View file

@ -1,17 +1,15 @@
(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
syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core?
environment? bytecode? exception? macro? context? file-descriptor?
Number Bignum Flonum Integer Char Boolean
Symbol String Byte-Vector Vector Pair
Context Lam Cnd Set Ref Seq Lit Sc Exception
syntactic-closure? lambda? cnd? set? ref? seq? lit? type?
environment? bytecode? exception? macro? context?
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
copy-lambda make-lambda make-cnd make-ref make-set make-seq make-lit
make-macro
lambda-name lambda-params lambda-body lambda-defs lambda-locals
lambda-flags lambda-free-vars lambda-set-vars lambda-return-type
lambda-param-types lambda-source
@ -21,29 +19,21 @@
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
exception-kind exception-message exception-irritants
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?
bytecode-name bytecode-literals bytecode-source
port-line port-line-set! port-source? port-source?-set!
extend-env env-parent env-parent-set! env-lambda env-lambda-set!
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)
port-line port-line-set!
environment-parent
type-name type-cpl type-parent type-slots type-num-slots type-printer
object-size integer->immediate gc atomically
string-contains integer->error-string
flatten-dot update-free-vars!)
(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))))

244
lib/chibi/base64.scm
View file

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

36
lib/chibi/base64.sld
View file

@ -1,37 +1,7 @@
(define-library (chibi base64)
(export base64-encode base64-encode-string base64-encode-bytevector
base64-decode base64-decode-string base64-decode-bytevector
(export base64-encode base64-encode-string
base64-decode base64-decode-string
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 (chibi) (srfi 33) (chibi io))
(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))))

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

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

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

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

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

146
lib/chibi/bytevector.scm
View file

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

41
lib/chibi/bytevector.sld
View file

@ -1,41 +0,0 @@
;;> 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"))))

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

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

@ -1,12 +1,9 @@
;;> 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
char-set-fold char-set-for-each
list->char-set char-set->list string->char-set char-set->string
char-set-adjoin! char-set-adjoin char-set-union char-set-union!
char-set-intersection char-set-intersection!

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

8
lib/chibi/char-set/ascii.sld
View file

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

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

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

File diff suppressed because one or more lines are too long

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

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

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

@ -2,24 +2,16 @@
(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)
(define char-set-size iset-size)
(define (char-set-fold kons knil cset)
(iset-fold (lambda (i acc) (kons (integer->char i) acc)) knil cset))
(define (char-set-for-each proc cset)
(iset-for-each (lambda (i) (proc (integer->char i))) cset))
(define (list->char-set ls . o)
(apply list->iset (map char->integer ls) o))
(define (list->char-set ls)
(list->iset (map char->integer ls)))
(define (char-set->list cset)
(map integer->char (iset->list cset)))
@ -28,10 +20,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!)

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

@ -1,13 +1,9 @@
(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
char-set-fold char-set-for-each
list->char-set char-set->list string->char-set char-set->string
char-set-adjoin! char-set-adjoin char-set-union char-set-union!
char-set-intersection char-set-intersection!

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

File diff suppressed because one or more lines are too long

511
lib/chibi/config.scm
View file

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

27
lib/chibi/config.sld
View file

@ -1,27 +0,0 @@
(define-library (chibi config)
(export make-conf conf? conf-load conf-load-in-path conf-load-cascaded
conf-verify conf-extend conf-append conf-set conf-unfold-key
conf-get conf-get-list conf-get-cdr conf-get-multi
conf-specialize read-from-file conf-source conf-head conf-parent
assoc-get assoc-get-list)
(import (scheme base) (scheme read) (scheme write) (scheme file)
(scheme time) (srfi 1))
;; 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))))))
(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))))

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

@ -1,366 +0,0 @@
;; md5.scm -- pure R7RS md5 implementation (originally from hato)
;; Copyright (c) 2009-2014 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; Break computations down into 16-bit words to keep everything in
;; fixnum even on 32-bit machines.
;; All values are in little-endian.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities.
(define (extract-byte n i)
(bitwise-and #xFF (arithmetic-shift n (* i -8))))
;; integer->hex-string is big-endian, so we adjust here
(define (hex-byte n)
(if (< n 16)
(string-append "0" (number->string n 16))
(number->string n 16)))
(define (hex n)
(string-append (hex-byte (remainder n 256))
(hex-byte (quotient n 256))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 3. MD5 Algorithm Description
;; We begin by supposing that we have a b-bit message as input, and that
;; we wish to find its message digest. Here b is an arbitrary
;; nonnegative integer; b may be zero, it need not be a multiple of
;; eight, and it may be arbitrarily large. We imagine the bits of the
;; message written down as follows:
;; m_0 m_1 ... m_{b-1}
;; The following five steps are performed to compute the message digest
;; of the message.
;; 3.1 Step 1. Append Padding Bits
;; The message is "padded" (extended) so that its length (in bits) is
;; congruent to 448, modulo 512. That is, the message is extended so
;; that it is just 64 bits shy of being a multiple of 512 bits long.
;; Padding is always performed, even if the length of the message is
;; already congruent to 448, modulo 512.
;; Padding is performed as follows: a single "1" bit is appended to the
;; message, and then "0" bits are appended so that the length in bits of
;; the padded message becomes congruent to 448, modulo 512. In all, at
;; least one bit and at most 512 bits are appended.
;; 3.2 Step 2. Append Length
;; A 64-bit representation of b (the length of the message before the
;; padding bits were added) is appended to the result of the previous
;; step. In the unlikely event that b is greater than 2^64, then only
;; the low-order 64 bits of b are used. (These bits are appended as two
;; 32-bit words and appended low-order word first in accordance with the
;; previous conventions.)
;; At this point the resulting message (after padding with bits and with
;; b) has a length that is an exact multiple of 512 bits. Equivalently,
;; this message has a length that is an exact multiple of 16 (32-bit)
;; words. Let M[0 ... N-1] denote the words of the resulting message,
;; where N is a multiple of 16.
;; 3.3 Step 3. Initialize MD Buffer
;; A four-word buffer (A,B,C,D) is used to compute the message digest.
;; Here each of A, B, C, D is a 32-bit register. These registers are
;; initialized to the following values in hexadecimal, low-order bytes
;; first):
;; word A: 01 23 45 67
;; word B: 89 ab cd ef
;; word C: fe dc ba 98
;; word D: 76 54 32 10
;; 3.4 Step 4. Process Message in 16-Word Blocks
;; We first define four auxiliary functions that each take as input
;; three 32-bit words and produce as output one 32-bit word.
;; F(X,Y,Z) = XY v not(X) Z
;; G(X,Y,Z) = XZ v Y not(Z)
;; H(X,Y,Z) = X xor Y xor Z
;; I(X,Y,Z) = Y xor (X v not(Z))
;; In each bit position F acts as a conditional: if X then Y else Z.
;; The function F could have been defined using + instead of v since XY
;; and not(X)Z will never have 1's in the same bit position.) It is
;; interesting to note that if the bits of X, Y, and Z are independent
;; and unbiased, the each bit of F(X,Y,Z) will be independent and
;; unbiased.
;; The functions G, H, and I are similar to the function F, in that they
;; act in "bitwise parallel" to produce their output from the bits of X,
;; Y, and Z, in such a manner that if the corresponding bits of X, Y,
;; and Z are independent and unbiased, then each bit of G(X,Y,Z),
;; H(X,Y,Z), and I(X,Y,Z) will be independent and unbiased. Note that
;; the function H is the bit-wise "xor" or "parity" function of its
;; inputs.
;; This step uses a 64-element table T[1 ... 64] constructed from the
;; sine function. Let T[i] denote the i-th element of the table, which
;; is equal to the integer part of 4294967296 times abs(sin(i)), where i
;; is in radians. The elements of the table are given in the appendix.
;; (define T
;; (do ((i 64 (- i 1))
;; (ls '()
;; (cons (u32 (exact (truncate (* 4294967296 (abs (sin i))))))
;; ls)))
;; ((< i 0) (list->vector ls))))
(define T
'#(0 0 #xd76a #xa478 #xe8c7 #xb756 #x2420 #x70db #xc1bd #xceee
#xf57c #x0faf #x4787 #xc62a #xa830 #x4613 #xfd46 #x9501 #x6980 #x98d8
#x8b44 #xf7af #xffff #x5bb1 #x895c #xd7be #x6b90 #x1122 #xfd98 #x7193
#xa679 #x438e #x49b4 #x0821 #xf61e #x2562 #xc040 #xb340 #x265e #x5a51
#xe9b6 #xc7aa #xd62f #x105d #x0244 #x1453 #xd8a1 #xe681 #xe7d3 #xfbc8
#x21e1 #xcde6 #xc337 #x07d6 #xf4d5 #x0d87 #x455a #x14ed #xa9e3 #xe905
#xfcef #xa3f8 #x676f #x02d9 #x8d2a #x4c8a #xfffa #x3942 #x8771 #xf681
#x6d9d #x6122 #xfde5 #x380c #xa4be #xea44 #x4bde #xcfa9 #xf6bb #x4b60
#xbebf #xbc70 #x289b #x7ec6 #xeaa1 #x27fa #xd4ef #x3085 #x0488 #x1d05
#xd9d4 #xd039 #xe6db #x99e5 #x1fa2 #x7cf8 #xc4ac #x5665 #xf429 #x2244
#x432a #xff97 #xab94 #x23a7 #xfc93 #xa039 #x655b #x59c3 #x8f0c #xcc92
#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))
((input-port? src) src)
(else (error "unknown digest source: " src))))
;; 3.3 Step 3. Initialize MD Buffer
(buf (make-bytevector 64 0))
(vec (make-vector 32))
(A1 #x6745) (A0 #x2301)
(B1 #xefcd) (B0 #xab89)
(C1 #x98ba) (C0 #xdcfe)
(D1 #x1032) (D0 #x5476))
;; Process each 16-word block.
(let lp ((i 0)
(pad #x80))
(let* ((n (read-bytevector! buf in))
(n (if (eof-object? n) 0 n)))
(cond
((< n 64)
(let ((len (* 8 (+ i n))))
;; 3.1 Step 1. Append Padding Bits
(bytevector-u8-set! buf n pad)
(do ((j (+ n 1) (+ j 1))) ((>= j 64))
(bytevector-u8-set! buf j 0))
;; 3.2 Step 2. Append Length
(cond
((< n 56)
(bytevector-u8-set! buf 56 (extract-byte len 0))
(bytevector-u8-set! buf 57 (extract-byte len 1))
(bytevector-u8-set! buf 58 (extract-byte len 2))
(bytevector-u8-set! buf 59 (extract-byte len 3))
(bytevector-u8-set! buf 60 (extract-byte len 4))
(bytevector-u8-set! buf 61 (extract-byte len 5))
(bytevector-u8-set! buf 62 (extract-byte len 6))
(bytevector-u8-set! buf 63 (extract-byte len 7)))))))
;; 3.4 Step 4. Process Message in 16-Word Blocks
;;
;; Copy block i into X.
(do ((j 0 (+ j 1)))
((= j 16))
(vector-set! vec (* j 2) (bytevector-u16-ref-le buf (* j 4)))
(vector-set! vec
(+ (* j 2) 1)
(bytevector-u16-ref-le buf (+ (* j 4) 2))))
;; Save A as AA, B as BB, C as CC, and D as DD.
(let ((AA0 A0) (AA1 A1)
(BB0 B0) (BB1 B1)
(CC0 C0) (CC1 C1)
(DD0 D0) (DD1 D1)
(T1 0) (T0 0))
(letrec-syntax
((add
(syntax-rules ()
((add d1 d0 a1 a0 b1 b0)
(begin
(set! d0 (+ a0 b0))
(set! d1 (bitwise-and
(+ a1 b1 (arithmetic-shift d0 -16))
#xFFFF))
(set! d0 (bitwise-and d0 #xFFFF))))))
(rot
(syntax-rules ()
((rot d1 d0 a1 a0 s)
(let ((tmp a1))
(set! d1 (bitwise-and
(bitwise-ior (arithmetic-shift a1 s)
(arithmetic-shift a1 (- s 32))
(arithmetic-shift a0 (- s 16)))
#xFFFF))
(set! d0 (bitwise-and
(bitwise-ior (arithmetic-shift a0 s)
(arithmetic-shift a0 (- s 32))
(arithmetic-shift tmp (- s 16)))
#xFFFF))))))
(bit-not
(syntax-rules ()
((bit-not a) (- (expt 2 16) a 1))))
(FF
(syntax-rules ()
((FF d1 d0 x1 x0 y1 y0 z1 z0)
(begin
(set! d1 (bitwise-ior (bitwise-and x1 y1)
(bitwise-and (bit-not x1) z1)))
(set! d0 (bitwise-ior (bitwise-and x0 y0)
(bitwise-and (bit-not x0) z0)))
))))
(GG
(syntax-rules ()
((GG d1 d0 x1 x0 y1 y0 z1 z0)
(begin
(set! d1 (bitwise-ior (bitwise-and x1 z1)
(bitwise-and y1 (bit-not z1))))
(set! d0 (bitwise-ior (bitwise-and x0 z0)
(bitwise-and y0 (bit-not z0))))
))))
(HH
(syntax-rules ()
((HH d1 d0 x1 x0 y1 y0 z1 z0)
(begin (set! d1 (bitwise-xor x1 y1 z1))
(set! d0 (bitwise-xor x0 y0 z0))))))
(II
(syntax-rules ()
((II d1 d0 x1 x0 y1 y0 z1 z0)
(begin
(set! d1 (bitwise-xor y1 (bitwise-ior x1 (bit-not z1))))
(set! d0 (bitwise-xor y0 (bitwise-ior x0 (bit-not z0))))
))))
(R
(syntax-rules ()
((R op T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
(begin
(op T1 T0 b1 b0 c1 c0 d1 d0)
(add T1 T0 T1 T0
(vector-ref vec (+ (* k 2) 1))
(vector-ref vec (* k 2)))
(add T1 T0 T1 T0
(vector-ref T (* i 2))
(vector-ref T (+ (* i 2) 1)))
(add a1 a0 a1 a0 T1 T0)
(rot a1 a0 a1 a0 s)
(add a1 a0 a1 a0 b1 b0)))))
(R1 (syntax-rules ()
((R1 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
(R FF T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i))))
(R2 (syntax-rules ()
((R2 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
(R GG T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i))))
(R3 (syntax-rules ()
((R3 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
(R HH T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i))))
(R4 (syntax-rules ()
((R4 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
(R II T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)))))
;; Round 1: Let [abcd k s i] denote the operation
;; a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
(R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 0 7 1)
(R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 1 12 2)
(R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 2 17 3)
(R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 3 22 4)
(R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 4 7 5)
(R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 5 12 6)
(R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 6 17 7)
(R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 7 22 8)
(R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 8 7 9)
(R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 9 12 10)
(R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 10 17 11)
(R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 11 22 12)
(R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 12 7 13)
(R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 13 12 14)
(R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 14 17 15)
(R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 15 22 16)
;; Round 2: Let [abcd k s i] denote the operation
;; a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s)
(R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 1 5 17)
(R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 6 9 18)
(R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 11 14 19)
(R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 0 20 20)
(R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 5 5 21)
(R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 10 9 22)
(R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 15 14 23)
(R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 4 20 24)
(R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 9 5 25)
(R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 14 9 26)
(R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 3 14 27)
(R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 8 20 28)
(R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 13 5 29)
(R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 2 9 30)
(R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 7 14 31)
(R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 12 20 32)
;; Round 3: Let [abcd k s i] denote the operation
;; a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s)
(R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 5 4 33)
(R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 8 11 34)
(R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 11 16 35)
(R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 14 23 36)
(R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 1 4 37)
(R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 4 11 38)
(R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 7 16 39)
(R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 10 23 40)
(R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 13 4 41)
(R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 0 11 42)
(R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 3 16 43)
(R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 6 23 44)
(R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 9 4 45)
(R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 12 11 46)
(R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 15 16 47)
(R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 2 23 48)
;; Round 4: Let [abcd k s i] denote the operation
;; a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s)
(R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 0 6 49)
(R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 7 10 50)
(R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 14 15 51)
(R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 5 21 52)
(R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 12 6 53)
(R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 3 10 54)
(R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 10 15 55)
(R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 1 21 56)
(R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 8 6 57)
(R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 15 10 58)
(R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 6 15 59)
(R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 13 21 60)
(R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 4 6 61)
(R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 11 10 62)
(R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 2 15 63)
(R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 9 21 64)
;; Then in increment each of the four registers by the
;; value it had before this block was started.
(add A1 A0 A1 A0 AA1 AA0)
(add B1 B0 B1 B0 BB1 BB0)
(add C1 C0 C1 C0 CC1 CC0)
(add D1 D0 D1 D0 DD1 DD0)
(cond
((< n 64)
;; 3.5 Step 5. Output
;;
;; The message digest produced as output is A, B, C,
;; D. That is, we begin with the low-order byte of A,
;; and end with the high-order byte of D.
(if (>= n 56)
(lp (+ i n) 0)
(string-append
(hex A0) (hex A1)
(hex B0) (hex B1)
(hex C0) (hex C1)
(hex D0) (hex D1))))
(else
(lp (+ i 64) pad)))))))))
;; This completes the description of MD5. A reference implementation in
;; C is given in the appendix.

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