mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
Compare commits
No commits in common. "master" and "0.7.3" have entirely different histories.
613 changed files with 8065 additions and 66270 deletions
|
@ -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
23
.github/workflows/CI.yaml
vendored
|
@ -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
|
|
26
.gitignore
vendored
26
.gitignore
vendored
|
@ -1,6 +1,5 @@
|
||||||
# Object files
|
# Object files
|
||||||
*.o
|
*.o
|
||||||
*.bc
|
|
||||||
*.ko
|
*.ko
|
||||||
*.obj
|
*.obj
|
||||||
*.elf
|
*.elf
|
||||||
|
@ -17,7 +16,6 @@
|
||||||
|
|
||||||
# Shared objects (inc. Windows DLLs)
|
# Shared objects (inc. Windows DLLs)
|
||||||
*.dll
|
*.dll
|
||||||
*.dll.*
|
|
||||||
*.so
|
*.so
|
||||||
*.so.*
|
*.so.*
|
||||||
*.dylib
|
*.dylib
|
||||||
|
@ -38,7 +36,6 @@ lib/.*.meta
|
||||||
|
|
||||||
# Generated files
|
# Generated files
|
||||||
chibi-scheme
|
chibi-scheme
|
||||||
chibi-scheme-emscripten
|
|
||||||
chibi-scheme.pc
|
chibi-scheme.pc
|
||||||
include/chibi/install.h
|
include/chibi/install.h
|
||||||
lib/chibi/emscripten.c
|
lib/chibi/emscripten.c
|
||||||
|
@ -46,30 +43,12 @@ lib/chibi/filesystem.c
|
||||||
lib/chibi/io/io.c
|
lib/chibi/io/io.c
|
||||||
lib/chibi/net.c
|
lib/chibi/net.c
|
||||||
lib/chibi/process.c
|
lib/chibi/process.c
|
||||||
lib/chibi/pty.c
|
|
||||||
lib/chibi/snow/install.sld
|
|
||||||
lib/chibi/stty.c
|
lib/chibi/stty.c
|
||||||
lib/chibi/system.c
|
lib/chibi/system.c
|
||||||
lib/chibi/time.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
|
*.tgz
|
||||||
*.bz2
|
|
||||||
*.xz
|
|
||||||
*.html
|
*.html
|
||||||
*.img
|
|
||||||
*.err
|
|
||||||
*.fasl
|
|
||||||
*.txt
|
|
||||||
!CMakeLists.txt
|
|
||||||
*.test
|
|
||||||
*.train
|
|
||||||
*.h5
|
|
||||||
!index.html
|
|
||||||
|
|
||||||
benchmarks/gabriel/times.tsv
|
|
||||||
examples/snow-fort
|
examples/snow-fort
|
||||||
examples/synthcode
|
examples/synthcode
|
||||||
tests/snow/repo-cache
|
tests/snow/repo-cache
|
||||||
|
@ -79,8 +58,3 @@ tmp
|
||||||
/lib/chibi/crypto/crypto.c
|
/lib/chibi/crypto/crypto.c
|
||||||
/chibi-scheme-ulimit
|
/chibi-scheme-ulimit
|
||||||
/clibs.c
|
/clibs.c
|
||||||
|
|
||||||
js/chibi.*
|
|
||||||
|
|
||||||
build-lib/chibi/char-set/derived.scm
|
|
||||||
build-lib/chibi/char-set/width.scm
|
|
||||||
|
|
|
@ -1,4 +0,0 @@
|
||||||
language: c
|
|
||||||
compiler:
|
|
||||||
- clang
|
|
||||||
- gcc
|
|
40
AUTHORS
40
AUTHORS
|
@ -1,11 +1,6 @@
|
||||||
Alex Shinn wrote the initial version of chibi-scheme and all
|
Alex Shinn wrote the initial version of chibi-scheme and all
|
||||||
distributed modules.
|
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
|
The `dynamic-wind' implementation is adapted from the implementation
|
||||||
in the appendix to the Scheme48 reference manual, reportedly first
|
in the appendix to the Scheme48 reference manual, reportedly first
|
||||||
written by Chris Hanson and John Lamping.
|
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
|
from Alan Watson's Scheme clock library at
|
||||||
http://code.google.com/p/scheme-clock/ under the same license.
|
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
|
The benchmarks are based on the Racket versions of the classic
|
||||||
Gabriel benchmarks from
|
Gabriel benchmarks from
|
||||||
http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html.
|
http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html.
|
||||||
|
@ -32,58 +16,36 @@ They are not installed or needed but are included for convenience.
|
||||||
|
|
||||||
Thanks to the following people for patches and bug reports:
|
Thanks to the following people for patches and bug reports:
|
||||||
|
|
||||||
* Adam Feuer
|
|
||||||
* Alan Watson
|
* Alan Watson
|
||||||
* Alexei Lozovsky
|
* Alexei Lozovsky
|
||||||
* Alexander Shendi
|
* Alexander Shendi
|
||||||
* Andreas Rottman
|
* Andreas Rottman
|
||||||
* Arthur Gleckler
|
|
||||||
* Bakul Shah
|
* Bakul Shah
|
||||||
* Ben Davenport-Ray
|
|
||||||
* Ben Mather
|
* Ben Mather
|
||||||
* Ben Weaver
|
* Ben Weaver
|
||||||
* Bertrand Augereau
|
|
||||||
* Bradley Lucier
|
|
||||||
* Bruno Deferrari
|
* Bruno Deferrari
|
||||||
* Damien Diederen
|
|
||||||
* Daphne Preston-Kendal
|
|
||||||
* Doug Currie
|
* Doug Currie
|
||||||
* Derrick Eddington
|
* Derrick Eddington
|
||||||
* Dmitry Chestnykh
|
* Dmitry Chestnykh
|
||||||
* Eduardo Cavazos
|
* Eduardo Cavazos
|
||||||
* Ekaitz Zarraga
|
|
||||||
* Felix Winkelmann
|
* Felix Winkelmann
|
||||||
* Gregor Klinke
|
* Gregor Klinke
|
||||||
* Jeremy Wolff
|
* Jeremy Wolff
|
||||||
* Jeronimo Pellegrini
|
* Jeronimo Pellegrini
|
||||||
* John Cowan
|
* John Cowan
|
||||||
* John Samsa
|
* John Samsa
|
||||||
* Jonas Rinke
|
|
||||||
* Kris Katterjohn
|
|
||||||
* Lars J Aas
|
* Lars J Aas
|
||||||
* Lassi Kortela
|
|
||||||
* Lorenzo Campedelli
|
* Lorenzo Campedelli
|
||||||
* Lukas Böger
|
|
||||||
* Marc Nieper-Wißkirchen
|
* Marc Nieper-Wißkirchen
|
||||||
* McKay Marston
|
|
||||||
* Meng Zhang
|
* Meng Zhang
|
||||||
* Michal Kowalski (sladegen)
|
* Michal Kowalski (sladegen)
|
||||||
* Miroslav Urbanek
|
* Miroslav Urbanek
|
||||||
* Naoki Koguro
|
|
||||||
* Nguyễn Thái Ngọc Duy
|
|
||||||
* Petteri Piiroinen
|
|
||||||
* Rajesh Krishnan
|
* Rajesh Krishnan
|
||||||
* Ricardo G. Herdt
|
|
||||||
* Roger Crew
|
|
||||||
* Seth Alves
|
* Seth Alves
|
||||||
* Sören Tempel
|
|
||||||
* Stephen Lewis
|
* Stephen Lewis
|
||||||
* Taylor Venable
|
* Taylor Venable
|
||||||
* Travis Cross
|
* Travis Cross
|
||||||
* Vasilij Schneidermann
|
* Zhang Meng
|
||||||
* Vitaliy Mysak
|
|
||||||
* Yota Toyama
|
|
||||||
* Yuki Okumura
|
|
||||||
|
|
||||||
If you would prefer not to be listed, or are one of the users listed
|
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
|
without a full name, please contact me. If you've made a contribution
|
||||||
|
|
603
CMakeLists.txt
603
CMakeLists.txt
|
@ -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)
|
|
|
@ -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
2
COPYING
|
@ -1,4 +1,4 @@
|
||||||
Copyright (c) 2009-2021 Alex Shinn
|
Copyright (c) 2009-2015 Alex Shinn
|
||||||
All rights reserved.
|
All rights reserved.
|
||||||
|
|
||||||
Redistribution and use in source and binary forms, with or without
|
Redistribution and use in source and binary forms, with or without
|
||||||
|
|
363
Makefile
363
Makefile
|
@ -1,112 +1,94 @@
|
||||||
# -*- makefile-gmake -*-
|
# -*- makefile-gmake -*-
|
||||||
|
|
||||||
.PHONY: dist mips-dist cleaner distclean dist-clean test test-all test-dist checkdefs debian snowballs init-dev
|
.PHONY: dist mips-dist cleaner test test-all test-dist checkdefs debian snowballs
|
||||||
.DEFAULT_GOAL := all
|
.DEFAULT_GOAL := all
|
||||||
|
|
||||||
CHIBI_VERSION ?= $(shell cat VERSION)
|
VERSION ?= $(shell cat VERSION)
|
||||||
SOVERSION ?= $(CHIBI_VERSION)
|
SOVERSION ?= $(VERSION)
|
||||||
SOVERSION_MAJOR ?= $(shell echo "$(SOVERSION)" | sed "s/\..*//")
|
SOVERSION_MAJOR ?= $(shell echo "$(SOVERSION)" | sed "s/\..*//")
|
||||||
|
|
||||||
CHIBI_FFI ?= $(CHIBI) -q tools/chibi-ffi
|
CHIBI_FFI ?= $(CHIBI) -q tools/chibi-ffi
|
||||||
CHIBI_FFI_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-ffi
|
CHIBI_FFI_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-ffi
|
||||||
|
|
||||||
CHIBI_DOC ?= $(CHIBI) tools/chibi-doc
|
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
|
GENSTATIC ?= ./tools/chibi-genstatic
|
||||||
|
|
||||||
CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH=".:$(DYLD_LIBRARY_PATH)" CHIBI_IGNORE_SYSTEM_PATH=1 CHIBI_MODULE_PATH=lib ./chibi-scheme$(EXE)
|
CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH=".:$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH=lib ./chibi-scheme$(EXE)
|
||||||
CHIBI_DEPENDENCIES = ./chibi-scheme$(EXE)
|
CHIBI_DEPENDENCIES = ./chibi-scheme$(EXE)
|
||||||
|
|
||||||
SNOW_CHIBI ?= tools/snow-chibi
|
SNOW_CHIBI ?= $(CHIBI) tools/snow-chibi
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
|
|
||||||
CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/weak$(SO) \
|
CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
|
||||||
lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) lib/chibi/ast$(SO) \
|
lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/stty$(SO) \
|
||||||
lib/chibi/json$(SO) lib/chibi/emscripten$(SO)
|
lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
|
||||||
CHIBI_POSIX_COMPILED_LIBS = lib/chibi/process$(SO) lib/chibi/time$(SO) \
|
lib/chibi/net$(SO) lib/chibi/ast$(SO) lib/chibi/emscripten$(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_CRYPTO_COMPILED_LIBS = lib/chibi/crypto/crypto$(SO)
|
||||||
CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)
|
CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)
|
||||||
CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
|
CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
|
||||||
lib/chibi/optimize/profile$(SO)
|
lib/chibi/optimize/profile$(SO)
|
||||||
EXTRA_COMPILED_LIBS ?=
|
EXTRA_COMPILED_LIBS ?=
|
||||||
|
|
||||||
COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
|
COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
|
||||||
$(CHIBI_OPT_COMPILED_LIBS) $(CHIBI_CRYPTO_COMPILED_LIBS) \
|
$(CHIBI_OPT_COMPILED_LIBS) $(CHIBI_CRYPTO_COMPILED_LIBS) \
|
||||||
$(EXTRA_COMPILED_LIBS) \
|
$(EXTRA_COMPILED_LIBS) \
|
||||||
lib/srfi/27/rand$(SO) lib/srfi/151/bit$(SO) \
|
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/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/srfi/98/env$(SO) lib/scheme/time$(SO)
|
||||||
lib/scheme/bytevector$(SO) lib/scheme/time$(SO)
|
|
||||||
|
|
||||||
BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
|
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 \
|
MODULE_DOCS := app ast config disasm equiv filesystem generic heap-stats io \
|
||||||
crypto/md5 crypto/rsa crypto/sha2 diff disasm doc edit-distance \
|
loop match mime modules net parse pathname process repl scribble stty \
|
||||||
equiv filesystem generic heap-stats io \
|
system test time trace type-inference uri weak monad/environment \
|
||||||
iset/base iset/constructors iset/iterators json loop \
|
show show/base crypto/sha2
|
||||||
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
|
|
||||||
|
|
||||||
IMAGE_FILES = lib/chibi.img lib/red.img lib/snow.img
|
HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
|
||||||
|
|
||||||
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
|
META_FILES = lib/.chibi.meta lib/.srfi.meta lib/.scheme.meta
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
# This includes the rules to build optional libraries.
|
|
||||||
# It also pulls in Makefile.detect for platform detection.
|
|
||||||
|
|
||||||
include Makefile.libs
|
include Makefile.libs
|
||||||
|
|
||||||
|
########################################################################
|
||||||
|
# Library config.
|
||||||
|
#
|
||||||
|
# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to
|
||||||
|
# automatically include the necessary compiler and linker flags in
|
||||||
|
# addition to setting those features. If not using GNU make just
|
||||||
|
# comment out the ifs and use the else branches for the defaults.
|
||||||
|
|
||||||
|
ifeq ($(SEXP_USE_BOEHM),1)
|
||||||
|
GCLDFLAGS := -lgc
|
||||||
|
XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
|
||||||
|
else
|
||||||
|
GCLDFLAGS :=
|
||||||
|
XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
|
||||||
|
endif
|
||||||
|
|
||||||
|
ifeq ($(SEXP_USE_DL),0)
|
||||||
|
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
|
||||||
|
XCFLAGS := -Wall -DSEXP_USE_DL=0 -g -g3 -O3 $(CFLAGS)
|
||||||
|
else
|
||||||
|
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
|
||||||
|
XCFLAGS := -Wall -g -g3 -O3 $(CFLAGS)
|
||||||
|
endif
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
|
|
||||||
all: chibi-scheme$(EXE) all-libs chibi-scheme.pc $(META_FILES)
|
all: chibi-scheme$(EXE) all-libs chibi-scheme.pc $(META_FILES)
|
||||||
|
|
||||||
# Please run this if you want to contribute.
|
include/chibi/install.h: Makefile
|
||||||
init-dev:
|
|
||||||
git config core.hooksPath .githooks
|
|
||||||
|
|
||||||
js: js/chibi.js
|
|
||||||
|
|
||||||
js/chibi.js: chibi-scheme-emscripten chibi-scheme-static.bc js/pre.js js/post.js js/exported_functions.json
|
|
||||||
emcc -O0 chibi-scheme-static.bc -o $@ -s ALLOW_MEMORY_GROWTH=1 -s MODULARIZE=1 -s EXPORT_NAME=\"Chibi\" -s EXPORTED_FUNCTIONS=@js/exported_functions.json `find lib -type f \( -name "*.scm" -or -name "*.sld" \) -printf " --preload-file %p"` -s 'EXTRA_EXPORTED_RUNTIME_METHODS=["ccall", "cwrap"]' --pre-js js/pre.js --post-js js/post.js
|
|
||||||
|
|
||||||
chibi-scheme-static.bc:
|
|
||||||
emmake $(MAKE) PLATFORM=emscripten CHIBI_DEPENDENCIES= CHIBI=./chibi-scheme-emscripten PREFIX= CFLAGS=-O2 SEXP_USE_DL=0 EXE=.bc SO=.bc STATICFLAGS=-shared CPPFLAGS="-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1 -DSEXP_USE_ALIGNED_BYTECODE=1 -DSEXP_USE_STATIC_LIBS=1 -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0" clibs.c chibi-scheme-static.bc VERBOSE=1
|
|
||||||
|
|
||||||
chibi-scheme-emscripten: VERSION
|
|
||||||
$(MAKE) distclean
|
|
||||||
$(MAKE) chibi-scheme-static PLATFORM=emscripten SEXP_USE_DL=0
|
|
||||||
(tempfile="`mktemp -t chibi.XXXXXX`" && \
|
|
||||||
mv chibi-scheme-static$(EXE) "$$tempfile" && \
|
|
||||||
$(MAKE) distclean; \
|
|
||||||
mv "$$tempfile" chibi-scheme-emscripten)
|
|
||||||
|
|
||||||
include/chibi/install.h: Makefile.libs Makefile.detect
|
|
||||||
echo '#define sexp_so_extension "'$(SO)'"' > $@
|
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_platform "'$(PLATFORM)'"' >> $@
|
||||||
echo '#define sexp_architecture "'$(ARCH)'"' >> $@
|
echo '#define sexp_version "'$(VERSION)'"' >> $@
|
||||||
echo '#define sexp_version "'$(CHIBI_VERSION)'"' >> $@
|
|
||||||
echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@
|
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)
|
%.o: %.c $(BASE_INCLUDES)
|
||||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
|
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
|
||||||
|
|
||||||
|
@ -119,8 +101,8 @@ sexp-ulimit.o: sexp.c $(BASE_INCLUDES)
|
||||||
main.o: main.c $(INCLUDES)
|
main.o: main.c $(INCLUDES)
|
||||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
|
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
|
||||||
|
|
||||||
SEXP_OBJS = gc.o sexp.o bignum.o gc_heap.o
|
SEXP_OBJS = gc.o sexp.o bignum.o
|
||||||
SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o gc_heap.o
|
SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o
|
||||||
EVAL_OBJS = opcodes.o vm.o eval.o simplify.o
|
EVAL_OBJS = opcodes.o vm.o eval.o simplify.o
|
||||||
|
|
||||||
libchibi-sexp$(SO): $(SEXP_OBJS)
|
libchibi-sexp$(SO): $(SEXP_OBJS)
|
||||||
|
@ -130,29 +112,25 @@ libchibi-scheme$(SO_VERSIONED_SUFFIX): $(SEXP_OBJS) $(EVAL_OBJS)
|
||||||
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(LIBCHIBI_FLAGS) -o $@ $^ $(XLDFLAGS)
|
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(LIBCHIBI_FLAGS) -o $@ $^ $(XLDFLAGS)
|
||||||
|
|
||||||
libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX): libchibi-scheme$(SO_VERSIONED_SUFFIX)
|
libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX): libchibi-scheme$(SO_VERSIONED_SUFFIX)
|
||||||
$(LN) $< $@
|
$(LN) -sf $< $@
|
||||||
|
|
||||||
libchibi-scheme$(SO): libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
libchibi-scheme$(SO): libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
||||||
$(LN) $< $@
|
$(LN) -sf $< $@
|
||||||
|
|
||||||
libchibi-scheme.a: $(SEXP_OBJS) $(EVAL_OBJS)
|
libchibi-scheme.a: $(SEXP_OBJS) $(EVAL_OBJS)
|
||||||
$(AR) rcs $@ $^
|
$(AR) rcs $@ $^
|
||||||
|
|
||||||
chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
|
chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
|
||||||
$(CC) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) -lchibi-scheme
|
$(CC) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. -lchibi-scheme
|
||||||
|
|
||||||
chibi-scheme-static$(EXE): main.o $(SEXP_OBJS) $(EVAL_OBJS)
|
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)
|
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)
|
clibs.c: $(GENSTATIC) $(CHIBI_DEPENDENCIES) $(COMPILED_LIBS:%$(SO)=%.c)
|
||||||
if [ -d .git ]; then \
|
$(FIND) lib -name \*.sld | $(CHIBI) -q $(GENSTATIC) > $@
|
||||||
$(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
|
chibi-scheme.pc: chibi-scheme.pc.in
|
||||||
echo "# pkg-config" > chibi-scheme.pc
|
echo "# pkg-config" > chibi-scheme.pc
|
||||||
|
@ -160,39 +138,23 @@ chibi-scheme.pc: chibi-scheme.pc.in
|
||||||
echo "exec_prefix=\$${prefix}" >> chibi-scheme.pc
|
echo "exec_prefix=\$${prefix}" >> chibi-scheme.pc
|
||||||
echo "libdir=$(LIBDIR)" >> chibi-scheme.pc
|
echo "libdir=$(LIBDIR)" >> chibi-scheme.pc
|
||||||
echo "includedir=\$${prefix}/include" >> chibi-scheme.pc
|
echo "includedir=\$${prefix}/include" >> chibi-scheme.pc
|
||||||
echo "version=$(CHIBI_VERSION)" >> chibi-scheme.pc
|
echo "version=$(VERSION)" >> chibi-scheme.pc
|
||||||
echo "" >> chibi-scheme.pc
|
echo "" >> chibi-scheme.pc
|
||||||
cat chibi-scheme.pc.in >> chibi-scheme.pc
|
cat chibi-scheme.pc.in >> chibi-scheme.pc
|
||||||
|
|
||||||
# A special case, this needs to be linked with the LDFLAGS in case
|
# A special case, this needs to be linked with the LDFLAGS in case
|
||||||
# we're using Boehm.
|
# we're using Boehm.
|
||||||
lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES) libchibi-scheme$(SO)
|
lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES) libchibi-scheme$(SO)
|
||||||
-$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< $(GCLDFLAGS) -L. $(RLDFLAGS) -lchibi-scheme
|
-$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< $(GCLDFLAGS) -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: doc/chibi.html doc-libs
|
doc: doc/chibi.html doc-libs
|
||||||
|
|
||||||
%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
|
%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
|
||||||
$(CHIBI_DOC) --html $< > $@
|
$(CHIBI_DOC) --html $< > $@
|
||||||
|
|
||||||
lib/.%.meta: lib/%/ tools/generate-install-meta.scm $(CHIBI_DEPENDENCIES)
|
lib/.%.meta: lib/%/ tools/generate-install-meta.scm
|
||||||
-$(FIND) $< -name \*.sld | \
|
-$(FIND) $< -name \*.sld | \
|
||||||
$(CHIBI) tools/generate-install-meta.scm $(CHIBI_VERSION) > $@
|
$(CHIBI) tools/generate-install-meta.scm $(VERSION) > $@
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
# Dist builds - rules to build generated files included in distribution
|
# Dist builds - rules to build generated files included in distribution
|
||||||
|
@ -205,25 +167,14 @@ data/%.txt:
|
||||||
build-lib/chibi/char-set/derived.scm: data/UnicodeData.txt data/DerivedCoreProperties.txt chibi-scheme$(EXE)
|
build-lib/chibi/char-set/derived.scm: data/UnicodeData.txt data/DerivedCoreProperties.txt chibi-scheme$(EXE)
|
||||||
$(CHIBI) tools/extract-unicode-props.scm --default > $@
|
$(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)
|
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 > $@
|
$(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)
|
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 > $@
|
$(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)
|
lib/scheme/char/case-offsets.scm: data/CaseFolding.txt chibi-scheme$(EXE) all-libs
|
||||||
$(CHIBI) -Abuild-lib tools/optimize-char-sets.scm --predicate chibi.char-set.width > $@
|
$(CHIBI) tools/extract-case-offsets.scm $< > $@
|
||||||
|
|
||||||
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 > $@
|
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
# Tests
|
# Tests
|
||||||
|
@ -251,23 +202,22 @@ test-memory: chibi-scheme-ulimit$(EXE)
|
||||||
test-build:
|
test-build:
|
||||||
MAKE=$(MAKE) ./tests/build/build-tests.sh
|
MAKE=$(MAKE) ./tests/build/build-tests.sh
|
||||||
|
|
||||||
test-run:
|
|
||||||
./tests/run/command-line-tests.sh
|
|
||||||
|
|
||||||
test-ffi: chibi-scheme$(EXE)
|
test-ffi: chibi-scheme$(EXE)
|
||||||
$(CHIBI) tests/ffi/ffi-tests.scm
|
$(CHIBI) tests/ffi/ffi-tests.scm
|
||||||
|
|
||||||
test-snow: chibi-scheme$(EXE) $(IMAGE_FILES)
|
test-snow: chibi-scheme$(EXE)
|
||||||
$(CHIBI) tests/snow/snow-tests.scm
|
$(CHIBI) tests/snow/snow-tests.scm
|
||||||
|
|
||||||
|
test-numbers: chibi-scheme$(EXE)
|
||||||
|
$(CHIBI) -xchibi tests/numeric-tests.scm
|
||||||
|
|
||||||
|
test-flonums: chibi-scheme$(EXE)
|
||||||
|
$(CHIBI) -xchibi tests/flonum-tests.scm
|
||||||
|
|
||||||
test-unicode: chibi-scheme$(EXE)
|
test-unicode: chibi-scheme$(EXE)
|
||||||
$(CHIBI) -xchibi tests/unicode-tests.scm
|
$(CHIBI) -xchibi tests/unicode-tests.scm
|
||||||
|
|
||||||
test-division: chibi-scheme$(EXE)
|
|
||||||
$(CHIBI) tests/division-tests.scm
|
|
||||||
|
|
||||||
test-libs: chibi-scheme$(EXE)
|
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) tests/lib-tests.scm
|
||||||
|
|
||||||
test-r5rs: chibi-scheme$(EXE)
|
test-r5rs: chibi-scheme$(EXE)
|
||||||
|
@ -276,16 +226,9 @@ test-r5rs: chibi-scheme$(EXE)
|
||||||
test-r7rs: chibi-scheme$(EXE)
|
test-r7rs: chibi-scheme$(EXE)
|
||||||
$(CHIBI) tests/r7rs-tests.scm
|
$(CHIBI) tests/r7rs-tests.scm
|
||||||
|
|
||||||
test-syntax: chibi-scheme$(EXE)
|
|
||||||
$(CHIBI) tests/syntax-tests.scm
|
|
||||||
|
|
||||||
test: test-r7rs
|
test: test-r7rs
|
||||||
|
|
||||||
test-safe-string-cursors: chibi-scheme$(EXE)
|
test-all: test test-libs test-ffi
|
||||||
$(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-dist: test-all test-memory test-build
|
||||||
|
|
||||||
|
@ -296,33 +239,25 @@ bench-gabriel: chibi-scheme$(EXE)
|
||||||
# Packaging
|
# Packaging
|
||||||
|
|
||||||
clean: clean-libs
|
clean: clean-libs
|
||||||
-$(RM) *.o *.i *.s *.bc *.8 tests/basic/*.out tests/basic/*.err \
|
-$(RM) *.o *.i *.s *.8 tests/basic/*.out tests/basic/*.err
|
||||||
tests/run/*.out tests/run/*.err
|
|
||||||
|
|
||||||
cleaner: clean
|
cleaner: clean
|
||||||
-$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \
|
-$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \
|
||||||
$(IMAGE_FILES) libchibi-scheme*$(SO) *.a *.pc \
|
libchibi-scheme$(SO)* *.a *.pc include/chibi/install.h lib/.*.meta \
|
||||||
libchibi-scheme$(SO_VERSIONED_SUFFIX) \
|
|
||||||
libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX) \
|
|
||||||
include/chibi/install.h lib/.*.meta \
|
|
||||||
chibi-scheme-emscripten \
|
|
||||||
js/chibi.* \
|
|
||||||
$(shell $(FIND) lib -name \*.o)
|
$(shell $(FIND) lib -name \*.o)
|
||||||
|
|
||||||
distclean: dist-clean-libs cleaner
|
dist-clean: dist-clean-libs cleaner
|
||||||
dist-clean: distclean
|
|
||||||
|
|
||||||
install-base: all
|
install: all
|
||||||
$(MKDIR) $(DESTDIR)$(BINDIR)
|
$(MKDIR) $(DESTDIR)$(BINDIR)
|
||||||
$(INSTALL_EXE) -m0755 chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
|
$(INSTALL) -m0755 chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
|
||||||
$(INSTALL) -m0755 tools/chibi-ffi $(DESTDIR)$(BINDIR)/
|
$(INSTALL) -m0755 tools/chibi-ffi $(DESTDIR)$(BINDIR)/
|
||||||
$(INSTALL) -m0755 tools/chibi-doc $(DESTDIR)$(BINDIR)/
|
$(INSTALL) -m0755 tools/chibi-doc $(DESTDIR)$(BINDIR)/
|
||||||
$(INSTALL) -m0755 tools/snow-chibi $(DESTDIR)$(BINDIR)/
|
$(INSTALL) -m0755 tools/snow-chibi $(DESTDIR)$(BINDIR)/
|
||||||
$(INSTALL) -m0755 tools/snow-chibi.scm $(DESTDIR)$(BINDIR)/
|
$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term
|
||||||
$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(MODDIR)/chibi/text
|
|
||||||
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
|
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
|
||||||
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
|
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
|
||||||
$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(MODDIR)/srfi/179 $(DESTDIR)$(MODDIR)/srfi/211 $(DESTDIR)$(MODDIR)/srfi/231
|
$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
|
||||||
$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
|
$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
|
||||||
$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
|
$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
|
||||||
$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
|
$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
|
||||||
|
@ -341,87 +276,51 @@ install-base: all
|
||||||
$(INSTALL) -m0644 lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
|
$(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/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/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/*.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/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
|
||||||
$(INSTALL) -m0644 lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/
|
$(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/*.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/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
|
||||||
$(INSTALL) -m0644 lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
|
$(INSTALL) -m0644 lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
|
||||||
$(INSTALL) -m0644 lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
|
$(INSTALL) -m0644 lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
|
||||||
|
$(INSTALL) -m0644 lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
|
||||||
$(INSTALL) -m0644 lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
|
$(INSTALL) -m0644 lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
|
||||||
$(INSTALL) -m0644 lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
|
$(INSTALL) -m0644 lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
|
||||||
$(INSTALL) -m0644 lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
|
$(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/*.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/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
|
||||||
$(INSTALL) -m0644 lib/srfi/113/*.scm $(DESTDIR)$(MODDIR)/srfi/113/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/117/*.scm $(DESTDIR)$(MODDIR)/srfi/117/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/121/*.scm $(DESTDIR)$(MODDIR)/srfi/121/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/125/*.scm $(DESTDIR)$(MODDIR)/srfi/125/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/128/*.scm $(DESTDIR)$(MODDIR)/srfi/128/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/129/*.scm $(DESTDIR)$(MODDIR)/srfi/129/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/132/*.scm $(DESTDIR)$(MODDIR)/srfi/132/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/133/*.scm $(DESTDIR)$(MODDIR)/srfi/133/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/135/*.sld lib/srfi/135/*.scm $(DESTDIR)$(MODDIR)/srfi/135/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/143/*.scm $(DESTDIR)$(MODDIR)/srfi/143/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/144/*.scm $(DESTDIR)$(MODDIR)/srfi/144/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/151/*.scm $(DESTDIR)$(MODDIR)/srfi/151/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/159/*.scm $(DESTDIR)$(MODDIR)/srfi/159/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/159/*.sld $(DESTDIR)$(MODDIR)/srfi/159/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/160/*.sld $(DESTDIR)$(MODDIR)/srfi/160/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/160/*.scm $(DESTDIR)$(MODDIR)/srfi/160/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/166/*.sld $(DESTDIR)$(MODDIR)/srfi/166/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/166/*.scm $(DESTDIR)$(MODDIR)/srfi/166/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/146/*.sld $(DESTDIR)$(MODDIR)/srfi/146/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/146/*.scm $(DESTDIR)$(MODDIR)/srfi/146/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/179/*.sld $(DESTDIR)$(MODDIR)/srfi/179/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/179/*.scm $(DESTDIR)$(MODDIR)/srfi/179/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/211/*.sld $(DESTDIR)$(MODDIR)/srfi/211/
|
|
||||||
$(INSTALL) -m0644 lib/srfi/231/*.sld lib/srfi/231/*.scm $(DESTDIR)$(MODDIR)/srfi/231/
|
|
||||||
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
|
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
|
||||||
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
|
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
|
||||||
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
|
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
|
||||||
$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
|
$(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
|
$(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_EXE) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
|
$(INSTALL) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
|
||||||
$(INSTALL_EXE) -m0755 $(CHIBI_CRYPTO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
|
$(INSTALL) -m0755 $(CHIBI_CRYPTO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
|
||||||
$(INSTALL_EXE) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
|
$(INSTALL) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
|
||||||
$(INSTALL_EXE) -m0755 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
|
$(INSTALL) -m0755 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
|
||||||
$(INSTALL_EXE) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
|
$(INSTALL) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
|
||||||
$(INSTALL_EXE) -m0755 lib/scheme/bytevector$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
|
$(INSTALL) -m0755 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
|
$(INSTALL) -m0755 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
|
$(INSTALL) -m0755 lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
|
$(INSTALL) -m0755 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
|
$(INSTALL) -m0755 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
|
$(INSTALL) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
|
$(INSTALL) -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)$(INCDIR)
|
$(MKDIR) $(DESTDIR)$(INCDIR)
|
||||||
$(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/
|
$(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/
|
||||||
$(MKDIR) $(DESTDIR)$(LIBDIR)
|
$(MKDIR) $(DESTDIR)$(LIBDIR)
|
||||||
$(MKDIR) $(DESTDIR)$(SOLIBDIR)
|
$(MKDIR) $(DESTDIR)$(SOLIBDIR)
|
||||||
$(INSTALL_EXE) -m0755 libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/
|
$(INSTALL) -m0755 libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/
|
||||||
$(LN) libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
$(LN) -s -f libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
||||||
$(LN) libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
|
$(LN) -s -f 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
|
-$(INSTALL) -m0644 libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/
|
||||||
$(MKDIR) $(DESTDIR)$(PKGCONFDIR)
|
$(MKDIR) $(DESTDIR)$(SOLIBDIR)/pkgconfig
|
||||||
$(INSTALL) -m0644 chibi-scheme.pc $(DESTDIR)$(PKGCONFDIR)
|
$(INSTALL) -m0644 chibi-scheme.pc $(DESTDIR)$(SOLIBDIR)/pkgconfig/
|
||||||
$(MKDIR) $(DESTDIR)$(MANDIR)
|
$(MKDIR) $(DESTDIR)$(MANDIR)
|
||||||
$(INSTALL) -m0644 doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
|
$(INSTALL) -m0644 doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
|
||||||
$(INSTALL) -m0644 doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
|
$(INSTALL) -m0644 doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
|
||||||
$(INSTALL) -m0644 doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
|
$(INSTALL) -m0644 doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
|
||||||
-if type $(LDCONFIG) >/dev/null 2>/dev/null; then $(LDCONFIG) >/dev/null 2>/dev/null; fi
|
-if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
|
||||||
|
|
||||||
install: install-base
|
|
||||||
ifneq "$(IMAGE_FILES)" ""
|
|
||||||
echo "Generating images"
|
|
||||||
-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.repl -d $(MODDIR)/chibi.img
|
|
||||||
-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -xscheme.red -mchibi.repl -d $(MODDIR)/red.img
|
|
||||||
-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils -d $(DESTDIR)$(MODDIR)/snow.img
|
|
||||||
endif
|
|
||||||
|
|
||||||
uninstall:
|
uninstall:
|
||||||
-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
|
-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
|
||||||
|
@ -429,20 +328,15 @@ uninstall:
|
||||||
-$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi
|
-$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi
|
||||||
-$(RM) $(DESTDIR)$(BINDIR)/chibi-doc
|
-$(RM) $(DESTDIR)$(BINDIR)/chibi-doc
|
||||||
-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi
|
-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi
|
||||||
-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi.scm
|
|
||||||
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
|
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
|
||||||
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_VERSIONED_SUFFIX)
|
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_VERSIONED_SUFFIX)
|
||||||
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
||||||
-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
|
-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
|
||||||
-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
|
-$(RM) $(DESTDIR)$(SOLIBDIR)/pkgconfig/chibi-scheme.pc
|
||||||
-$(CD) $(DESTDIR)$(PREFIX) && $(RM) $(INCLUDES)
|
-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
|
||||||
-$(RMDIR) $(DESTDIR)$(INCDIR)
|
-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm}
|
||||||
-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.sld
|
|
||||||
-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.scm
|
|
||||||
-$(RM) $(DESTDIR)$(MODDIR)/.*.meta
|
-$(RM) $(DESTDIR)$(MODDIR)/.*.meta
|
||||||
-$(RM) $(DESTDIR)$(MODDIR)/*.img
|
-$(RM) $(DESTDIR)$(MODDIR)/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*/*.{sld,scm}
|
||||||
-$(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)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
|
||||||
-$(CD) $(DESTDIR)$(BINMODDIR) && $(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/char-set $(DESTDIR)$(BINMODDIR)/chibi/char-set
|
||||||
|
@ -460,7 +354,6 @@ uninstall:
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(BINMODDIR)/chibi/snow
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(BINMODDIR)/chibi/snow
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
|
-$(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)/chibi $(DESTDIR)$(BINMODDIR)/chibi
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/time $(DESTDIR)$(BINMODDIR)/scheme/time
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/time $(DESTDIR)$(BINMODDIR)/scheme/time
|
||||||
|
@ -468,44 +361,26 @@ uninstall:
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27
|
-$(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/39 $(DESTDIR)$(BINMODDIR)/srfi/39
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98
|
-$(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/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
|
-$(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)/srfi $(DESTDIR)$(BINMODDIR)/srfi
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
|
-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
|
||||||
-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
|
-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
|
||||||
-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
|
-$(RM) $(DESTDIR)$(SOLIBDIR)/pkgconfig/chibi-scheme.pc
|
||||||
|
|
||||||
dist: distclean
|
dist: dist-clean
|
||||||
$(RM) chibi-scheme-$(CHIBI_VERSION).tgz
|
$(RM) chibi-scheme-$(VERSION).tgz
|
||||||
$(MKDIR) chibi-scheme-$(CHIBI_VERSION)
|
$(MKDIR) chibi-scheme-$(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
|
@for f in `git ls-files | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-$(VERSION)/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-$(VERSION)/$$f; done
|
||||||
$(TAR) cphzvf chibi-scheme-$(CHIBI_VERSION).tgz chibi-scheme-$(CHIBI_VERSION)
|
$(TAR) cphzvf chibi-scheme-$(VERSION).tgz chibi-scheme-$(VERSION)
|
||||||
$(RM) -r chibi-scheme-$(CHIBI_VERSION)
|
$(RM) -r chibi-scheme-$(VERSION)
|
||||||
|
|
||||||
mips-dist: distclean
|
mips-dist: dist-clean
|
||||||
$(RM) chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`.tgz
|
$(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-`
|
$(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
|
@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
|
||||||
|
@ -513,47 +388,33 @@ mips-dist: distclean
|
||||||
$(RM) -r 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:
|
debian:
|
||||||
sudo checkinstall -D --pkgname chibi-scheme --pkgversion $(CHIBI_VERSION) --maintainer "http://groups.google.com/group/chibi-scheme" -y make PREFIX=/usr install
|
sudo checkinstall -D --pkgname chibi-scheme --pkgversion $(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
|
# Libraries in the standard distribution we want to make available to
|
||||||
# other Scheme implementations. Note this is run with my own
|
# other Scheme implementations. Note this is run with my own
|
||||||
# ~/.snow/config.scm, which specifies my own settings regarding
|
# ~/.snow/config.scm, which specifies myself own settings regarding
|
||||||
# author, license, extracting docs from scribble, etc.
|
# author, license, extracting docs from scribble, etc.
|
||||||
snowballs:
|
snowballs:
|
||||||
$(SNOW_CHIBI) package --license public-domain lib/chibi/char-set/boundary.sld
|
$(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 --license public-domain lib/chibi/match.sld
|
||||||
$(SNOW_CHIBI) package -r lib/chibi/char-set.sld
|
$(SNOW_CHIBI) package -r lib/chibi/char-set.sld
|
||||||
$(SNOW_CHIBI) package -r lib/chibi/iset.sld lib/chibi/iset/optimize.sld
|
$(SNOW_CHIBI) package -r lib/chibi/iset.sld
|
||||||
$(SNOW_CHIBI) package --doc https://srfi.schemers.org/srfi-115/srfi-115.html --test-library lib/srfi/115.sld
|
$(SNOW_CHIBI) package -r lib/chibi/show.sld lib/chibi/show/pretty.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/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/bytevector.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/config.sld
|
$(SNOW_CHIBI) package lib/chibi/config.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/crypto/md5.sld
|
$(SNOW_CHIBI) package lib/chibi/crypto/md5.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/crypto/rsa.sld
|
$(SNOW_CHIBI) package lib/chibi/crypto/rsa.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/crypto/sha2.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/math/prime.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/mime.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/monad/environment.sld
|
$(SNOW_CHIBI) package lib/chibi/monad/environment.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/optional.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/parse.sld lib/chibi/parse/common.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/pathname.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/regexp.sld lib/chibi/regexp/pcre.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/scribble.sld
|
$(SNOW_CHIBI) package lib/chibi/scribble.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/string.sld
|
$(SNOW_CHIBI) package lib/chibi/string.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/sxml.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/ansi.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/term/edit-line.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/test.sld
|
$(SNOW_CHIBI) package lib/chibi/test.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/uri.sld
|
$(SNOW_CHIBI) package lib/chibi/uri.sld
|
||||||
$(SNOW_CHIBI) package lib/chibi/zlib.sld
|
|
||||||
|
|
120
Makefile.detect
120
Makefile.detect
|
@ -9,7 +9,6 @@ PLATFORM=macosx
|
||||||
else
|
else
|
||||||
ifeq ($(shell uname),FreeBSD)
|
ifeq ($(shell uname),FreeBSD)
|
||||||
PLATFORM=bsd
|
PLATFORM=bsd
|
||||||
LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
|
|
||||||
else
|
else
|
||||||
ifeq ($(shell uname),NetBSD)
|
ifeq ($(shell uname),NetBSD)
|
||||||
PLATFORM=bsd
|
PLATFORM=bsd
|
||||||
|
@ -21,7 +20,7 @@ ifeq ($(shell uname),DragonFly)
|
||||||
PLATFORM=bsd
|
PLATFORM=bsd
|
||||||
else
|
else
|
||||||
ifeq ($(shell uname -o),Msys)
|
ifeq ($(shell uname -o),Msys)
|
||||||
PLATFORM=windows
|
PLATFORM=mingw
|
||||||
SOLIBDIR = $(BINDIR)
|
SOLIBDIR = $(BINDIR)
|
||||||
DIFFOPTS = -b
|
DIFFOPTS = -b
|
||||||
else
|
else
|
||||||
|
@ -30,15 +29,9 @@ PLATFORM=cygwin
|
||||||
SOLIBDIR = $(BINDIR)
|
SOLIBDIR = $(BINDIR)
|
||||||
DIFFOPTS = -b
|
DIFFOPTS = -b
|
||||||
else
|
else
|
||||||
ifeq ($(shell uname -o),Android)
|
|
||||||
PLATFORM=android
|
|
||||||
else
|
|
||||||
ifeq ($(shell uname -o),GNU/Linux)
|
ifeq ($(shell uname -o),GNU/Linux)
|
||||||
PLATFORM=linux
|
PLATFORM=linux
|
||||||
else
|
else
|
||||||
ifeq ($(shell uname),SunOS)
|
|
||||||
PLATFORM=solaris
|
|
||||||
else
|
|
||||||
PLATFORM=unix
|
PLATFORM=unix
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
|
@ -48,13 +41,6 @@ endif
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
endif
|
|
||||||
endif
|
|
||||||
endif
|
|
||||||
|
|
||||||
ifndef ARCH
|
|
||||||
ARCH = $(shell uname -m)
|
|
||||||
endif
|
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
# Set default variables for the platform.
|
# Set default variables for the platform.
|
||||||
|
@ -62,7 +48,6 @@ endif
|
||||||
LIBDL = -ldl
|
LIBDL = -ldl
|
||||||
SO_VERSIONED_SUFFIX = $(SO).$(SOVERSION)
|
SO_VERSIONED_SUFFIX = $(SO).$(SOVERSION)
|
||||||
SO_MAJOR_VERSIONED_SUFFIX = $(SO).$(SOVERSION_MAJOR)
|
SO_MAJOR_VERSIONED_SUFFIX = $(SO).$(SOVERSION_MAJOR)
|
||||||
STATIC_LDFLAGS = -lm -ldl -lutil
|
|
||||||
|
|
||||||
ifeq ($(PLATFORM),macosx)
|
ifeq ($(PLATFORM),macosx)
|
||||||
SO = .dylib
|
SO = .dylib
|
||||||
|
@ -80,37 +65,17 @@ EXE =
|
||||||
CLIBFLAGS = -fPIC
|
CLIBFLAGS = -fPIC
|
||||||
CLINKFLAGS = -shared
|
CLINKFLAGS = -shared
|
||||||
LIBDL =
|
LIBDL =
|
||||||
RLDFLAGS=-Wl,-R$(LIBDIR)
|
|
||||||
else
|
else
|
||||||
ifeq ($(PLATFORM),solaris)
|
ifeq ($(PLATFORM),mingw)
|
||||||
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)
|
|
||||||
SO = .dll
|
SO = .dll
|
||||||
EXE = .exe
|
EXE = .exe
|
||||||
CC = gcc
|
CC = gcc
|
||||||
CLIBFLAGS =
|
CLIBFLAGS =
|
||||||
CLINKFLAGS = -shared
|
CLINKFLAGS = -shared
|
||||||
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
|
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
|
||||||
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
|
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
|
||||||
STATIC_LDFLAGS = -lm -ldl
|
STATICFLAGS = -DSEXP_USE_DL=0
|
||||||
|
LIBDL =
|
||||||
else
|
else
|
||||||
ifeq ($(PLATFORM),cygwin)
|
ifeq ($(PLATFORM),cygwin)
|
||||||
SO = .dll
|
SO = .dll
|
||||||
|
@ -120,7 +85,6 @@ CLIBFLAGS =
|
||||||
CLINKFLAGS = -shared
|
CLINKFLAGS = -shared
|
||||||
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
|
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
|
||||||
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
|
LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
|
||||||
STATIC_LDFLAGS = -lm -ldl
|
|
||||||
else
|
else
|
||||||
SO = .so
|
SO = .so
|
||||||
EXE =
|
EXE =
|
||||||
|
@ -128,6 +92,9 @@ CLIBFLAGS = -fPIC
|
||||||
CLINKFLAGS = -shared
|
CLINKFLAGS = -shared
|
||||||
STATICFLAGS = -static -DSEXP_USE_DL=0
|
STATICFLAGS = -static -DSEXP_USE_DL=0
|
||||||
LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
|
LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
|
||||||
|
ifeq ($(PLATFORM),BSD)
|
||||||
|
LIBDL=
|
||||||
|
RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
|
@ -135,83 +102,26 @@ endif
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
|
|
||||||
ifeq ($(PLATFORM),emscripten)
|
|
||||||
STATIC_LDFLAGS = -lm -ldl
|
|
||||||
endif
|
|
||||||
|
|
||||||
ifeq ($(PLATFORM),unix)
|
ifeq ($(PLATFORM),unix)
|
||||||
#RLDFLAGS=-rpath $(LIBDIR)
|
#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.
|
|
||||||
|
|
||||||
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
|
endif
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
# Check for headers (who needs autoconf?)
|
# Check for headers (who needs autoconf?)
|
||||||
|
|
||||||
ifndef SEXP_USE_NTP_GETTIME
|
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)
|
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
|
endif
|
||||||
|
|
||||||
ifeq ($(SEXP_USE_NTP_GETTIME),1)
|
ifeq ($(SEXP_USE_NTP_GETTIME),1)
|
||||||
XCPPFLAGS += -DSEXP_USE_NTPGETTIME
|
CPPFLAGS += -DSEXP_USE_NTPGETTIME
|
||||||
endif
|
endif
|
||||||
|
|
||||||
ifndef SEXP_USE_INTTYPES
|
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)
|
SEXP_USE_INTTYPES := $(shell echo "main(){int_least8_t x;}" | gcc -fsyntax-only -include inttypes.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
ifeq ($(SEXP_USE_INTTYPES),1)
|
ifeq ($(SEXP_USE_INTTYPES),1)
|
||||||
XCPPFLAGS += -DSEXP_USE_INTTYPES
|
CPPFLAGS += -DSEXP_USE_INTTYPES
|
||||||
endif
|
endif
|
||||||
|
|
|
@ -14,49 +14,25 @@ CD ?= cd
|
||||||
RM ?= rm -f
|
RM ?= rm -f
|
||||||
LS ?= ls
|
LS ?= ls
|
||||||
CP ?= cp
|
CP ?= cp
|
||||||
LN ?= ln -sf
|
LN ?= ln
|
||||||
INSTALL ?= install
|
INSTALL ?= install
|
||||||
INSTALL_EXE ?= $(INSTALL)
|
|
||||||
MKDIR ?= $(INSTALL) -d
|
MKDIR ?= $(INSTALL) -d
|
||||||
RMDIR ?= rmdir
|
RMDIR ?= rmdir
|
||||||
TAR ?= tar
|
TAR ?= tar
|
||||||
DIFF ?= diff
|
DIFF ?= diff
|
||||||
GIT ?= git
|
|
||||||
GREP ?= grep
|
GREP ?= grep
|
||||||
FIND ?= find
|
FIND ?= find
|
||||||
SYMLINK ?= ln -s
|
SYMLINK ?= ln -s
|
||||||
LDCONFIG ?= ldconfig
|
|
||||||
|
|
||||||
# gnu coding standards
|
PREFIX ?= /usr/local
|
||||||
prefix ?= /usr/local
|
BINDIR ?= $(PREFIX)/bin
|
||||||
PREFIX ?= $(prefix)
|
LIBDIR ?= $(PREFIX)/lib
|
||||||
exec_prefix ?= $(PREFIX)
|
SOLIBDIR ?= $(PREFIX)/lib
|
||||||
bindir ?= $(exec_prefix)/bin
|
INCDIR ?= $(PREFIX)/include/chibi
|
||||||
libdir ?= $(exec_prefix)/lib
|
MODDIR ?= $(PREFIX)/share/chibi
|
||||||
includedir ?= $(PREFIX)/include
|
BINMODDIR ?= $(PREFIX)/lib/chibi
|
||||||
datarootdir ?= $(PREFIX)/share
|
MANDIR ?= $(PREFIX)/share/man/man1
|
||||||
datadir ?= $(datarootdir)
|
|
||||||
mandir ?= $(datarootdir)/man
|
|
||||||
man1dir ?= $(mandir)/man1
|
|
||||||
|
|
||||||
# hysterical raisins
|
|
||||||
BINDIR ?= $(bindir)
|
|
||||||
LIBDIR ?= $(libdir)
|
|
||||||
SOLIBDIR ?= $(libdir)
|
|
||||||
INCDIR ?= $(includedir)/chibi
|
|
||||||
MODDIR ?= $(datadir)/chibi
|
|
||||||
BINMODDIR ?= $(SOLIBDIR)/chibi
|
|
||||||
PKGCONFDIR ?= $(SOLIBDIR)/pkgconfig
|
|
||||||
MANDIR ?= $(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 ?=
|
DESTDIR ?=
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
|
@ -67,16 +43,13 @@ include Makefile.detect
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
|
|
||||||
all-libs: $(COMPILED_LIBS) lib/chibi/snow/install.sld
|
all-libs: $(COMPILED_LIBS)
|
||||||
|
|
||||||
lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES)
|
lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES)
|
||||||
$(CHIBI_FFI) $<
|
$(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)
|
lib/%$(SO): lib/%.c $(INCLUDES) libchibi-scheme$(SO)
|
||||||
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) $(XLIBS) -lchibi-scheme
|
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme
|
||||||
|
|
||||||
doc-libs: $(HTML_LIBS)
|
doc-libs: $(HTML_LIBS)
|
||||||
|
|
||||||
|
|
40
README
Normal file
40
README
Normal file
|
@ -0,0 +1,40 @@
|
||||||
|
|
||||||
|
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 repl language contains all bindings from R7RS small,
|
||||||
|
available explicitly as the (scheme small) library.
|
||||||
|
|
||||||
|
Support for additional languages such as JavaScript, Go, Lua and Bash
|
||||||
|
are planned for future releases. Scheme is chosen as a substrate
|
||||||
|
because its first class continuations and guaranteed tail-call
|
||||||
|
optimization makes implementing other languages easy.
|
||||||
|
|
||||||
|
To build on most platforms just run "make && make test". This will
|
||||||
|
provide a shared library "libchibi-scheme", as well as a sample
|
||||||
|
"chibi-scheme" command-line repl. You can then run
|
||||||
|
|
||||||
|
sudo make install
|
||||||
|
|
||||||
|
to install the binaries and libraries. You can optionally specify a
|
||||||
|
PREFIX for the installation directory:
|
||||||
|
|
||||||
|
make PREFIX=/path/to/install/
|
||||||
|
sudo make PREFIX=/path/to/install/ install
|
||||||
|
|
||||||
|
By default files are installed in /usr/local.
|
||||||
|
|
||||||
|
If you want to try out chibi-scheme without installing, be sure to set
|
||||||
|
LD_LIBRARY_PATH so it can find the shared libraries.
|
||||||
|
|
||||||
|
For more detailed documentation, run "make doc" and see the generated
|
||||||
|
"doc/chibi.html".
|
|
@ -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
60
README.md
|
@ -1,60 +0,0 @@
|
||||||
# 
|
|
||||||
|
|
||||||
**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
2
RELEASE
|
@ -1 +1 @@
|
||||||
sodium
|
nitrogen
|
||||||
|
|
14
TODO
14
TODO
|
@ -10,8 +10,7 @@
|
||||||
** TODO native x86 backend
|
** TODO native x86 backend
|
||||||
API redesign in preparation complete, initial
|
API redesign in preparation complete, initial
|
||||||
tests on native factorial and closures working.
|
tests on native factorial and closures working.
|
||||||
** DONE fasl/image files
|
** TODO fasl/image files
|
||||||
- State "DONE" from "TODO" [2017-08-30 Wed 23:13]
|
|
||||||
sexp_copy_context() can form the basis for images,
|
sexp_copy_context() can form the basis for images,
|
||||||
FASL for arbitrary modules will need additional
|
FASL for arbitrary modules will need additional
|
||||||
help with resolving external references.
|
help with resolving external references.
|
||||||
|
@ -19,8 +18,7 @@
|
||||||
- State "DONE" from "TODO" [2011-11-10 Thu 20:44]
|
- State "DONE" from "TODO" [2011-11-10 Thu 20:44]
|
||||||
*** TODO static image compiled into library
|
*** TODO static image compiled into library
|
||||||
With this you'll be able to run Chibi without any filesystem.
|
With this you'll be able to run Chibi without any filesystem.
|
||||||
*** DONE external tool to compact and optimize images
|
*** TODO external tool to compact and optimize images
|
||||||
- State "DONE" from "TODO" [2017-08-30 Wed 23:13]
|
|
||||||
The current GC is mark&sweep, which can cause fragmentation,
|
The current GC is mark&sweep, which can cause fragmentation,
|
||||||
but we can at at least compact the initial fixed image.
|
but we can at at least compact the initial fixed image.
|
||||||
*** TODO fasl versions of modules
|
*** TODO fasl versions of modules
|
||||||
|
@ -91,6 +89,8 @@
|
||||||
- State "DONE" from "TODO" [2010-07-11 Sun 15:31]
|
- State "DONE" from "TODO" [2010-07-11 Sun 15:31]
|
||||||
VM now supports an optional hook for green threads,
|
VM now supports an optional hook for green threads,
|
||||||
and a SRFI-18 interface is provided as a separate module.
|
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
|
*** DONE thread-local parameters
|
||||||
CLOSED: [2010-12-06 Mon 21:52]
|
CLOSED: [2010-12-06 Mon 21:52]
|
||||||
*** TODO efficient priority queues
|
*** TODO efficient priority queues
|
||||||
|
@ -125,8 +125,7 @@
|
||||||
- State "DONE" [2009-12-08 Tue 14:39]
|
- State "DONE" [2009-12-08 Tue 14:39]
|
||||||
** DONE only/except/rename/prefix modifiers
|
** DONE only/except/rename/prefix modifiers
|
||||||
- State "DONE" [2009-12-16 Wed 18:57]
|
- State "DONE" [2009-12-16 Wed 18:57]
|
||||||
** DONE scheme-complete.el support
|
** TODO scheme-complete.el support
|
||||||
- State "DONE" from "TODO" [2017-08-30 Wed 23:14]
|
|
||||||
** DONE access individual modules from repl
|
** DONE access individual modules from repl
|
||||||
- State "DONE" [2009-12-26 Sat 01:49]
|
- State "DONE" [2009-12-26 Sat 01:49]
|
||||||
|
|
||||||
|
@ -182,8 +181,7 @@
|
||||||
* miscellaneous
|
* miscellaneous
|
||||||
** DONE user documentation
|
** DONE user documentation
|
||||||
- State "DONE" from "TODO" [2011-11-10 Thu 20:45]
|
- State "DONE" from "TODO" [2011-11-10 Thu 20:45]
|
||||||
** DONE full test suite for libraries
|
** TODO full test suite for libraries
|
||||||
- State "DONE" from "TODO" [2017-08-30 Wed 23:14]
|
|
||||||
** TODO thorough source documentation
|
** TODO thorough source documentation
|
||||||
|
|
||||||
* distribution
|
* distribution
|
||||||
|
|
2
VERSION
2
VERSION
|
@ -1 +1 @@
|
||||||
0.11.0
|
0.7.3
|
||||||
|
|
53
appveyor.yml
53
appveyor.yml
|
@ -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 .
|
|
||||||
|
|
|
@ -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)
|
(define (timeval->milliseconds tv)
|
||||||
(quotient (+ (* 1000000 (timeval-seconds tv)) (timeval-microseconds tv))
|
(quotient (+ (* 1000000 (timeval-seconds tv)) (timeval-microseconds tv))
|
||||||
1000))
|
1000))
|
||||||
|
|
||||||
(define (timeval-diff start end)
|
|
||||||
(- (timeval->milliseconds end)
|
|
||||||
(timeval->milliseconds start)))
|
|
||||||
|
|
||||||
(define (time* thunk)
|
(define (time* thunk)
|
||||||
(call-with-output-string
|
(call-with-output-string
|
||||||
(lambda (out)
|
(lambda (out)
|
||||||
(gc)
|
|
||||||
(let* ((start (car (get-time-of-day)))
|
(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)))
|
(result (parameterize ((current-output-port out)) (thunk)))
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
(end (car (get-time-of-day)))
|
(end (car (get-time-of-day)))
|
||||||
(end-rusage (get-resource-usage))
|
(msecs (- (timeval->milliseconds end)
|
||||||
(gc-end (gc-usecs))
|
(timeval->milliseconds start))))
|
||||||
(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))))
|
|
||||||
(display "user: ")
|
(display "user: ")
|
||||||
(display user-msecs)
|
(display msecs)
|
||||||
(display " system: ")
|
(display " system: 0")
|
||||||
(display system-msecs)
|
|
||||||
(display " real: ")
|
(display " real: ")
|
||||||
(display real-msecs)
|
(display msecs)
|
||||||
(display " gc: ")
|
(display " gc: 0")
|
||||||
(display gc-msecs)
|
(newline)
|
||||||
(display " (")
|
|
||||||
(display (- (gc-count) gc-start-count))
|
|
||||||
(display " times)\n")
|
|
||||||
(display "result: ")
|
(display "result: ")
|
||||||
(write result)
|
(write result)
|
||||||
(newline)
|
(newline)
|
||||||
|
|
|
@ -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,32 +1,16 @@
|
||||||
#!/bin/sh
|
#!/bin/sh
|
||||||
|
|
||||||
# set -ex
|
|
||||||
|
|
||||||
BENCHDIR=$(dirname $0)
|
BENCHDIR=$(dirname $0)
|
||||||
if [ "${BENCHDIR%%/*}" = "." ]; then
|
if [ "${BENCHDIR%%/*}" == "." ]; then
|
||||||
BENCHDIR="$(pwd)${BENCHDIR#.}"
|
BENCHDIR=$(pwd)${BENCHDIR#.}
|
||||||
fi
|
fi
|
||||||
OUTPUT="$BENCHDIR/out.txt"
|
CHIBIHOME=${BENCHDIR%%/benchmarks/gabriel}
|
||||||
DB="$BENCHDIR/times.tsv"
|
|
||||||
CHIBIHOME="${BENCHDIR%%/benchmarks/gabriel}"
|
|
||||||
CHIBI="${CHIBI:-${CHIBIHOME}/chibi-scheme} -I$CHIBIHOME"
|
CHIBI="${CHIBI:-${CHIBIHOME}/chibi-scheme} -I$CHIBIHOME"
|
||||||
HEAP="2M"
|
|
||||||
|
|
||||||
cd "$BENCHDIR"
|
cd $BENCHDIR
|
||||||
for t in *.sch; do
|
for t in *.sch; do
|
||||||
echo "program: ${t%%.sch}"
|
echo "${t%%.sch}"
|
||||||
LD_LIBRARY_PATH="$CHIBIHOME" DYLD_LIBRARY_PATH="$CHIBIHOME" \
|
LD_LIBRARY_PATH="$CHIBIHOME" DYLD_LIBRARY_PATH="$CHIBIHOME" \
|
||||||
$CHIBI -I"$CHIBIHOME/lib" -h"$HEAP" -q -lchibi-prelude.scm "$t"
|
$CHIBI -I"$CHIBIHOME/lib" -q -lchibi-prelude.scm $t
|
||||||
done | tee "$OUTPUT"
|
done
|
||||||
cd -
|
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"
|
|
||||||
|
|
480
bignum.c
480
bignum.c
|
@ -35,91 +35,38 @@ sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) {
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_make_integer_from_lsint (sexp ctx, sexp_lsint_t x) {
|
|
||||||
sexp res;
|
|
||||||
if (lsint_is_fixnum(x)) {
|
|
||||||
res = sexp_make_fixnum(lsint_to_sint(x));
|
|
||||||
} else if (sexp_lsint_fits_sint(x)) {
|
|
||||||
res = sexp_make_bignum(ctx, 1);
|
|
||||||
if (lsint_lt_0(x)) {
|
|
||||||
sexp_bignum_sign(res) = -1;
|
|
||||||
sexp_bignum_data(res)[0] = (sexp_uint_t)-lsint_to_sint(x);
|
|
||||||
} else {
|
|
||||||
sexp_bignum_sign(res) = 1;
|
|
||||||
sexp_bignum_data(res)[0] = (sexp_uint_t)lsint_to_sint(x);
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
res = sexp_make_bignum(ctx, 2);
|
|
||||||
if (lsint_lt_0(x)) {
|
|
||||||
sexp_bignum_sign(res) = -1;
|
|
||||||
sexp_bignum_data(res)[0] = (sexp_uint_t)-lsint_to_sint(x);
|
|
||||||
sexp_bignum_data(res)[1] = (sexp_uint_t)~lsint_to_sint_hi(x);
|
|
||||||
} else {
|
|
||||||
sexp_bignum_sign(res) = 1;
|
|
||||||
sexp_bignum_data(res)[0] = (sexp_uint_t)lsint_to_sint(x);
|
|
||||||
sexp_bignum_data(res)[1] = (sexp_uint_t)lsint_to_sint_hi(x);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
sexp sexp_make_unsigned_integer_from_luint (sexp ctx, sexp_luint_t x) {
|
|
||||||
sexp res;
|
|
||||||
if (luint_is_fixnum(x)) {
|
|
||||||
res = sexp_make_fixnum(luint_to_uint(x));
|
|
||||||
} else if (sexp_luint_fits_uint(x)) {
|
|
||||||
res = sexp_make_bignum(ctx, 1);
|
|
||||||
sexp_bignum_sign(res) = 1;
|
|
||||||
sexp_bignum_data(res)[0] = luint_to_uint(x);
|
|
||||||
} else {
|
|
||||||
res = sexp_make_bignum(ctx, 2);
|
|
||||||
sexp_bignum_sign(res) = 1;
|
|
||||||
sexp_bignum_data(res)[0] = luint_to_uint(x);
|
|
||||||
sexp_bignum_data(res)[1] = luint_to_uint_hi(x);
|
|
||||||
}
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
#if SEXP_USE_CUSTOM_LONG_LONGS
|
|
||||||
sexp sexp_make_integer(sexp ctx, long long x) {
|
|
||||||
return sexp_make_integer_from_lsint(ctx, lsint_from_sint(x));
|
|
||||||
}
|
|
||||||
sexp sexp_make_unsigned_integer(sexp ctx, unsigned long long x) {
|
|
||||||
return sexp_make_unsigned_integer_from_luint(ctx, luint_from_uint(x));
|
|
||||||
}
|
|
||||||
#else
|
|
||||||
sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) {
|
sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) {
|
||||||
return sexp_make_integer_from_lsint(ctx, x);
|
sexp res;
|
||||||
|
if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) {
|
||||||
|
res = sexp_make_fixnum(x);
|
||||||
|
} else {
|
||||||
|
res = sexp_make_bignum(ctx, 1);
|
||||||
|
if (x < 0) {
|
||||||
|
sexp_bignum_sign(res) = -1;
|
||||||
|
sexp_bignum_data(res)[0] = -x;
|
||||||
|
} else {
|
||||||
|
sexp_bignum_sign(res) = 1;
|
||||||
|
sexp_bignum_data(res)[0] = x;
|
||||||
}
|
}
|
||||||
|
}
|
||||||
|
return res;
|
||||||
|
}
|
||||||
|
|
||||||
sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
|
sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
|
||||||
return sexp_make_unsigned_integer_from_luint(ctx, x);
|
sexp res;
|
||||||
|
if (x <= SEXP_MAX_FIXNUM) {
|
||||||
|
res = sexp_make_fixnum(x);
|
||||||
|
} else {
|
||||||
|
res = sexp_make_bignum(ctx, 1);
|
||||||
|
sexp_bignum_sign(res) = 1;
|
||||||
|
sexp_bignum_data(res)[0] = x;
|
||||||
}
|
}
|
||||||
#endif
|
return res;
|
||||||
|
|
||||||
#if !SEXP_64_BIT
|
|
||||||
long long sexp_bignum_to_sint(sexp x) {
|
|
||||||
if (!sexp_bignump(x))
|
|
||||||
return 0;
|
|
||||||
if (sexp_bignum_length(x) > 1)
|
|
||||||
return sexp_bignum_sign(x) * (
|
|
||||||
(((long long)(sexp_bignum_data(x)[1]))<<(8*sizeof(sexp_bignum_data(x)[0]))) + sexp_bignum_data(x)[0]);
|
|
||||||
return sexp_bignum_sign(x) * sexp_bignum_data(x)[0];
|
|
||||||
}
|
}
|
||||||
|
|
||||||
unsigned long long sexp_bignum_to_uint(sexp x) {
|
|
||||||
if (!sexp_bignump(x))
|
|
||||||
return 0;
|
|
||||||
if (sexp_bignum_length(x) > 1)
|
|
||||||
return (((unsigned long long)(sexp_bignum_data(x)[1]))<<(8*sizeof(sexp_bignum_data(x)[0]))) + sexp_bignum_data(x)[0];
|
|
||||||
return sexp_bignum_data(x)[0];
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0)
|
#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0)
|
||||||
#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f))
|
#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f))
|
||||||
|
|
||||||
#define double_16s_digit(f) fmod(f,16.0)
|
|
||||||
|
|
||||||
sexp sexp_double_to_bignum (sexp ctx, double f) {
|
sexp sexp_double_to_bignum (sexp ctx, double f) {
|
||||||
int sign;
|
int sign;
|
||||||
sexp_gc_var3(res, scale, tmp);
|
sexp_gc_var3(res, scale, tmp);
|
||||||
|
@ -127,10 +74,10 @@ sexp sexp_double_to_bignum (sexp ctx, double f) {
|
||||||
res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
|
res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
|
||||||
scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
|
scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
|
||||||
sign = (f < 0 ? -1 : 1);
|
sign = (f < 0 ? -1 : 1);
|
||||||
for (f=fabs(f); f >= 1.0; f=trunc(f/16)) {
|
for (f=fabs(f); f >= 1.0; f=trunc(f/10)) {
|
||||||
tmp = sexp_bignum_fxmul(ctx, NULL, scale, (sexp_uint_t)double_16s_digit(f), 0);
|
tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0);
|
||||||
res = sexp_bignum_add(ctx, res, res, tmp);
|
res = sexp_bignum_add(ctx, res, res, tmp);
|
||||||
scale = sexp_bignum_fxmul(ctx, NULL, scale, 16, 0);
|
scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0);
|
||||||
}
|
}
|
||||||
sexp_bignum_sign(res) = sign;
|
sexp_bignum_sign(res) = sign;
|
||||||
sexp_gc_release3(ctx);
|
sexp_gc_release3(ctx);
|
||||||
|
@ -188,8 +135,7 @@ sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) {
|
||||||
sexp_sint_t sexp_bignum_compare (sexp a, sexp b) {
|
sexp_sint_t sexp_bignum_compare (sexp a, sexp b) {
|
||||||
if (sexp_bignum_sign(a) != sexp_bignum_sign(b))
|
if (sexp_bignum_sign(a) != sexp_bignum_sign(b))
|
||||||
return sexp_bignum_sign(a);
|
return sexp_bignum_sign(a);
|
||||||
sexp_sint_t cmp = sexp_bignum_compare_abs(a, b);
|
return sexp_bignum_compare_abs(a, b);
|
||||||
return sexp_bignum_sign(a) < 0 ? -cmp : cmp;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_bignum_normalize (sexp a) {
|
sexp sexp_bignum_normalize (sexp a) {
|
||||||
|
@ -252,9 +198,9 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
|
||||||
tmp = d;
|
tmp = d;
|
||||||
data = sexp_bignum_data(d);
|
data = sexp_bignum_data(d);
|
||||||
for (i=0; i<len; i++) {
|
for (i=0; i<len; i++) {
|
||||||
n = luint_add(luint_mul_uint(luint_from_uint(adata[i]), b), luint_from_uint(carry));
|
n = (sexp_luint_t)adata[i]*b + carry;
|
||||||
data[i+offset] = luint_to_uint(n);
|
data[i+offset] = (sexp_uint_t)n;
|
||||||
carry = luint_to_uint(luint_shr(n, (sizeof(sexp_uint_t)*8)));
|
carry = n >> (sizeof(sexp_uint_t)*8);
|
||||||
}
|
}
|
||||||
if (carry) {
|
if (carry) {
|
||||||
if (sexp_bignum_length(d) <= len+offset)
|
if (sexp_bignum_length(d) <= len+offset)
|
||||||
|
@ -268,13 +214,13 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
|
||||||
sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
|
sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
|
||||||
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0;
|
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0;
|
||||||
int i;
|
int i;
|
||||||
sexp_luint_t n = luint_from_uint(0);
|
sexp_luint_t n = 0;
|
||||||
for (i=len-1; i>=offset; i--) {
|
for (i=len-1; i>=offset; i--) {
|
||||||
n = luint_add(luint_shl(n, sizeof(sexp_uint_t)*8), luint_from_uint(data[i]));
|
n = (n << sizeof(sexp_uint_t)*8) + data[i];
|
||||||
q = luint_to_uint(luint_div_uint(n, b));
|
q = n / b;
|
||||||
r = luint_to_uint(luint_sub(n, luint_mul_uint(luint_from_uint(q), b)));
|
r = n - (sexp_luint_t)q * b;
|
||||||
data[i] = q;
|
data[i] = q;
|
||||||
n = luint_from_uint(r);
|
n = r;
|
||||||
}
|
}
|
||||||
return r;
|
return r;
|
||||||
}
|
}
|
||||||
|
@ -282,35 +228,32 @@ sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
|
||||||
sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) {
|
sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) {
|
||||||
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, b0;
|
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, b0;
|
||||||
int i;
|
int i;
|
||||||
sexp_luint_t n = luint_from_uint(0);
|
sexp_luint_t n = 0;
|
||||||
if (b > 0) {
|
if (b > 0) {
|
||||||
q = b - 1;
|
q = b - 1;
|
||||||
if ((b & q) == 0)
|
if ((b & q) == 0)
|
||||||
return sexp_make_fixnum(sexp_bignum_sign(a) * (data[0] & q));
|
return sexp_make_fixnum(sexp_bignum_sign(a) * (data[0] & q));
|
||||||
}
|
}
|
||||||
b0 = (b >= 0) ? b : -b;
|
b0 = (b >= 0) ? b : -b;
|
||||||
if (b0 == 0) {
|
|
||||||
return sexp_xtype_exception(ctx, NULL, "divide by zero", a);
|
|
||||||
}
|
|
||||||
for (i=len-1; i>=0; i--) {
|
for (i=len-1; i>=0; i--) {
|
||||||
n = luint_add(luint_shl(n, sizeof(sexp_uint_t)*8), luint_from_uint(data[i]));
|
n = (n << sizeof(sexp_uint_t)*8) + data[i];
|
||||||
q = luint_to_uint(luint_div_uint(n, b0));
|
q = n / b0;
|
||||||
n = luint_sub(n, luint_mul_uint(luint_from_uint(q), b0));
|
n -= (sexp_luint_t)q * b0;
|
||||||
}
|
}
|
||||||
return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)luint_to_uint(n));
|
return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)n);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
|
sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
|
||||||
signed char sign, sexp_uint_t base) {
|
signed char sign, sexp_uint_t base) {
|
||||||
int c, digit;
|
int c, digit;
|
||||||
sexp_gc_var3(res, tmp, imag);
|
sexp_gc_var1(res);
|
||||||
sexp_gc_preserve3(ctx, res, tmp, imag);
|
sexp_gc_preserve1(ctx, res);
|
||||||
res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE);
|
res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE);
|
||||||
sexp_bignum_sign(res) = sign;
|
sexp_bignum_sign(res) = sign;
|
||||||
sexp_bignum_data(res)[0] = init;
|
sexp_bignum_data(res)[0] = init;
|
||||||
for (c=sexp_read_char(ctx, in); sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
|
for (c=sexp_read_char(ctx, in); sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
|
||||||
digit = digit_value(c);
|
digit = digit_value(c);
|
||||||
if ((digit < 0) || (digit >= (int)base))
|
if ((digit < 0) || (digit >= base))
|
||||||
break;
|
break;
|
||||||
res = sexp_bignum_fxmul(ctx, res, res, base, 0);
|
res = sexp_bignum_fxmul(ctx, res, res, base, 0);
|
||||||
res = sexp_bignum_fxadd(ctx, res, digit);
|
res = sexp_bignum_fxadd(ctx, res, digit);
|
||||||
|
@ -318,32 +261,9 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
|
||||||
if (c=='.' || c=='e' || c=='E') {
|
if (c=='.' || c=='e' || c=='E') {
|
||||||
if (base != 10) {
|
if (base != 10) {
|
||||||
res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
|
res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
|
||||||
} else if (c=='.') {
|
} else {
|
||||||
|
if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */
|
||||||
res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1));
|
res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1));
|
||||||
} else {
|
|
||||||
tmp = sexp_read_number(ctx, in, base, 0);
|
|
||||||
#if SEXP_USE_COMPLEX
|
|
||||||
if (sexp_complexp(tmp)) {
|
|
||||||
imag = sexp_complex_imag(tmp);
|
|
||||||
tmp = sexp_complex_real(tmp);
|
|
||||||
} else {
|
|
||||||
imag = SEXP_ZERO;
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
if (sexp_exceptionp(tmp)) {
|
|
||||||
res = tmp;
|
|
||||||
} else if (sexp_fixnump(tmp) && labs(sexp_unbox_fixnum(tmp)) < 100*1024*1024) {
|
|
||||||
tmp = sexp_expt(ctx, SEXP_TEN, tmp);
|
|
||||||
res = sexp_mul(ctx, res, tmp);
|
|
||||||
} else {
|
|
||||||
tmp = sexp_exact_to_inexact(ctx, NULL, 2, tmp);
|
|
||||||
tmp = sexp_expt(ctx, SEXP_TEN, tmp);
|
|
||||||
res = sexp_mul(ctx, res, tmp);
|
|
||||||
}
|
|
||||||
#if SEXP_USE_COMPLEX
|
|
||||||
if (imag != SEXP_ZERO && !sexp_exceptionp(res))
|
|
||||||
res = sexp_make_complex(ctx, res, imag);
|
|
||||||
#endif
|
|
||||||
}
|
}
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
} else if (c=='/') {
|
} else if (c=='/') {
|
||||||
|
@ -364,7 +284,7 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
|
||||||
} else {
|
} else {
|
||||||
sexp_push_char(ctx, c, in);
|
sexp_push_char(ctx, c, in);
|
||||||
}
|
}
|
||||||
sexp_gc_release3(ctx);
|
sexp_gc_release1(ctx);
|
||||||
return sexp_bignum_normalize(res);
|
return sexp_bignum_normalize(res);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -383,9 +303,6 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) {
|
||||||
sexp_gc_preserve2(ctx, b, str);
|
sexp_gc_preserve2(ctx, b, str);
|
||||||
b = sexp_copy_bignum(ctx, NULL, a, 0);
|
b = sexp_copy_bignum(ctx, NULL, a, 0);
|
||||||
sexp_bignum_sign(b) = 1;
|
sexp_bignum_sign(b) = 1;
|
||||||
if (lg_base < 1) {
|
|
||||||
return sexp_xtype_exception(ctx, NULL, "number base too small", a);
|
|
||||||
}
|
|
||||||
i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1)
|
i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1)
|
||||||
/ lg_base + 1;
|
/ lg_base + 1;
|
||||||
str = sexp_make_string(ctx, sexp_make_fixnum(str_len),
|
str = sexp_make_string(ctx, sexp_make_fixnum(str_len),
|
||||||
|
@ -595,44 +512,44 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
|
||||||
sexp_bignum_sign(b1) = 1;
|
sexp_bignum_sign(b1) = 1;
|
||||||
q = SEXP_ZERO;
|
q = SEXP_ZERO;
|
||||||
x = sexp_make_bignum(ctx, sexp_bignum_length(a));
|
x = sexp_make_bignum(ctx, sexp_bignum_length(a));
|
||||||
while (sexp_bignum_compare_abs(a1, b1) >= 0) { /* a1, b1 at least 2 bigits */
|
while (sexp_bignum_compare_abs(a1, b1) > 0) { /* a1, b1 at least 2 bigits */
|
||||||
/* guess divisor x */
|
/* guess divisor x */
|
||||||
alen = sexp_bignum_hi(a1);
|
alen = sexp_bignum_hi(a1);
|
||||||
sexp_bignum_data(x)[off] = 0;
|
sexp_bignum_data(x)[off] = 0;
|
||||||
if (off > 0) sexp_bignum_data(x)[off-1] = 0;
|
if (off > 0) sexp_bignum_data(x)[off-1] = 0;
|
||||||
off = alen - blen + 1;
|
off = alen - blen + 1;
|
||||||
dn = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(a1)[alen-1])
|
dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
|
||||||
, (sizeof(sexp_uint_t)*8))
|
<< (sizeof(sexp_uint_t)*8))
|
||||||
, sexp_bignum_data(a1)[alen-2]);
|
+ sexp_bignum_data(a1)[alen-2]);
|
||||||
dd = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(b1)[blen-1])
|
dd = (((sexp_luint_t)sexp_bignum_data(b1)[blen-1]
|
||||||
, (sizeof(sexp_uint_t)*8))
|
<< (sizeof(sexp_uint_t)*8))
|
||||||
, sexp_bignum_data(b1)[blen-2]);
|
+ sexp_bignum_data(b1)[blen-2]);
|
||||||
if (alen > 2 && blen > 2 &&
|
if (alen > 2 && blen > 2 &&
|
||||||
luint_lt(luint_from_uint(sexp_bignum_data(a1)[alen-1]), luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4))) &&
|
sexp_bignum_data(a1)[alen-1] < (1uL<<(sizeof(sexp_uint_t)*4)) &&
|
||||||
luint_lt(luint_from_uint(sexp_bignum_data(b1)[blen-1]), luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4)))) {
|
sexp_bignum_data(b1)[blen-1] < (1uL<<(sizeof(sexp_uint_t)*4))) {
|
||||||
dn = luint_add_uint(luint_shl(dn, (sizeof(sexp_uint_t)*4))
|
dn = (dn << (sizeof(sexp_uint_t)*4))
|
||||||
, (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4)));
|
+ (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4));
|
||||||
dd = luint_add_uint(luint_shl(dd, (sizeof(sexp_uint_t)*4))
|
dd = (dd << (sizeof(sexp_uint_t)*4))
|
||||||
, (sexp_bignum_data(b1)[blen-3] >> (sizeof(sexp_uint_t)*4)));
|
+ (sexp_bignum_data(b1)[blen-3] >> (sizeof(sexp_uint_t)*4));
|
||||||
}
|
}
|
||||||
d = luint_div(dn, dd);
|
d = dn / dd;
|
||||||
if (luint_eq(d, luint_from_uint(0))) {
|
if (d == 0) {
|
||||||
dn = luint_add_uint(luint_shl(luint_from_uint(sexp_bignum_data(a1)[alen-1])
|
dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
|
||||||
, (sizeof(sexp_uint_t)*8))
|
<< (sizeof(sexp_uint_t)*8))
|
||||||
, sexp_bignum_data(a1)[alen-2]);
|
+ sexp_bignum_data(a1)[alen-2]);
|
||||||
dd = luint_from_uint(sexp_bignum_data(b1)[blen-1]);
|
dd = sexp_bignum_data(b1)[blen-1];
|
||||||
if (luint_lt(luint_from_uint(sexp_bignum_data(a1)[alen-1]), (luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4)))) &&
|
if (sexp_bignum_data(a1)[alen-1] < (1uL<<(sizeof(sexp_uint_t)*4)) &&
|
||||||
luint_lt(luint_from_uint(sexp_bignum_data(b1)[blen-1]), (luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*4))))) {
|
sexp_bignum_data(b1)[blen-1] < (1uL<<(sizeof(sexp_uint_t)*4))) {
|
||||||
dn = luint_add_uint(luint_shl(dn, (sizeof(sexp_uint_t)*4))
|
dn = (dn << (sizeof(sexp_uint_t)*4))
|
||||||
, (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4)));
|
+ (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4));
|
||||||
dd = luint_add_uint(luint_shl(dd, (sizeof(sexp_uint_t)*4))
|
dd = (dd << (sizeof(sexp_uint_t)*4))
|
||||||
, (sexp_bignum_data(b1)[blen-2] >> (sizeof(sexp_uint_t)*4)));
|
+ (sexp_bignum_data(b1)[blen-2] >> (sizeof(sexp_uint_t)*4));
|
||||||
}
|
}
|
||||||
d = luint_div(dn, dd);
|
d = dn / dd;
|
||||||
off--;
|
off--;
|
||||||
}
|
}
|
||||||
dhi = luint_to_uint(luint_shr(d, (sizeof(sexp_uint_t)*8)));
|
dhi = d >> (sizeof(sexp_uint_t)*8);
|
||||||
dlo = luint_to_uint(luint_and(d, luint_sub(luint_shl(luint_from_uint(1), (sizeof(sexp_uint_t)*8)), luint_from_uint(1))));
|
dlo = d & (((sexp_luint_t)1<<(sizeof(sexp_uint_t)*8))-1);
|
||||||
sexp_bignum_data(x)[off] = dhi;
|
sexp_bignum_data(x)[off] = dhi;
|
||||||
if (off > 0) sexp_bignum_data(x)[off-1] = dlo;
|
if (off > 0) sexp_bignum_data(x)[off-1] = dlo;
|
||||||
/* update quotient q and remainder a1 estimates */
|
/* update quotient q and remainder a1 estimates */
|
||||||
|
@ -646,13 +563,12 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
|
||||||
}
|
}
|
||||||
/* flip the sign if we overshot in our estimate */
|
/* flip the sign if we overshot in our estimate */
|
||||||
if (sexp_bignum_sign(a1) != sign) {
|
if (sexp_bignum_sign(a1) != sign) {
|
||||||
sexp_bignum_sign(a1) = (char)(-sign);
|
sexp_bignum_sign(a1) = -sign;
|
||||||
sign *= -1;
|
sign *= -1;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
/* adjust signs */
|
/* adjust signs */
|
||||||
a1 = sexp_bignum_normalize(a1);
|
if (sign < 0) {
|
||||||
if (sign < 0 && a1 != SEXP_ZERO) {
|
|
||||||
q = sexp_sub(ctx, q, SEXP_ONE);
|
q = sexp_sub(ctx, q, SEXP_ONE);
|
||||||
a1 = sexp_add(ctx, a1, b1);
|
a1 = sexp_add(ctx, a1, b1);
|
||||||
}
|
}
|
||||||
|
@ -685,21 +601,14 @@ sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) {
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) {
|
sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) {
|
||||||
sexp_sint_t e = sexp_unbox_fixnum(b);
|
sexp_sint_t e = sexp_unbox_fx_abs(b);
|
||||||
sexp_sint_t abs_e;
|
|
||||||
if (e < 0)
|
|
||||||
abs_e = -e;
|
|
||||||
else
|
|
||||||
abs_e = e;
|
|
||||||
sexp_gc_var2(res, acc);
|
sexp_gc_var2(res, acc);
|
||||||
sexp_gc_preserve2(ctx, res, acc);
|
sexp_gc_preserve2(ctx, res, acc);
|
||||||
res = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
|
res = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
|
||||||
acc = sexp_copy_bignum(ctx, NULL, a, 0);
|
acc = sexp_copy_bignum(ctx, NULL, a, 0);
|
||||||
for (; abs_e; abs_e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
|
for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
|
||||||
if (abs_e & 1)
|
if (e & 1)
|
||||||
res = sexp_bignum_mul(ctx, NULL, res, acc);
|
res = sexp_bignum_mul(ctx, NULL, res, acc);
|
||||||
if (e < 0)
|
|
||||||
res = sexp_div(ctx, sexp_fixnum_to_bignum(ctx, SEXP_ONE), res);
|
|
||||||
sexp_gc_release2(ctx);
|
sexp_gc_release2(ctx);
|
||||||
return sexp_bignum_normalize(res);
|
return sexp_bignum_normalize(res);
|
||||||
}
|
}
|
||||||
|
@ -735,7 +644,7 @@ sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) {
|
||||||
if (! sexp_bignump(a)) return sexp_type_exception(ctx, NULL, SEXP_BIGNUM, a);
|
if (! sexp_bignump(a)) return sexp_type_exception(ctx, NULL, SEXP_BIGNUM, a);
|
||||||
sexp_gc_preserve4(ctx, res, rem, tmp, tmpa);
|
sexp_gc_preserve4(ctx, res, rem, tmp, tmpa);
|
||||||
/* initial estimate via flonum, ignoring signs */
|
/* initial estimate via flonum, ignoring signs */
|
||||||
if (sexp_exact_negativep(a)) {
|
if (sexp_negativep(a)) {
|
||||||
tmpa = sexp_copy_bignum(ctx, NULL, a, 0);
|
tmpa = sexp_copy_bignum(ctx, NULL, a, 0);
|
||||||
a = tmpa;
|
a = tmpa;
|
||||||
sexp_negate(a);
|
sexp_negate(a);
|
||||||
|
@ -779,25 +688,12 @@ sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) {
|
||||||
|
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
|
|
||||||
double sexp_ratio_to_double (sexp ctx, sexp rat) {
|
double sexp_ratio_to_double (sexp rat) {
|
||||||
sexp_gc_var1(quot);
|
|
||||||
sexp num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
|
sexp num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
|
||||||
double res = (sexp_bignump(num) ? sexp_bignum_to_double(num)
|
return (sexp_bignump(num) ? sexp_bignum_to_double(num)
|
||||||
: sexp_fixnum_to_double(num))
|
: sexp_fixnum_to_double(num))
|
||||||
/ (sexp_bignump(den) ? sexp_bignum_to_double(den)
|
/ (sexp_bignump(den) ? sexp_bignum_to_double(den)
|
||||||
: sexp_fixnum_to_double(den));
|
: sexp_fixnum_to_double(den));
|
||||||
if (!isfinite(res)) {
|
|
||||||
sexp_gc_preserve1(ctx, quot);
|
|
||||||
if (sexp_unbox_fixnum(sexp_compare(ctx, sexp_ratio_numerator(rat), sexp_ratio_denominator(rat))) < 0) {
|
|
||||||
quot = sexp_quotient(ctx, sexp_ratio_denominator(rat), sexp_ratio_numerator(rat));
|
|
||||||
res = 1 / sexp_to_double(ctx, quot);
|
|
||||||
} else {
|
|
||||||
quot = sexp_quotient(ctx, sexp_ratio_numerator(rat), sexp_ratio_denominator(rat));
|
|
||||||
res = sexp_to_double(ctx, quot);
|
|
||||||
}
|
|
||||||
sexp_gc_release1(ctx);
|
|
||||||
}
|
|
||||||
return res;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_double_to_ratio (sexp ctx, double f) {
|
sexp sexp_double_to_ratio (sexp ctx, double f) {
|
||||||
|
@ -813,7 +709,7 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
|
||||||
for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) {
|
for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) {
|
||||||
res = sexp_bignum_fxmul(ctx, NULL, res, 10, 0);
|
res = sexp_bignum_fxmul(ctx, NULL, res, 10, 0);
|
||||||
f = f * 10;
|
f = f * 10;
|
||||||
res = sexp_bignum_fxadd(ctx, res, (sexp_uint_t)double_10s_digit(f));
|
res = sexp_bignum_fxadd(ctx, res, double_10s_digit(f));
|
||||||
f = f - trunc(f);
|
f = f - trunc(f);
|
||||||
scale = sexp_mul(ctx, scale, SEXP_TEN);
|
scale = sexp_mul(ctx, scale, SEXP_TEN);
|
||||||
}
|
}
|
||||||
|
@ -827,41 +723,6 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
/*
|
|
||||||
* For conversion that does not introduce round-off error,
|
|
||||||
* no matter what FLT_RADIX is.
|
|
||||||
*/
|
|
||||||
sexp sexp_double_to_ratio_2 (sexp ctx, double f) {
|
|
||||||
int sign,i;
|
|
||||||
sexp_gc_var3(res, whole, scale);
|
|
||||||
if (f == trunc(f))
|
|
||||||
return sexp_bignum_normalize(sexp_double_to_bignum(ctx, f));
|
|
||||||
sexp_gc_preserve3(ctx, res, whole, scale);
|
|
||||||
whole = sexp_double_to_bignum(ctx, trunc(f));
|
|
||||||
res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
|
|
||||||
scale = SEXP_ONE;
|
|
||||||
sign = (f < 0 ? -1 : 1);
|
|
||||||
f = fabs(f-trunc(f));
|
|
||||||
while(f) {
|
|
||||||
res = sexp_bignum_fxmul(ctx, NULL, res, FLT_RADIX, 0);
|
|
||||||
scale = sexp_mul(ctx, scale, sexp_make_fixnum(FLT_RADIX));
|
|
||||||
f *= FLT_RADIX;
|
|
||||||
i = trunc(f);
|
|
||||||
if (i) {
|
|
||||||
f -= i;
|
|
||||||
res = sexp_bignum_fxadd(ctx, res, i);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
sexp_bignum_sign(res) = sign;
|
|
||||||
res = sexp_bignum_normalize(res);
|
|
||||||
scale = sexp_bignum_normalize(scale);
|
|
||||||
res = sexp_make_ratio(ctx, res, scale);
|
|
||||||
res = sexp_ratio_normalize(ctx, res, SEXP_FALSE);
|
|
||||||
res = sexp_add(ctx, res, whole);
|
|
||||||
sexp_gc_release3(ctx);
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
sexp sexp_ratio_add (sexp ctx, sexp a, sexp b) {
|
sexp sexp_ratio_add (sexp ctx, sexp a, sexp b) {
|
||||||
sexp_gc_var3(res, num, den);
|
sexp_gc_var3(res, num, den);
|
||||||
sexp_gc_preserve3(ctx, res, num, den);
|
sexp_gc_preserve3(ctx, res, num, den);
|
||||||
|
@ -912,13 +773,13 @@ sexp sexp_ratio_round (sexp ctx, sexp a) {
|
||||||
sexp_gc_preserve2(ctx, q, r);
|
sexp_gc_preserve2(ctx, q, r);
|
||||||
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
|
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
|
||||||
if ((sexp_ratio_denominator(a) == SEXP_TWO) && sexp_oddp(q)) {
|
if ((sexp_ratio_denominator(a) == SEXP_TWO) && sexp_oddp(q)) {
|
||||||
q = sexp_add(ctx, q, (sexp_exact_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
|
q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
|
||||||
} else {
|
} else {
|
||||||
r = sexp_remainder(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
|
r = sexp_remainder(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
|
||||||
r = sexp_mul(ctx, r, SEXP_TWO);
|
r = sexp_mul(ctx, r, SEXP_TWO);
|
||||||
if (sexp_exact_negativep(r)) {sexp_negate(r);}
|
if (sexp_negativep(r)) {sexp_negate(r);}
|
||||||
if (sexp_unbox_fixnum(sexp_compare(ctx, r, sexp_ratio_denominator(a))) > 0)
|
if (sexp_unbox_fixnum(sexp_compare(ctx, r, sexp_ratio_denominator(a))) > 0)
|
||||||
q = sexp_add(ctx, q, (sexp_exact_negativep(sexp_ratio_numerator(a)) ? SEXP_NEG_ONE : SEXP_ONE));
|
q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
|
||||||
}
|
}
|
||||||
sexp_gc_release2(ctx);
|
sexp_gc_release2(ctx);
|
||||||
return q;
|
return q;
|
||||||
|
@ -932,7 +793,7 @@ sexp sexp_ratio_floor (sexp ctx, sexp a) {
|
||||||
sexp_gc_var1(q);
|
sexp_gc_var1(q);
|
||||||
sexp_gc_preserve1(ctx, q);
|
sexp_gc_preserve1(ctx, q);
|
||||||
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
|
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
|
||||||
if (sexp_exact_negativep(sexp_ratio_numerator(a)))
|
if (sexp_negativep(sexp_ratio_numerator(a)))
|
||||||
q = sexp_add(ctx, q, SEXP_NEG_ONE);
|
q = sexp_add(ctx, q, SEXP_NEG_ONE);
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release1(ctx);
|
||||||
return q;
|
return q;
|
||||||
|
@ -942,7 +803,7 @@ sexp sexp_ratio_ceiling (sexp ctx, sexp a) {
|
||||||
sexp_gc_var1(q);
|
sexp_gc_var1(q);
|
||||||
sexp_gc_preserve1(ctx, q);
|
sexp_gc_preserve1(ctx, q);
|
||||||
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
|
q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
|
||||||
if (sexp_exact_positivep(sexp_ratio_numerator(a)))
|
if (sexp_positivep(sexp_ratio_numerator(a)))
|
||||||
q = sexp_add(ctx, q, SEXP_ONE);
|
q = sexp_add(ctx, q, SEXP_ONE);
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release1(ctx);
|
||||||
return q;
|
return q;
|
||||||
|
@ -950,21 +811,6 @@ sexp sexp_ratio_ceiling (sexp ctx, sexp a) {
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
double sexp_to_double (sexp ctx, sexp x) {
|
|
||||||
if (sexp_flonump(x))
|
|
||||||
return sexp_flonum_value(x);
|
|
||||||
else if (sexp_fixnump(x))
|
|
||||||
return sexp_fixnum_to_double(x);
|
|
||||||
else if (sexp_bignump(x))
|
|
||||||
return sexp_bignum_to_double(x);
|
|
||||||
#if SEXP_USE_RATIOS
|
|
||||||
else if (sexp_ratiop(x))
|
|
||||||
return sexp_ratio_to_double(ctx, x);
|
|
||||||
#endif
|
|
||||||
else
|
|
||||||
return 0.0;
|
|
||||||
}
|
|
||||||
|
|
||||||
/************************ complex numbers ****************************/
|
/************************ complex numbers ****************************/
|
||||||
|
|
||||||
#if SEXP_USE_COMPLEX
|
#if SEXP_USE_COMPLEX
|
||||||
|
@ -999,8 +845,8 @@ sexp sexp_complex_sub (sexp ctx, sexp a, sexp b) {
|
||||||
sexp_gc_var2(res, tmp);
|
sexp_gc_var2(res, tmp);
|
||||||
sexp_gc_preserve2(ctx, res, tmp);
|
sexp_gc_preserve2(ctx, res, tmp);
|
||||||
tmp = sexp_complex_copy(ctx, b);
|
tmp = sexp_complex_copy(ctx, b);
|
||||||
sexp_negate_maybe_ratio(sexp_complex_real(tmp));
|
sexp_negate(sexp_complex_real(tmp));
|
||||||
sexp_negate_maybe_ratio(sexp_complex_imag(tmp));
|
sexp_negate(sexp_complex_imag(tmp));
|
||||||
res = sexp_complex_add(ctx, a, tmp);
|
res = sexp_complex_add(ctx, a, tmp);
|
||||||
sexp_gc_release2(ctx);
|
sexp_gc_release2(ctx);
|
||||||
return res;
|
return res;
|
||||||
|
@ -1046,6 +892,21 @@ sexp sexp_complex_div (sexp ctx, sexp a, sexp b) {
|
||||||
return sexp_complex_normalize(res);
|
return sexp_complex_normalize(res);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
static double sexp_to_double (sexp x) {
|
||||||
|
if (sexp_flonump(x))
|
||||||
|
return sexp_flonum_value(x);
|
||||||
|
else if (sexp_fixnump(x))
|
||||||
|
return sexp_fixnum_to_double(x);
|
||||||
|
else if (sexp_bignump(x))
|
||||||
|
return sexp_bignum_to_double(x);
|
||||||
|
#if SEXP_USE_RATIOS
|
||||||
|
else if (sexp_ratiop(x))
|
||||||
|
return sexp_ratio_to_double(x);
|
||||||
|
#endif
|
||||||
|
else
|
||||||
|
return 0.0;
|
||||||
|
}
|
||||||
|
|
||||||
static sexp sexp_to_complex (sexp ctx, sexp x) {
|
static sexp sexp_to_complex (sexp ctx, sexp x) {
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
sexp_gc_var1(tmp);
|
sexp_gc_var1(tmp);
|
||||||
|
@ -1056,7 +917,7 @@ static sexp sexp_to_complex (sexp ctx, sexp x) {
|
||||||
} else if (sexp_ratiop(x)) {
|
} else if (sexp_ratiop(x)) {
|
||||||
sexp_gc_preserve1(ctx, tmp);
|
sexp_gc_preserve1(ctx, tmp);
|
||||||
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
||||||
sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(ctx, x));
|
sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(x));
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release1(ctx);
|
||||||
return tmp;
|
return tmp;
|
||||||
#endif
|
#endif
|
||||||
|
@ -1066,8 +927,8 @@ static sexp sexp_to_complex (sexp ctx, sexp x) {
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_complex_exp (sexp ctx, sexp z) {
|
sexp sexp_complex_exp (sexp ctx, sexp z) {
|
||||||
double e2x = exp(sexp_to_double(ctx, sexp_complex_real(z))),
|
double e2x = exp(sexp_to_double(sexp_complex_real(z))),
|
||||||
y = sexp_to_double(ctx, sexp_complex_imag(z));
|
y = sexp_to_double(sexp_complex_imag(z));
|
||||||
sexp_gc_var1(res);
|
sexp_gc_var1(res);
|
||||||
sexp_gc_preserve1(ctx, res);
|
sexp_gc_preserve1(ctx, res);
|
||||||
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
||||||
|
@ -1078,8 +939,8 @@ sexp sexp_complex_exp (sexp ctx, sexp z) {
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_complex_log (sexp ctx, sexp z) {
|
sexp sexp_complex_log (sexp ctx, sexp z) {
|
||||||
double x = sexp_to_double(ctx, sexp_complex_real(z)),
|
double x = sexp_to_double(sexp_complex_real(z)),
|
||||||
y = sexp_to_double(ctx, sexp_complex_imag(z));
|
y = sexp_to_double(sexp_complex_imag(z));
|
||||||
sexp_gc_var1(res);
|
sexp_gc_var1(res);
|
||||||
sexp_gc_preserve1(ctx, res);
|
sexp_gc_preserve1(ctx, res);
|
||||||
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
||||||
|
@ -1103,21 +964,21 @@ sexp sexp_complex_expt (sexp ctx, sexp a, sexp b) {
|
||||||
#if SEXP_USE_MATH
|
#if SEXP_USE_MATH
|
||||||
|
|
||||||
sexp sexp_complex_sqrt (sexp ctx, sexp z) {
|
sexp sexp_complex_sqrt (sexp ctx, sexp z) {
|
||||||
double x = sexp_to_double(ctx, sexp_complex_real(z)),
|
double x = sexp_to_double(sexp_complex_real(z)),
|
||||||
y = sexp_to_double(ctx, sexp_complex_imag(z)), r;
|
y = sexp_to_double(sexp_complex_imag(z)), r;
|
||||||
sexp_gc_var1(res);
|
sexp_gc_var1(res);
|
||||||
sexp_gc_preserve1(ctx, res);
|
sexp_gc_preserve1(ctx, res);
|
||||||
r = sqrt(x*x + y*y);
|
r = sqrt(x*x + y*y);
|
||||||
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
||||||
sexp_complex_real(res) = sexp_make_flonum(ctx, sqrt((x+r)/2));
|
sexp_complex_real(res) = sexp_make_flonum(ctx, sqrt((x+r)/2));
|
||||||
sexp_complex_imag(res) = sexp_make_flonum(ctx, ((y<-0.0)?-1:1)*sqrt((-x+r)/2));
|
sexp_complex_imag(res) = sexp_make_flonum(ctx, (y<0?-1:1)*sqrt((-x+r)/2));
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release1(ctx);
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_complex_sin (sexp ctx, sexp z) {
|
sexp sexp_complex_sin (sexp ctx, sexp z) {
|
||||||
double x = sexp_to_double(ctx, sexp_complex_real(z)),
|
double x = sexp_to_double(sexp_complex_real(z)),
|
||||||
y = sexp_to_double(ctx, sexp_complex_imag(z));
|
y = sexp_to_double(sexp_complex_imag(z));
|
||||||
sexp_gc_var1(res);
|
sexp_gc_var1(res);
|
||||||
sexp_gc_preserve1(ctx, res);
|
sexp_gc_preserve1(ctx, res);
|
||||||
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
||||||
|
@ -1128,8 +989,8 @@ sexp sexp_complex_sin (sexp ctx, sexp z) {
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_complex_cos (sexp ctx, sexp z) {
|
sexp sexp_complex_cos (sexp ctx, sexp z) {
|
||||||
double x = sexp_to_double(ctx, sexp_complex_real(z)),
|
double x = sexp_to_double(sexp_complex_real(z)),
|
||||||
y = sexp_to_double(ctx, sexp_complex_imag(z));
|
y = sexp_to_double(sexp_complex_imag(z));
|
||||||
sexp_gc_var1(res);
|
sexp_gc_var1(res);
|
||||||
sexp_gc_preserve1(ctx, res);
|
sexp_gc_preserve1(ctx, res);
|
||||||
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
||||||
|
@ -1151,19 +1012,22 @@ sexp sexp_complex_tan (sexp ctx, sexp z) {
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_complex_asin (sexp ctx, sexp z) {
|
sexp sexp_complex_asin (sexp ctx, sexp z) {
|
||||||
sexp_gc_var3(res, tmp, tmp2);
|
sexp_gc_var2(res, tmp);
|
||||||
sexp_gc_preserve3(ctx, res, tmp, tmp2);
|
sexp_gc_preserve2(ctx, res, tmp);
|
||||||
res = sexp_complex_mul(ctx, z, z);
|
res = sexp_complex_mul(ctx, z, z);
|
||||||
res = sexp_sub(ctx, SEXP_ONE, res);
|
tmp = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO);
|
||||||
res = sexp_sqrt(ctx, NULL, 1, res);
|
res = sexp_complex_sub(ctx, tmp, res);
|
||||||
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
res = sexp_complex_sqrt(ctx, res);
|
||||||
sexp_complex_real(tmp) = sexp_mul(ctx, SEXP_NEG_ONE, sexp_complex_imag(z));
|
/* tmp = iz */
|
||||||
|
sexp_complex_real(tmp) = sexp_complex_imag(z);
|
||||||
|
sexp_negate(sexp_complex_real(tmp));
|
||||||
sexp_complex_imag(tmp) = sexp_complex_real(z);
|
sexp_complex_imag(tmp) = sexp_complex_real(z);
|
||||||
res = sexp_add(ctx, tmp, res);
|
res = sexp_complex_add(ctx, tmp, res);
|
||||||
res = sexp_log(ctx, NULL, 1, res);
|
tmp = sexp_complex_log(ctx, res);
|
||||||
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_NEG_ONE);
|
/* res = -i*tmp */
|
||||||
res = sexp_mul(ctx, res, tmp);
|
res = sexp_complex_copy(ctx, tmp);
|
||||||
sexp_gc_release3(ctx);
|
sexp_negate(sexp_complex_imag(res));
|
||||||
|
sexp_gc_release2(ctx);
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -1327,7 +1191,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
|
||||||
r = sexp_make_fixnum(sum);
|
r = sexp_make_fixnum(sum);
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_FLO:
|
case SEXP_NUM_FIX_FLO:
|
||||||
r = a == SEXP_ZERO ? b : sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
|
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_BIG:
|
case SEXP_NUM_FIX_BIG:
|
||||||
r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a));
|
r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a));
|
||||||
|
@ -1343,7 +1207,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
|
||||||
break;
|
break;
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_FLO_RAT:
|
case SEXP_NUM_FLO_RAT:
|
||||||
r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_ratio_to_double(ctx, b));
|
r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_ratio_to_double(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_RAT:
|
case SEXP_NUM_FIX_RAT:
|
||||||
case SEXP_NUM_BIG_RAT:
|
case SEXP_NUM_BIG_RAT:
|
||||||
|
@ -1403,7 +1267,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
|
||||||
r = sexp_fx_sub(a, b); /* VM catches this case */
|
r = sexp_fx_sub(a, b); /* VM catches this case */
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_FLO:
|
case SEXP_NUM_FIX_FLO:
|
||||||
r = sexp_make_flonum(ctx, a==SEXP_ZERO ? -sexp_flonum_value(b) : sexp_fixnum_to_double(a)-sexp_flonum_value(b));
|
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_BIG:
|
case SEXP_NUM_FIX_BIG:
|
||||||
tmp1 = sexp_fixnum_to_bignum(ctx, a);
|
tmp1 = sexp_fixnum_to_bignum(ctx, a);
|
||||||
|
@ -1432,10 +1296,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
|
||||||
break;
|
break;
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_FLO_RAT:
|
case SEXP_NUM_FLO_RAT:
|
||||||
r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_ratio_to_double(ctx, b));
|
r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_ratio_to_double(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_RAT_FLO:
|
case SEXP_NUM_RAT_FLO:
|
||||||
r = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a) - sexp_flonum_value(b));
|
r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) - sexp_flonum_value(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_RAT_FIX:
|
case SEXP_NUM_RAT_FIX:
|
||||||
case SEXP_NUM_RAT_BIG:
|
case SEXP_NUM_RAT_BIG:
|
||||||
|
@ -1453,17 +1317,21 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
|
||||||
sexp_negate_exact(sexp_ratio_numerator(tmp2));
|
sexp_negate_exact(sexp_ratio_numerator(tmp2));
|
||||||
r = sexp_ratio_add(ctx, a, tmp2);
|
r = sexp_ratio_add(ctx, a, tmp2);
|
||||||
if (negatep) {
|
if (negatep) {
|
||||||
sexp_negate_maybe_ratio(r);
|
if (sexp_ratiop(r)) {
|
||||||
|
sexp_negate_exact(sexp_ratio_numerator(r));
|
||||||
|
} else {
|
||||||
|
sexp_negate_exact(r);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
#endif
|
#endif
|
||||||
#if SEXP_USE_COMPLEX
|
#if SEXP_USE_COMPLEX
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_RAT_CPX:
|
case SEXP_NUM_RAT_CPX:
|
||||||
a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a));
|
a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
|
||||||
goto complex_sub;
|
goto complex_sub;
|
||||||
case SEXP_NUM_CPX_RAT:
|
case SEXP_NUM_CPX_RAT:
|
||||||
b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, b));
|
b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
|
||||||
/* ... FALLTHROUGH ... */
|
/* ... FALLTHROUGH ... */
|
||||||
#endif
|
#endif
|
||||||
case SEXP_NUM_CPX_FLO:
|
case SEXP_NUM_CPX_FLO:
|
||||||
|
@ -1485,10 +1353,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
|
||||||
if (negatep) {
|
if (negatep) {
|
||||||
if (sexp_complexp(r)) {
|
if (sexp_complexp(r)) {
|
||||||
r = sexp_complex_copy(ctx, r);
|
r = sexp_complex_copy(ctx, r);
|
||||||
sexp_negate_maybe_ratio(sexp_complex_real(r));
|
sexp_negate(sexp_complex_real(r));
|
||||||
sexp_negate_maybe_ratio(sexp_complex_imag(r));
|
sexp_negate(sexp_complex_imag(r));
|
||||||
} else {
|
} else {
|
||||||
sexp_negate_maybe_ratio(r);
|
sexp_negate(r);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
|
@ -1514,11 +1382,11 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
|
||||||
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
|
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_FIX:
|
case SEXP_NUM_FIX_FIX:
|
||||||
prod = lsint_mul_sint(lsint_from_sint(sexp_unbox_fixnum(a)), sexp_unbox_fixnum(b));
|
prod = (sexp_lsint_t)sexp_unbox_fixnum(a) * sexp_unbox_fixnum(b);
|
||||||
if (!lsint_is_fixnum(prod))
|
if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM))
|
||||||
r = sexp_mul(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
|
r = sexp_mul(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
|
||||||
else
|
else
|
||||||
r = sexp_make_fixnum(lsint_to_sint(prod));
|
r = sexp_make_fixnum(prod);
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_FLO:
|
case SEXP_NUM_FIX_FLO:
|
||||||
r = (a==SEXP_ZERO ? a : sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)));
|
r = (a==SEXP_ZERO ? a : sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)));
|
||||||
|
@ -1539,7 +1407,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
|
||||||
break;
|
break;
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_FLO_RAT:
|
case SEXP_NUM_FLO_RAT:
|
||||||
r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_ratio_to_double(ctx, b));
|
r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_ratio_to_double(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_RAT:
|
case SEXP_NUM_FIX_RAT:
|
||||||
case SEXP_NUM_BIG_RAT:
|
case SEXP_NUM_BIG_RAT:
|
||||||
|
@ -1646,10 +1514,10 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
|
||||||
break;
|
break;
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_FLO_RAT:
|
case SEXP_NUM_FLO_RAT:
|
||||||
r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_ratio_to_double(ctx, b));
|
r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_ratio_to_double(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_RAT_FLO:
|
case SEXP_NUM_RAT_FLO:
|
||||||
r = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a) / sexp_flonum_value(b));
|
r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) / sexp_flonum_value(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_RAT_FIX:
|
case SEXP_NUM_RAT_FIX:
|
||||||
case SEXP_NUM_RAT_BIG:
|
case SEXP_NUM_RAT_BIG:
|
||||||
|
@ -1667,7 +1535,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
|
||||||
#if SEXP_USE_COMPLEX
|
#if SEXP_USE_COMPLEX
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_CPX_RAT:
|
case SEXP_NUM_CPX_RAT:
|
||||||
b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, b));
|
b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
|
||||||
/* ... FALLTHROUGH ... */
|
/* ... FALLTHROUGH ... */
|
||||||
#endif
|
#endif
|
||||||
case SEXP_NUM_CPX_FLO:
|
case SEXP_NUM_CPX_FLO:
|
||||||
|
@ -1678,7 +1546,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_RAT_CPX:
|
case SEXP_NUM_RAT_CPX:
|
||||||
if (sexp_ratiop(a))
|
if (sexp_ratiop(a))
|
||||||
a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, a));
|
a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
|
||||||
/* ... FALLTHROUGH ... */
|
/* ... FALLTHROUGH ... */
|
||||||
#endif
|
#endif
|
||||||
case SEXP_NUM_FLO_CPX:
|
case SEXP_NUM_FLO_CPX:
|
||||||
|
@ -1762,9 +1630,6 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_FIX:
|
case SEXP_NUM_FIX_FIX:
|
||||||
r = sexp_fx_div(a, b);
|
r = sexp_fx_div(a, b);
|
||||||
if ((sexp_sint_t)a < 0 && (sexp_sint_t)b < 0 && (sexp_sint_t)r < 0) {
|
|
||||||
r = sexp_quotient(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
|
|
||||||
}
|
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_BIG:
|
case SEXP_NUM_FIX_BIG:
|
||||||
r = SEXP_ZERO;
|
r = SEXP_ZERO;
|
||||||
|
@ -1798,11 +1663,8 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_FLO_RAT:
|
case SEXP_NUM_FLO_RAT:
|
||||||
#endif
|
#endif
|
||||||
if (isinf(sexp_flonum_value(a)) ||
|
if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
|
||||||
sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
|
|
||||||
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
|
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
|
||||||
} else if (bt == SEXP_NUM_FLO && isinf(sexp_flonum_value(b))) {
|
|
||||||
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
|
|
||||||
} else {
|
} else {
|
||||||
tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(a)));
|
tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(a)));
|
||||||
tmp = sexp_remainder(ctx, tmp, b);
|
tmp = sexp_remainder(ctx, tmp, b);
|
||||||
|
@ -1825,8 +1687,7 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_RAT_FLO:
|
case SEXP_NUM_RAT_FLO:
|
||||||
#endif
|
#endif
|
||||||
if (isinf(sexp_flonum_value(b)) ||
|
if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
|
||||||
sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
|
|
||||||
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
|
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
|
||||||
} else {
|
} else {
|
||||||
tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(b)));
|
tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(b)));
|
||||||
|
@ -1867,16 +1728,16 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
|
||||||
sexp_gc_preserve1(ctx, tmp);
|
sexp_gc_preserve1(ctx, tmp);
|
||||||
if (at > bt) {
|
if (at > bt) {
|
||||||
r = sexp_compare(ctx, b, a);
|
r = sexp_compare(ctx, b, a);
|
||||||
if (!sexp_exceptionp(r)) { sexp_negate(r); }
|
sexp_negate(r);
|
||||||
} else {
|
} else {
|
||||||
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
|
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
|
||||||
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
|
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
|
||||||
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
|
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
|
||||||
#if SEXP_USE_COMPLEX
|
#if SEXP_USE_COMPLEX
|
||||||
case SEXP_NUM_CPX_CPX: case SEXP_NUM_FIX_CPX:
|
case SEXP_NUM_CPX_CPX: case SEXP_NUM_CPX_FIX:
|
||||||
case SEXP_NUM_FLO_CPX: case SEXP_NUM_BIG_CPX:
|
case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG:
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
case SEXP_NUM_RAT_CPX:
|
case SEXP_NUM_CPX_RAT:
|
||||||
#endif
|
#endif
|
||||||
#endif
|
#endif
|
||||||
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
|
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
|
||||||
|
@ -1885,13 +1746,9 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
|
||||||
r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b));
|
r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_FLO:
|
case SEXP_NUM_FIX_FLO:
|
||||||
if (isinf(sexp_flonum_value(b))) {
|
f = sexp_fixnum_to_double(a);
|
||||||
r = sexp_flonum_value(b) > 0 ? SEXP_NEG_ONE : SEXP_ONE;
|
g = sexp_flonum_value(b);
|
||||||
} else if (isnan(sexp_flonum_value(b))) {
|
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
|
||||||
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
|
|
||||||
} else {
|
|
||||||
r = sexp_compare(ctx, a, tmp=sexp_inexact_to_exact(ctx, NULL, 1, b));
|
|
||||||
}
|
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_BIG:
|
case SEXP_NUM_FIX_BIG:
|
||||||
if ((sexp_bignum_hi(b) > 1) ||
|
if ((sexp_bignum_hi(b) > 1) ||
|
||||||
|
@ -1903,11 +1760,6 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
|
||||||
case SEXP_NUM_FLO_FLO:
|
case SEXP_NUM_FLO_FLO:
|
||||||
f = sexp_flonum_value(a);
|
f = sexp_flonum_value(a);
|
||||||
g = sexp_flonum_value(b);
|
g = sexp_flonum_value(b);
|
||||||
if (isnan(f))
|
|
||||||
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
|
|
||||||
else if (isnan(g))
|
|
||||||
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
|
|
||||||
else
|
|
||||||
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
|
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FLO_BIG:
|
case SEXP_NUM_FLO_BIG:
|
||||||
|
@ -1933,7 +1785,8 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
|
||||||
} else if (isnan(f)) {
|
} else if (isnan(f)) {
|
||||||
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
|
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
|
||||||
} else {
|
} else {
|
||||||
r = sexp_compare(ctx, tmp=sexp_inexact_to_exact(ctx, NULL, 1, a), b);
|
g = sexp_ratio_to_double(b);
|
||||||
|
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_RAT:
|
case SEXP_NUM_FIX_RAT:
|
||||||
|
@ -1944,9 +1797,6 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
|
||||||
r = sexp_ratio_compare(ctx, a, b);
|
r = sexp_ratio_compare(ctx, a, b);
|
||||||
break;
|
break;
|
||||||
#endif
|
#endif
|
||||||
default:
|
|
||||||
r = sexp_xtype_exception(ctx, NULL, "unknown comparison", a);
|
|
||||||
break;
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release1(ctx);
|
||||||
|
|
|
@ -1,12 +0,0 @@
|
||||||
|
|
||||||
;; Don't import this - it's temporarily used to compute optimized
|
|
||||||
;; char-set representations.
|
|
||||||
|
|
||||||
(define-library (chibi char-set width)
|
|
||||||
(import (chibi) (chibi iset) (chibi char-set))
|
|
||||||
(include "width.scm")
|
|
||||||
(export
|
|
||||||
char-set:zero-width
|
|
||||||
char-set:full-width
|
|
||||||
char-set:ambiguous-width
|
|
||||||
))
|
|
206
chibi-scheme.vcproj
Normal file
206
chibi-scheme.vcproj
Normal 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
5
configure
vendored
|
@ -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'."
|
|
|
@ -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()
|
|
|
@ -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()
|
|
|
@ -1,2 +0,0 @@
|
||||||
|
|
||||||
include(${CMAKE_CURRENT_LIST_DIR}/chibi-scheme-targets.cmake)
|
|
|
@ -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}
|
|
|
@ -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)
|
|
|
@ -52,4 +52,4 @@ Alex Shinn (alexshinn @ gmail . com)
|
||||||
.PP
|
.PP
|
||||||
The chibi-scheme home-page:
|
The chibi-scheme home-page:
|
||||||
.BR
|
.BR
|
||||||
https://github.com/ashinn/chibi-scheme/
|
http://code.google.com/p/chibi-scheme/
|
||||||
|
|
|
@ -42,4 +42,4 @@ Alex Shinn (alexshinn @ gmail . com)
|
||||||
.PP
|
.PP
|
||||||
The chibi-scheme home-page:
|
The chibi-scheme home-page:
|
||||||
.BR
|
.BR
|
||||||
https://github.com/ashinn/chibi-scheme/
|
http://code.google.com/p/chibi-scheme/
|
||||||
|
|
|
@ -6,16 +6,13 @@ chibi-scheme \- a tiny Scheme interpreter
|
||||||
|
|
||||||
.SH SYNOPSIS
|
.SH SYNOPSIS
|
||||||
.B chibi-scheme
|
.B chibi-scheme
|
||||||
[-qQrRfTV]
|
[-qQrRfV]
|
||||||
[-I
|
[-I
|
||||||
.I path
|
.I path
|
||||||
]
|
]
|
||||||
[-A
|
[-A
|
||||||
.I path
|
.I path
|
||||||
]
|
]
|
||||||
[-D
|
|
||||||
.I feature
|
|
||||||
]
|
|
||||||
[-m
|
[-m
|
||||||
.I module
|
.I module
|
||||||
]
|
]
|
||||||
|
@ -79,14 +76,8 @@ module. This can be launched automatically with:
|
||||||
.I chibi-scheme -R
|
.I chibi-scheme -R
|
||||||
\[char46]
|
\[char46]
|
||||||
|
|
||||||
For convenience the default language is the
|
The default language the R7RS
|
||||||
(scheme small) module, which includes every library in the R7RS
|
(scheme base) module. To get a mostly R5RS-compatible language, use
|
||||||
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
|
.I chibi-scheme -xscheme.r5rs
|
||||||
or to get just the core language used for bootstrapping, use
|
or to get just the core language used for bootstrapping, use
|
||||||
.I chibi-scheme -xchibi
|
.I chibi-scheme -xchibi
|
||||||
|
@ -139,7 +130,7 @@ 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
|
arguments as in SRFI-22. The name "main" can be overridden with the -r
|
||||||
option.
|
option.
|
||||||
.I [module]
|
.I [module]
|
||||||
may be omitted, in which case it defaults to chibi.repl. Thus
|
may be omitted, in which case it default to chibi.repl. Thus
|
||||||
.I chibi-scheme -R
|
.I chibi-scheme -R
|
||||||
is the recommended means to obtain the advanced REPL.
|
is the recommended means to obtain the advanced REPL.
|
||||||
.TP
|
.TP
|
||||||
|
@ -149,11 +140,6 @@ Strict mode, escalating warnings to fatal errors.
|
||||||
.BI -f
|
.BI -f
|
||||||
Change the reader to case-fold symbols as in R5RS.
|
Change the reader to case-fold symbols as in R5RS.
|
||||||
.TP
|
.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]
|
.BI -h size[/max_size]
|
||||||
Specifies the initial size of the heap, in bytes,
|
Specifies the initial size of the heap, in bytes,
|
||||||
optionally followed by the maximum size the heap can
|
optionally followed by the maximum size the heap can
|
||||||
|
@ -175,12 +161,6 @@ Appends
|
||||||
.I path
|
.I path
|
||||||
to the load path list.
|
to the load path list.
|
||||||
.TP
|
.TP
|
||||||
.BI -D feature
|
|
||||||
Adds
|
|
||||||
.I feature
|
|
||||||
to the feature list, useful for cond-expanding different
|
|
||||||
library code.
|
|
||||||
.TP
|
|
||||||
.BI -m module
|
.BI -m module
|
||||||
.TP
|
.TP
|
||||||
.BI -x module
|
.BI -x module
|
||||||
|
@ -225,17 +205,13 @@ Loads the Scheme heap from
|
||||||
.I image-file
|
.I image-file
|
||||||
instead of compiling the init file on the fly.
|
instead of compiling the init file on the fly.
|
||||||
This feature is still experimental.
|
This feature is still experimental.
|
||||||
.TP
|
|
||||||
.BI -b
|
|
||||||
Makes stdio nonblocking (blocking by default). Only available when
|
|
||||||
lightweight threads are enabled.
|
|
||||||
|
|
||||||
.SH ENVIRONMENT
|
.SH ENVIRONMENT
|
||||||
.TP
|
.TP
|
||||||
.B CHIBI_MODULE_PATH
|
.B CHIBI_MODULE_PATH
|
||||||
A colon separated list of directories to search for module
|
A colon separated list of directories to search for module
|
||||||
files, inserted before the system default load paths. chibi-scheme
|
files, inserted before the system default load paths. chibi-scheme
|
||||||
searches for modules in directories in the following order:
|
searchs for modules in directories in the following order:
|
||||||
|
|
||||||
.TP
|
.TP
|
||||||
directories included with the -I path option
|
directories included with the -I path option
|
||||||
|
@ -246,14 +222,8 @@ searches for modules in directories in the following order:
|
||||||
.TP
|
.TP
|
||||||
directories included with -A path option
|
directories included with -A path option
|
||||||
|
|
||||||
If CHIBI_MODULE_PATH is unset, the directories "./lib", and "." are
|
If CHIBI_MODULE_PATH is unset, the directoriese "./lib", and "." are
|
||||||
searched in order. Set to empty to only consider -I, system
|
search in order.
|
||||||
directories and -A.
|
|
||||||
|
|
||||||
.TP
|
|
||||||
.B CHIBI_IGNORE_SYSTEM_PATH
|
|
||||||
If set to anything but "0", system directories (as listed above) are
|
|
||||||
not included in the search paths.
|
|
||||||
|
|
||||||
.SH AUTHORS
|
.SH AUTHORS
|
||||||
.PP
|
.PP
|
||||||
|
@ -261,9 +231,9 @@ Alex Shinn (alexshinn @ gmail . com)
|
||||||
|
|
||||||
.SH SEE ALSO
|
.SH SEE ALSO
|
||||||
.PP
|
.PP
|
||||||
More detailed information can be found in the manual included in
|
More detailed information can be found in the manuale included in
|
||||||
doc/chibi.scrbl included in the distribution.
|
doc/chibi.scrbl included in the distribution.
|
||||||
|
|
||||||
The chibi-scheme home-page:
|
The chibi-scheme home-page:
|
||||||
.br
|
.br
|
||||||
https://github.com/ashinn/chibi-scheme/
|
http://code.google.com/p/chibi-scheme/
|
||||||
|
|
310
doc/chibi.scrbl
310
doc/chibi.scrbl
|
@ -4,7 +4,7 @@
|
||||||
\author{Alex Shinn}
|
\author{Alex Shinn}
|
||||||
|
|
||||||
\centered{\smaller{Minimal Scheme Implementation for use as an Extension Language}}
|
\centered{\smaller{Minimal Scheme Implementation for use as an Extension Language}}
|
||||||
\centered{\url{https://github.com/ashinn/chibi-scheme}}
|
\centered{\url{http://synthcode.com/wiki/chibi-scheme}}
|
||||||
|
|
||||||
\section{Introduction}
|
\section{Introduction}
|
||||||
|
|
||||||
|
@ -28,8 +28,8 @@ standard modules. You can choose whichever layer suits your needs
|
||||||
best and customize the rest. Adding your own primitives or wrappers
|
best and customize the rest. Adding your own primitives or wrappers
|
||||||
around existing C libraries is easy with the C FFI.
|
around existing C libraries is easy with the C FFI.
|
||||||
|
|
||||||
Chibi is known to build and run on 32 and 64-bit Linux, OpenBSD, FreeBSD,
|
Chibi is known to build and run on 32 and 64-bit Linux, FreeBSD,
|
||||||
DragonFlyBSD, OS X, iOS, Windows (under Cygwin) and Plan9.
|
DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
|
||||||
|
|
||||||
\section{Installation}
|
\section{Installation}
|
||||||
|
|
||||||
|
@ -69,13 +69,6 @@ To compile a static executable, use
|
||||||
|
|
||||||
\command{make chibi-scheme-static SEXP_USE_DL=0}
|
\command{make chibi-scheme-static SEXP_USE_DL=0}
|
||||||
|
|
||||||
Note this static executable has none of the external binary libraries
|
|
||||||
included, which means among other things you can't load the
|
|
||||||
\scheme{(scheme base)} default language. You need to specify the
|
|
||||||
\scheme{(chibi)} or other Scheme-only language to run:
|
|
||||||
|
|
||||||
\command{./chibi-scheme-static -q}
|
|
||||||
|
|
||||||
To compile a static executable with all C libraries statically
|
To compile a static executable with all C libraries statically
|
||||||
included, first you need to create a clibs.c file, which can be done
|
included, first you need to create a clibs.c file, which can be done
|
||||||
with:
|
with:
|
||||||
|
@ -86,8 +79,7 @@ or edited manually. Be sure to run this with a non-static
|
||||||
chibi-scheme. Then you can make the static executable with:
|
chibi-scheme. Then you can make the static executable with:
|
||||||
|
|
||||||
\command{
|
\command{
|
||||||
make -B chibi-scheme-static SEXP_USE_DL=0 \
|
make -B chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS
|
||||||
CPPFLAGS="-DSEXP_USE_STATIC_LIBS -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0"
|
|
||||||
}
|
}
|
||||||
|
|
||||||
By default files are installed in /usr/local. You can optionally
|
By default files are installed in /usr/local. You can optionally
|
||||||
|
@ -120,7 +112,6 @@ are listed below.
|
||||||
\item{\ccode{SEXP_USE_RATIOS} - use exact ratios (enabled by default)}
|
\item{\ccode{SEXP_USE_RATIOS} - use exact ratios (enabled by default)}
|
||||||
\item{\ccode{SEXP_USE_COMPLEX} - use complex numbers (enabled by default)}
|
\item{\ccode{SEXP_USE_COMPLEX} - use complex numbers (enabled by default)}
|
||||||
\item{\ccode{SEXP_USE_UTF8_STRINGS} - Unicode support (enabled by default)}
|
\item{\ccode{SEXP_USE_UTF8_STRINGS} - Unicode support (enabled by default)}
|
||||||
\item{\ccode{SEXP_USE_STRING_INDEX_TABLE} - precompute offsets for O(1) \scheme{string-ref}}
|
|
||||||
\item{\ccode{SEXP_USE_NO_FEATURES} - disable almost all features}
|
\item{\ccode{SEXP_USE_NO_FEATURES} - disable almost all features}
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -136,8 +127,6 @@ documentation system described in
|
||||||
build this manual. \ccode{chibi-ffi} is a tool to build wrappers for
|
build this manual. \ccode{chibi-ffi} is a tool to build wrappers for
|
||||||
C libraries, described in the FFI section below.
|
C libraries, described in the FFI section below.
|
||||||
|
|
||||||
See the examples directory for some sample programs.
|
|
||||||
|
|
||||||
\section{Default Language}
|
\section{Default Language}
|
||||||
|
|
||||||
\subsection{Scheme Standard}
|
\subsection{Scheme Standard}
|
||||||
|
@ -148,10 +137,9 @@ superset of
|
||||||
\hyperlink["http://www.schemers.org/Documents/Standards/R5RS/HTML/"]{R5RS}.
|
\hyperlink["http://www.schemers.org/Documents/Standards/R5RS/HTML/"]{R5RS}.
|
||||||
|
|
||||||
The reader defaults to case-sensitive, like R6RS and R7RS but unlike
|
The reader defaults to case-sensitive, like R6RS and R7RS but unlike
|
||||||
R5RS. You can specify the -f option on the command-line to enable
|
R5RS. The default configuration includes the full numeric tower:
|
||||||
case-folding. The default configuration includes the full numeric
|
fixnums, flonums, bignums, exact rationals and complex numbers, though
|
||||||
tower: fixnums, flonums, bignums, exact rationals and complex numbers,
|
this can be customized at compile time.
|
||||||
though this can be customized at compile time.
|
|
||||||
|
|
||||||
Full continuations are supported, but currently continuations don't
|
Full continuations are supported, but currently continuations don't
|
||||||
take C code into account. This means that you can call from Scheme to
|
take C code into account. This means that you can call from Scheme to
|
||||||
|
@ -165,14 +153,13 @@ currently unspecified.
|
||||||
In R7RS (and R6RS) semantics it is impossible to use two macros from
|
In R7RS (and R6RS) semantics it is impossible to use two macros from
|
||||||
different modules which both use the same auxiliary keywords (like
|
different modules which both use the same auxiliary keywords (like
|
||||||
\scheme{else} in \scheme{cond} forms) without renaming one of the
|
\scheme{else} in \scheme{cond} forms) without renaming one of the
|
||||||
keywords. To minimize conflicts Chibi offers a special module named
|
keywords. By default Chibi considers all top-level bindings
|
||||||
\scheme{(auto)} which can export any identifier requested with
|
effectively unbound when matching auxiliary keywords, so this case
|
||||||
\scheme{only}, e.g. \scheme{(import (only (auto) foo))} will import
|
will "just work". This decision was made because the chance of
|
||||||
an auxiliary syntax \scheme{foo} binding. Separate modules can use
|
different modules using the same keywords seems more likely than user
|
||||||
this to get the same binding without needing to know about each other
|
code unintentionally matching a top-level keyword with a different
|
||||||
in advance. This is a Chibi-specific extension so is non-portable, but
|
binding, however if you want to use R7RS semantics you can compile
|
||||||
you can always define a static \scheme{(auto)} module exporting a list
|
with \ccode{SEXP_USE_STRICT_TOPLEVEL_BINDINGS=1}.
|
||||||
of all known bindings for other implementations.
|
|
||||||
|
|
||||||
\scheme{load} is extended to accept an optional environment argument, like
|
\scheme{load} is extended to accept an optional environment argument, like
|
||||||
\scheme{eval}. You can also \scheme{load} shared libraries in addition to
|
\scheme{eval}. You can also \scheme{load} shared libraries in addition to
|
||||||
|
@ -192,12 +179,11 @@ other languages.
|
||||||
|
|
||||||
\subsection{Module System}
|
\subsection{Module System}
|
||||||
|
|
||||||
Chibi supports the R7RS module system natively, which is a simple
|
Chibi uses the R7RS module system natively, which is a simple static
|
||||||
static module system. The Chibi implementation is actually a
|
module system in the style of the
|
||||||
hierarchy of languages in the style of the
|
\hyperlink["http://s48.org/"]{Scheme48} module system. As with most
|
||||||
\hyperlink["http://s48.org/"]{Scheme48} module system, allowing easy
|
features this is optional, and can be ignored or completely disabled
|
||||||
extension of the module system itself. As with most features this is
|
at compile time.
|
||||||
optional, and can be ignored or completely disabled at compile time.
|
|
||||||
|
|
||||||
Modules names are hierarchical lists of symbols or numbers. A module
|
Modules names are hierarchical lists of symbols or numbers. A module
|
||||||
definition uses the following form:
|
definition uses the following form:
|
||||||
|
@ -215,8 +201,7 @@ where \var{<library-declarations>} can be any of
|
||||||
(begin <expr> ...) ;; inline Scheme code
|
(begin <expr> ...) ;; inline Scheme code
|
||||||
(include <file> ...) ;; load one or more files
|
(include <file> ...) ;; load one or more files
|
||||||
(include-ci <file> ...) ;; as include, with case-folding
|
(include-ci <file> ...) ;; as include, with case-folding
|
||||||
(include-shared <file> ...) ;; dynamic load a library (non-R7RS)
|
(include-shared <file> ...) ;; dynamic load a library
|
||||||
(alias-for <library>) ;; a library alias (non-R7RS)
|
|
||||||
}
|
}
|
||||||
|
|
||||||
\var{<import-spec>} can either be a module name or any of
|
\var{<import-spec>} can either be a module name or any of
|
||||||
|
@ -225,23 +210,13 @@ where \var{<library-declarations>} can be any of
|
||||||
(only <import-spec> <id> ...)
|
(only <import-spec> <id> ...)
|
||||||
(except <import-spec> <id> ...)
|
(except <import-spec> <id> ...)
|
||||||
(rename <import-spec> (<from-id> <to-id>) ...)
|
(rename <import-spec> (<from-id> <to-id>) ...)
|
||||||
(prefix <import-spec> <prefix-id>)
|
(prefix <prefix-id> <import-spec>)
|
||||||
(drop-prefix <import-spec> <prefix-id>) ;; non-R7RS
|
|
||||||
}
|
}
|
||||||
|
|
||||||
These forms perform basic selection and renaming of individual
|
These forms perform basic selection and renaming of individual
|
||||||
identifiers from the given module. They may be composed to perform
|
identifiers from the given module. They may be composed to perform
|
||||||
combined selection and renaming.
|
combined selection and renaming.
|
||||||
|
|
||||||
Note while the repl provides default bindings as a convenience,
|
|
||||||
programs have strict semantics as in R7RS and must start with at least
|
|
||||||
one import, e.g.
|
|
||||||
|
|
||||||
\schemeblock{
|
|
||||||
(import (scheme base))
|
|
||||||
(write-string "Hello world!\n")
|
|
||||||
}
|
|
||||||
|
|
||||||
Some modules can be statically included in the initial configuration,
|
Some modules can be statically included in the initial configuration,
|
||||||
and even more may be included in image files, however in general
|
and even more may be included in image files, however in general
|
||||||
modules are searched for in a module load path. The definition of the
|
modules are searched for in a module load path. The definition of the
|
||||||
|
@ -250,7 +225,7 @@ module \scheme{(foo bar baz)} is searched for in the file
|
||||||
installed directories, \scheme{"."} and \scheme{"./lib"}. Additional
|
installed directories, \scheme{"."} and \scheme{"./lib"}. Additional
|
||||||
directories can be specified with the command-line options \ccode{-I}
|
directories can be specified with the command-line options \ccode{-I}
|
||||||
and \ccode{-A} (see the command-line options below) or with the
|
and \ccode{-A} (see the command-line options below) or with the
|
||||||
\scheme{add-module-directory} procedure at runtime. You can search for
|
\scheme{add-modue-directory} procedure at runtime. You can search for
|
||||||
a module file with \scheme{(find-module-file <file>)}, or load it with
|
a module file with \scheme{(find-module-file <file>)}, or load it with
|
||||||
\scheme{(load-module-file <file> <env>)}.
|
\scheme{(load-module-file <file> <env>)}.
|
||||||
|
|
||||||
|
@ -289,8 +264,8 @@ These are just syntactic sugar for the following more primitive type
|
||||||
constructors:
|
constructors:
|
||||||
|
|
||||||
\schemeblock{
|
\schemeblock{
|
||||||
(register-simple-type <name-string> <parent> <field-names>)
|
(register-simple-type <name-string> <parent> <num-fields>)
|
||||||
=> <type> ; parent may be #f, field-names should be a list of symbols
|
=> <type>
|
||||||
|
|
||||||
(make-type-predicate <opcode-name-string> <type>)
|
(make-type-predicate <opcode-name-string> <type>)
|
||||||
=> <opcode> ; takes 1 arg, returns #t iff that arg is of the type
|
=> <opcode> ; takes 1 arg, returns #t iff that arg is of the type
|
||||||
|
@ -303,38 +278,27 @@ constructors:
|
||||||
|
|
||||||
(make-setter <setter-name-string> <type> <field-index>)
|
(make-setter <setter-name-string> <type> <field-index>)
|
||||||
=> <opcode> ; takes 2 args, sets the field located at the index
|
=> <opcode> ; takes 2 args, sets the field located at the index
|
||||||
|
|
||||||
(type-slot-offset <type> <field-name>)
|
|
||||||
=> <index> ; returns the index of the field with the given name
|
|
||||||
}
|
}
|
||||||
|
|
||||||
\subsection{Unicode}
|
\subsection{Unicode}
|
||||||
|
|
||||||
Chibi supports Unicode strings and I/O natively. Case mappings and
|
Chibi supports Unicode strings, encoding them as utf8. This provides easy
|
||||||
comparisons, character properties, formatting and regular expressions
|
interoperability with many C libraries, but means that \scheme{string-ref} and
|
||||||
are all Unicode aware, supporting the latest version 13.0 of the
|
\scheme{string-set!} are O(n), so they should be avoided in
|
||||||
Unicode standard.
|
performance-sensitive code.
|
||||||
|
|
||||||
Internally strings are encoded as UTF-8. This provides easy
|
|
||||||
interoperability with many C libraries, but means that
|
|
||||||
\scheme{string-ref} and \scheme{string-set!} are O(n), so they should
|
|
||||||
be avoided in performance-sensitive code (unless you compile Chibi
|
|
||||||
with SEXP_USE_STRING_INDEX_TABLE).
|
|
||||||
|
|
||||||
In general you should use high-level APIs such as \scheme{string-map}
|
In general you should use high-level APIs such as \scheme{string-map}
|
||||||
to ensure fast string iteration. String ports also provide a simple
|
to ensure fast string iteration. String ports also provide a simple
|
||||||
and portable way to efficiently iterate and construct strings, by
|
way to efficiently iterate and construct strings, by looping over an
|
||||||
looping over an input string or accumulating characters in an output
|
input string or accumulating characters in an output string.
|
||||||
string.
|
|
||||||
|
|
||||||
The \scheme{in-string} and \scheme{in-string-reverse} iterators in the
|
The \scheme{in-string} and \scheme{in-string-reverse} iterators in the
|
||||||
\scheme{(chibi loop)} module will also iterate over strings
|
\scheme{(chibi loop)} module will also iterate over strings
|
||||||
efficiently while hiding the low-level details.
|
efficiently while hiding the low-level details.
|
||||||
|
|
||||||
In the event that you do need a low-level interface, such as when
|
In the event that you do need a low-level interface, such as when
|
||||||
writing your own iterator protocol, you should use string cursors.
|
writing your own iterator protocol, you should use the following
|
||||||
\scheme{(srfi 130)} provides a portable API for this, or you can use
|
string cursor API instead of indexes.
|
||||||
\scheme{(chibi string)} which builds on the following core procedures:
|
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
\item{\scheme{(string-cursor-start str)}
|
\item{\scheme{(string-cursor-start str)}
|
||||||
|
@ -370,10 +334,9 @@ To use Chibi-Scheme in a program you need to link against the
|
||||||
|
|
||||||
\ccode{#include <chibi/eval.h>}
|
\ccode{#include <chibi/eval.h>}
|
||||||
|
|
||||||
All definitions begin with a "sexp_" prefix, or "SEXP_" for constants
|
All definitions begin with a "sexp_" prefix, or "SEXP_" for constants.
|
||||||
(deliberately chosen not to conflict with other Scheme implementations
|
In addition to the prototypes and utility macros, this includes the
|
||||||
which typically use "scm_"). In addition to the prototypes and
|
following type definitions:
|
||||||
utility macros, this includes the following type definitions:
|
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
\item{\ctype{sexp} - an s-expression, used to represent all Scheme objects}
|
\item{\ctype{sexp} - an s-expression, used to represent all Scheme objects}
|
||||||
|
@ -407,10 +370,9 @@ void dostuff(sexp ctx) {
|
||||||
|
|
||||||
int main(int argc, char** argv) {
|
int main(int argc, char** argv) {
|
||||||
sexp ctx;
|
sexp ctx;
|
||||||
sexp_scheme_init();
|
|
||||||
ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
|
ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
|
||||||
sexp_load_standard_env(ctx, NULL, SEXP_SEVEN);
|
sexp_load_standard_env(ctx, NULL, SEXP_SEVEN);
|
||||||
sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 1);
|
sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 0);
|
||||||
dostuff(ctx);
|
dostuff(ctx);
|
||||||
sexp_destroy_context(ctx);
|
sexp_destroy_context(ctx);
|
||||||
}
|
}
|
||||||
|
@ -435,7 +397,7 @@ temporary values we may generate, which is what the
|
||||||
\cmacro{sexp_gc_var2}, \cmacro{sexp_gc_preserve2} and
|
\cmacro{sexp_gc_var2}, \cmacro{sexp_gc_preserve2} and
|
||||||
\cmacro{sexp_gc_release2} macros do (there are similar macros for
|
\cmacro{sexp_gc_release2} macros do (there are similar macros for
|
||||||
values 1-6). Precise GCs prevent a class of memory leaks (and
|
values 1-6). Precise GCs prevent a class of memory leaks (and
|
||||||
potential attacks based thereon), but if you prefer convenience then
|
potential attackes based thereon), but if you prefer convenience then
|
||||||
Chibi can be compiled with a conservative GC and you can ignore these.
|
Chibi can be compiled with a conservative GC and you can ignore these.
|
||||||
|
|
||||||
The interesting part is then the calls to \cfun{sexp_load},
|
The interesting part is then the calls to \cfun{sexp_load},
|
||||||
|
@ -476,11 +438,6 @@ using only the parent.
|
||||||
|
|
||||||
Otherwise, a new heap is allocated with \var{size} bytes, expandable to a
|
Otherwise, a new heap is allocated with \var{size} bytes, expandable to a
|
||||||
maximum of \var{max_size} bytes, using the system defaults if either is 0.
|
maximum of \var{max_size} bytes, using the system defaults if either is 0.
|
||||||
|
|
||||||
Note this context is not a malloced pointer (it resides inside a
|
|
||||||
malloced heap), and therefore can't be passed to \ccode{free()},
|
|
||||||
or stored in a C++ smart pointer. It can only be reclaimed with
|
|
||||||
\ccode{sexp_destroy_context}.
|
|
||||||
}}
|
}}
|
||||||
|
|
||||||
\item{\ccode{sexp_make_eval_context(sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size)}
|
\item{\ccode{sexp_make_eval_context(sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size)}
|
||||||
|
@ -512,8 +469,7 @@ the default context environment is used. Any of the \ctype{FILE*} may
|
||||||
be \cvar{NULL}, in which case the corresponding port is not set. If
|
be \cvar{NULL}, in which case the corresponding port is not set. If
|
||||||
\var{leave_open} is true, then the underlying \ctype{FILE*} is left
|
\var{leave_open} is true, then the underlying \ctype{FILE*} is left
|
||||||
open after the Scheme port is closed, otherwise they are both closed
|
open after the Scheme port is closed, otherwise they are both closed
|
||||||
together. If you want to reuse these streams from other vms, or from
|
together.
|
||||||
C, you should specify leave_open.
|
|
||||||
}}
|
}}
|
||||||
|
|
||||||
\item{\ccode{sexp_load(sexp ctx, sexp file, sexp env)}
|
\item{\ccode{sexp_load(sexp ctx, sexp file, sexp env)}
|
||||||
|
@ -557,11 +513,6 @@ Returns the current binding of \var{sym} in \var{env}, or \var{dflt} if there
|
||||||
is no binding.
|
is no binding.
|
||||||
}}
|
}}
|
||||||
|
|
||||||
\item{\ccode{sexp_env_import(sexp ctx, sexp to, sexp from, sexp ls, sexp immutp)}
|
|
||||||
\p{
|
|
||||||
Imports the bindings from environment \var{from} into environment \var{to}. \var{ls} is the list of bindings to import - if it is \scheme{#f} then import all bindings. If \var{immutp} is true the imported bindings are immutable and cannot be redefined.
|
|
||||||
}}
|
|
||||||
|
|
||||||
\item{\ccode{sexp_parameter_ref(sexp ctx, sexp param)}
|
\item{\ccode{sexp_parameter_ref(sexp ctx, sexp param)}
|
||||||
\p{
|
\p{
|
||||||
Returns the current dynamic value of the parameter \var{param} in the
|
Returns the current dynamic value of the parameter \var{param} in the
|
||||||
|
@ -666,15 +617,13 @@ sexp_release_object(ctx, obj)
|
||||||
|
|
||||||
Decrement the absolute reference count for \var{obj}.
|
Decrement the absolute reference count for \var{obj}.
|
||||||
|
|
||||||
\subsection{C API Index}
|
\subsection{API Index}
|
||||||
|
|
||||||
The above sections describe most everything you need for embedding in
|
The above sections describe most everything you need for embedding in
|
||||||
a typical application, notably creating environments and evaluating
|
a typical application, notably creating environments and evaluating
|
||||||
code from sexps, strings or files. The following sections expand on
|
code from sexps, strings or files. The following sections expand on
|
||||||
additional macros and utilities for inspecting, accessing and creating
|
additional macros and utilities for inspecting, accessing and creating
|
||||||
different Scheme types, and for performing port and string I/O. It is
|
different Scheme types, and for performing port and string I/O.
|
||||||
incomplete - see the macros and SEXP_API annotated functions in the
|
|
||||||
include files (sexp.h, eval.h, bignum.h) for more bindings.
|
|
||||||
|
|
||||||
Being able to convert from C string to sexp, evaluate it, and convert
|
Being able to convert from C string to sexp, evaluate it, and convert
|
||||||
the result back to a C string forms the basis of the C API. Because
|
the result back to a C string forms the basis of the C API. Because
|
||||||
|
@ -702,13 +651,10 @@ need to check manually before applying the predicate.
|
||||||
\item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer}
|
\item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer}
|
||||||
\item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real}
|
\item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real}
|
||||||
\item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer}
|
\item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer}
|
||||||
\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer (or flonum truncating without loss)}
|
\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer}
|
||||||
\item{\ccode{sexp_ratiop(obj)} - \var{obj} is an exact rational (with SEXP_USE_RATIOS)}
|
|
||||||
\item{\ccode{sexp_complexp(obj)} - \var{obj} is a complex number (with SEXP_USE_COMPLEX)}
|
|
||||||
\item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number}
|
\item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number}
|
||||||
\item{\ccode{sexp_charp(obj)} - \var{obj} is a character}
|
\item{\ccode{sexp_charp(obj)} - \var{obj} is a character}
|
||||||
\item{\ccode{sexp_stringp(obj)} - \var{obj} is a string}
|
\item{\ccode{sexp_stringp(obj)} - \var{obj} is a string}
|
||||||
\item{\ccode{sexp_string_cursorp(obj)} - \var{obj} is a string cursor}
|
|
||||||
\item{\ccode{sexp_bytesp(obj)} - \var{obj} is a bytevector}
|
\item{\ccode{sexp_bytesp(obj)} - \var{obj} is a bytevector}
|
||||||
\item{\ccode{sexp_symbolp(obj)} - \var{obj} is a symbol}
|
\item{\ccode{sexp_symbolp(obj)} - \var{obj} is a symbol}
|
||||||
\item{\ccode{sexp_idp(obj)} - \var{obj} is a symbol or hygienic identifier}
|
\item{\ccode{sexp_idp(obj)} - \var{obj} is a symbol or hygienic identifier}
|
||||||
|
@ -766,7 +712,7 @@ check. The runtime does not prevent embedded NULLs inside strings,
|
||||||
however data after the NULL may be ignored.
|
however data after the NULL may be ignored.
|
||||||
|
|
||||||
By default (unless you compile with -DSEXP_USE_UTF8_STRING=0), strings
|
By default (unless you compile with -DSEXP_USE_UTF8_STRING=0), strings
|
||||||
are interpreted as UTF-8 encoded on the Scheme side, as describe in
|
are interpreted as utf8 encoded on the Scheme side, as describe in
|
||||||
section Unicode above. In many cases you can ignore this on the C
|
section Unicode above. In many cases you can ignore this on the C
|
||||||
side and just treat the string as an opaque sequence of bytes.
|
side and just treat the string as an opaque sequence of bytes.
|
||||||
However, if you need to you can use the following macros to safely
|
However, if you need to you can use the following macros to safely
|
||||||
|
@ -784,7 +730,7 @@ compiled with:
|
||||||
\item{\ccode{sexp sexp_substring_cursor(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between raw offsets \var{i} and \var{j}}
|
\item{\ccode{sexp sexp_substring_cursor(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between raw offsets \var{i} and \var{j}}
|
||||||
]
|
]
|
||||||
|
|
||||||
When UTF-8 support is not compiled in the cursor and non-cursor
|
When UTF8 support is not compiled in the cursor and non-cursor
|
||||||
variants are equivalent.
|
variants are equivalent.
|
||||||
|
|
||||||
\subsubsection{Accessors}
|
\subsubsection{Accessors}
|
||||||
|
@ -800,12 +746,8 @@ once.
|
||||||
\item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise}
|
\item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise}
|
||||||
\item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}}
|
\item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}}
|
||||||
\item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer}
|
\item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer}
|
||||||
\item{\ccode{sexp_make_flonum(sexp ctx, float f)} - creates a new floating point value}
|
|
||||||
\item{\ccode{sexp_flonum_value(obj)} - converts a flonum to a C float}
|
|
||||||
\item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}}
|
\item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}}
|
||||||
\item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char}
|
\item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char}
|
||||||
\item{\ccode{sexp sexp_make_string_cursor(int offset)} - creates a string cursor for the given byte offset}
|
|
||||||
\item{\ccode{int sexp_unbox_string_cursor(sexp sc)} - returns the offset for the given string cursor}
|
|
||||||
\item{\ccode{sexp_car(pair)} - the car of \var{pair}}
|
\item{\ccode{sexp_car(pair)} - the car of \var{pair}}
|
||||||
\item{\ccode{sexp_cdr(pair)} - the cdr of \var{pair}}
|
\item{\ccode{sexp_cdr(pair)} - the cdr of \var{pair}}
|
||||||
\item{\ccode{sexp_ratio_numerator(q)} - the numerator of the ratio \var{q}}
|
\item{\ccode{sexp_ratio_numerator(q)} - the numerator of the ratio \var{q}}
|
||||||
|
@ -834,7 +776,6 @@ Any of these may fail and return the OOM exception object.
|
||||||
\item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}}
|
\item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}}
|
||||||
\item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)}
|
\item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)}
|
||||||
\item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements}
|
\item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements}
|
||||||
\item{\ccode{sexp_list3(sexp ctx, sexp obj1, sexp obj2, sexp obj3)} - create a list of three elements}
|
|
||||||
\item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}}
|
\item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}}
|
||||||
\item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).}
|
\item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).}
|
||||||
\item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).}
|
\item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).}
|
||||||
|
@ -850,6 +791,7 @@ Any of these may fail and return the OOM exception object.
|
||||||
\item{\ccode{sexp_read(sexp ctx, sexp in)} - read a single datum from port \var{in}}
|
\item{\ccode{sexp_read(sexp ctx, sexp in)} - read a single datum from port \var{in}}
|
||||||
\item{\ccode{sexp_write(sexp ctx, sexp obj, sexp out)} - write \var{obj} to port \var{out}}
|
\item{\ccode{sexp_write(sexp ctx, sexp obj, sexp out)} - write \var{obj} to port \var{out}}
|
||||||
\item{\ccode{sexp_write_string(sexp ctx, char* str, sexp out)} - write the characters in \var{str} to port \var{out}}
|
\item{\ccode{sexp_write_string(sexp ctx, char* str, sexp out)} - write the characters in \var{str} to port \var{out}}
|
||||||
|
\item{\ccode{sexp_display(sexp ctx, sexp obj, sexp out)} - display \var{obj} to port \var{out}}
|
||||||
\item{\ccode{sexp_newline(sexp ctx, sexp out)} - write a newline to port \var{out}}
|
\item{\ccode{sexp_newline(sexp ctx, sexp out)} - write a newline to port \var{out}}
|
||||||
\item{\ccode{sexp_print_exception(sexp ctx, sexp exn, sexp out)} - print an error message for \var{exn} to port \var{out}}
|
\item{\ccode{sexp_print_exception(sexp ctx, sexp exn, sexp out)} - print an error message for \var{exn} to port \var{out}}
|
||||||
\item{\ccode{sexp_current_input_port(sexp ctx)} - the \scheme{current-input-port}}
|
\item{\ccode{sexp_current_input_port(sexp ctx)} - the \scheme{current-input-port}}
|
||||||
|
@ -860,7 +802,7 @@ Any of these may fail and return the OOM exception object.
|
||||||
\item{\ccode{sexp_write_to_string(sexp ctx, sexp obj)} - return a Scheme string representation of \var{obj}}
|
\item{\ccode{sexp_write_to_string(sexp ctx, sexp obj)} - return a Scheme string representation of \var{obj}}
|
||||||
\item{\ccode{sexp_open_input_string(sexp ctx, sexp str)} - equivalent to \scheme{open-input-string}}
|
\item{\ccode{sexp_open_input_string(sexp ctx, sexp str)} - equivalent to \scheme{open-input-string}}
|
||||||
\item{\ccode{sexp_open_output_string(sexp ctx)} - equivalent to \scheme{open-output-string}}
|
\item{\ccode{sexp_open_output_string(sexp ctx)} - equivalent to \scheme{open-output-string}}
|
||||||
\item{\ccode{sexp_get_output_string(sexp ctx, sexp port)} - equivalent to \scheme{get-output-string}}
|
\item{\ccode{sexp_get_output_string(sexp ctx, sexp port)} - equivalent to \scheme{open-output-string}}
|
||||||
]
|
]
|
||||||
|
|
||||||
\subsubsection{Utilities}
|
\subsubsection{Utilities}
|
||||||
|
@ -873,7 +815,7 @@ Any of these may fail and return the OOM exception object.
|
||||||
\item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}}
|
\item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}}
|
||||||
\item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}}
|
\item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}}
|
||||||
\item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}}
|
\item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}}
|
||||||
\item{\ccode{sexp_append2(sexp ctx, sexp ls1, sexp ls2)} - \scheme{append} for two arguments}
|
\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \scheme{append} for two arguments}
|
||||||
\item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}}
|
\item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}}
|
||||||
\item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}}
|
\item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}}
|
||||||
\item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}}
|
\item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}}
|
||||||
|
@ -953,39 +895,6 @@ to any inherited from the parent type \var{parent}. If \var{parent} is false,
|
||||||
inherits from the default \var{object} record type.
|
inherits from the default \var{object} record type.
|
||||||
}}
|
}}
|
||||||
|
|
||||||
\item{\ccode{sexp sexp_register_c_type(sexp ctx, sexp name, sexp finalizer)}
|
|
||||||
\p{
|
|
||||||
Shortcut to defines a new type as a wrapper around a C pointer.
|
|
||||||
Returns the type object, which can be used with sexp_make_cpointer to
|
|
||||||
wrap instances of the type. The finalizer may be sexp_finalize_c_type
|
|
||||||
in which case managed pointers are freed as if allocated with malloc,
|
|
||||||
NULL in which case the pointers are never freed, or otherwise a
|
|
||||||
procedure of one argument which should release any resources.
|
|
||||||
}}
|
|
||||||
|
|
||||||
\item{\ccode{sexp sexp_make_cpointer(sexp ctx, sexp_uint_t type_tag, void* value, sexp parent, int freep)}
|
|
||||||
\p{
|
|
||||||
Creates a new instance of the type indicated by type_tag wrapping
|
|
||||||
value. If parent is provided, references to the child will also
|
|
||||||
preserve the parent, important e.g. to preserve an enclosing struct
|
|
||||||
when wrapped references to nested structs are still in use. If freep
|
|
||||||
is true, then when reclaimed by the GC the finalizer for this type,
|
|
||||||
if any, will be called on the instance.
|
|
||||||
|
|
||||||
You can retrieve the tag from a type object with sexp_type_tag(type).
|
|
||||||
}}
|
|
||||||
|
|
||||||
\item{\ccode{sexp sexp_lookup_type(sexp ctx, sexp name, sexp tag_or_id)}
|
|
||||||
\p{
|
|
||||||
Returns the type whose name matches the string \var{name}. If
|
|
||||||
\var{tag_or_id} is an integer, it is taken as the tag and requires the
|
|
||||||
numeric type tag (as from sexp_type_tag) to also match.
|
|
||||||
}
|
|
||||||
\p{If \var{tag_or_id} is a string, it is taken as the unique id of the
|
|
||||||
type, and must match sexp_type_id(type). However, currently
|
|
||||||
sexp_type_id(type) is never set.
|
|
||||||
}}
|
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
See the C FFI for an easy way to automate adding bindings for C
|
See the C FFI for an easy way to automate adding bindings for C
|
||||||
|
@ -1248,8 +1157,7 @@ A number of SRFIs are provided in the default installation. Note that
|
||||||
SRFIs 0, 6, 23, 46 and 62 are built into the default environment so
|
SRFIs 0, 6, 23, 46 and 62 are built into the default environment so
|
||||||
there's no need to import them. SRFI 22 is available with the "-r"
|
there's no need to import them. SRFI 22 is available with the "-r"
|
||||||
command-line option. This list includes popular SRFIs or SRFIs used
|
command-line option. This list includes popular SRFIs or SRFIs used
|
||||||
in standard Chibi modules (many other SRFIs are available on
|
in standard Chibi modules
|
||||||
snow-fort):
|
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
|
|
||||||
|
@ -1260,7 +1168,6 @@ snow-fort):
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-8/srfi-8.html"]{(srfi 8) - receive}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-8/srfi-8.html"]{(srfi 8) - receive}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{(srfi 9) - define-record-type}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{(srfi 9) - define-record-type}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-11/srfi-11.html"]{(srfi 11) - let-values/let*-values}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-11/srfi-11.html"]{(srfi 11) - let-values/let*-values}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-14/srfi-14.html"]{(srfi 14) - character-set library}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-16/srfi-16.html"]{(srfi 16) - case-lambda}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-16/srfi-16.html"]{(srfi 16) - case-lambda}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-18/srfi-18.html"]{(srfi 18) - multi-threading support}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-18/srfi-18.html"]{(srfi 18) - multi-threading support}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-22/srfi-22.html"]{(srfi 22) - running scheme scripts on Unix}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-22/srfi-22.html"]{(srfi 22) - running scheme scripts on Unix}}
|
||||||
|
@ -1270,53 +1177,13 @@ snow-fort):
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-33/srfi-33.html"]{(srfi 33) - bitwise operators}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-33/srfi-33.html"]{(srfi 33) - bitwise operators}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-38/srfi-38.html"]{(srfi 38) - read/write shared structures}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-38/srfi-38.html"]{(srfi 38) - read/write shared structures}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-39/srfi-39.html"]{(srfi 39) - parameter objects}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-39/srfi-39.html"]{(srfi 39) - parameter objects}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-41/srfi-41.html"]{(srfi 41) - streams}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-46/srfi-46.html"]{(srfi 46) - basic syntax-rules extensions}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-46/srfi-46.html"]{(srfi 46) - basic syntax-rules extensions}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-55/srfi-55.html"]{(srfi 55) - require-extension}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-55/srfi-55.html"]{(srfi 55) - require-extension}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-62/srfi-62.html"]{(srfi 62) - s-expression comments}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-62/srfi-62.html"]{(srfi 62) - s-expression comments}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-64/srfi-64.html"]{(srfi 64) - a scheme API for test suites}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-69/srfi-69.html"]{(srfi 69) - basic hash tables}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-69/srfi-69.html"]{(srfi 69) - basic hash tables}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-95/srfi-95.html"]{(srfi 95) - sorting and merging}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-95/srfi-95.html"]{(srfi 95) - sorting and merging}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-98/srfi-98.html"]{(srfi 98) - environment access}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-98/srfi-98.html"]{(srfi 98) - environment access}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{(srfi 99) - ERR5RS records}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{(srfi 99) - ERR5RS records}}
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-101/srfi-101.html"]{(srfi 101) - purely functional random-access pairs and lists}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-111/srfi-111.html"]{(srfi 111) - boxes}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-113/srfi-113.html"]{(srfi 113) - sets and bags}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-115/srfi-115.html"]{(srfi 115) - Scheme regular expressions}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-116/srfi-116.html"]{(srfi 116) - immutable list library}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-117/srfi-117.html"]{(srfi 117) - mutable queues}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-121/srfi-121.html"]{(srfi 121) - generators}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-124/srfi-124.html"]{(srfi 124) - ephemerons}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-125/srfi-125.html"]{(srfi 125) - intermediate hash tables}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-127/srfi-127.html"]{(srfi 127) - lazy sequences}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-128/srfi-128.html"]{(srfi 128) - comparators (reduced)}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-129/srfi-129.html"]{(srfi 129) - titlecase procedures}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-130/srfi-130.html"]{(srfi 130) - cursor-based string library}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-132/srfi-132.html"]{(srfi 132) - sort libraries}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-133/srfi-133.html"]{(srfi 133) - vector library}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-134/srfi-134.html"]{(srfi 134) - immutable deques}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-135/srfi-135.html"]{(srfi 135) - immutable texts}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-139/srfi-139.html"]{(srfi 139) - syntax parameters}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-141/srfi-141.html"]{(srfi 141) - integer division}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-142.html"]{(srfi 142) - bitwise operations}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-143.html"]{(srfi 143) - fixnums}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-144/srfi-144.html"]{(srfi 144) - flonums}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-145/srfi-145.html"]{(srfi 145) - assumptions}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-147/srfi-147.html"]{(srfi 147) - custom macro transformers}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-151/srfi-151.html"]{(srfi 151) - bitwise operators}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-154/srfi-154.html"]{(srfi 154) - first-class dynamic extents}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-158/srfi-158.html"]{(srfi 158) - generators and accumulators}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-160/srfi-160.html"]{(srfi 160) - homogeneous numeric vector libraries}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-165/srfi-165.html"]{(srfi 165) - the environment Monad}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-166.html"]{(srfi 166) - monadic formatting}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-179/srfi-179.html"]{(srfi 179) - nonempty intervals and generalized arrays}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-188/srfi-188.html"]{(srfi 188) - splicing binding constructs for syntactic keywords}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-193/srfi-193.html"]{(srfi 193) - command-line}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-211/srfi-211.html"]{(srfi 211) - scheme macro libaries}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-219/srfi-219.html"]{(srfi 219) - define higher-order lambda}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-227/srfi-227.html"]{(srfi 227) - optional arguments}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-229/srfi-229.html"]{(srfi 229) - tagged procedures}}
|
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-231/srfi-231.html"]{(srfi 231) - intervals and generalized arrays}}
|
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -1329,30 +1196,10 @@ namespace.
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}}
|
\item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/assert.html"]{(chibi assert) - A nicer assert macro}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/base64.html"]{(chibi base64) - Base64 encoding and decoding}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/binary-record.html"]{(chibi binary-record) - Record types with binary serialization}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/bytevector.html"]{(chibi bytevector) - Bytevector Utilities}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/config.html"]{(chibi config) - General configuration management}}
|
\item{\hyperlink["lib/chibi/config.html"]{(chibi config) - General configuration management}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/crypto/md5.html"]{(chibi crypto md5) - MD5 hash}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/crypto/rsa.html"]{(chibi crypto rsa) - RSA public key encryption}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/crypto/sha2.html"]{(chibi crypto sha2) - SHA-2 hash}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/diff.html"]{(chibi diff) - LCS Algorithm and diff utilities}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/disasm.html"]{(chibi disasm) - Disassembler for the virtual machine}}
|
\item{\hyperlink["lib/chibi/disasm.html"]{(chibi disasm) - Disassembler for the virtual machine}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/doc.html"]{(chibi doc) - Chibi documentation utilities}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/edit-distance.html"]{(chibi edit-distance) - A levenshtein distance implementation}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/equiv.html"]{(chibi equiv) - A version of \scheme{equal?} which is guaranteed to terminate}}
|
\item{\hyperlink["lib/chibi/equiv.html"]{(chibi equiv) - A version of \scheme{equal?} which is guaranteed to terminate}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/filesystem.html"]{(chibi filesystem) - Interface to the filesystem and file descriptor objects}}
|
\item{\hyperlink["lib/chibi/filesystem.html"]{(chibi filesystem) - Interface to the filesystem and file descriptor objects}}
|
||||||
|
@ -1363,36 +1210,16 @@ namespace.
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/io.html"]{(chibi io) - Various I/O extensions and custom ports}}
|
\item{\hyperlink["lib/chibi/io.html"]{(chibi io) - Various I/O extensions and custom ports}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/iset/base.html"]{(chibi iset base) - Compact integer sets}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/iset/base.html"]{(chibi iset base) - Compact integer sets}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/iset/constructors.html"]{(chibi iset constructors) - Compact integer set construction}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/iset/iterators.html"]{(chibi iset iterators) - Iterating over compact integer sets}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/json.html"]{(chibi json) - JSON reading and writing}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/loop.html"]{(chibi loop) - Fast and extensible loop syntax}}
|
\item{\hyperlink["lib/chibi/loop.html"]{(chibi loop) - Fast and extensible loop syntax}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/match.html"]{(chibi match) - Intuitive and widely supported pattern matching syntax}}
|
\item{\hyperlink["lib/chibi/match.html"]{(chibi match) - Intuitive and widely supported pattern matching syntax}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/math/prime.html"]{(chibi math prime) - Prime number utilities}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/memoize.html"]{(chibi memoize) - Procedure memoization}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/mime.html"]{(chibi mime) - Parse MIME files into SXML}}
|
\item{\hyperlink["lib/chibi/mime.html"]{(chibi mime) - Parse MIME files into SXML}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/modules.html"]{(chibi modules) - Introspection for the module system itself}}
|
\item{\hyperlink["lib/chibi/modules.html"]{(chibi modules) - Introspection for the module system itself}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/net.html"]{(chibi net) - Simple networking interface}}
|
\item{\hyperlink["lib/chibi/net.html"]{(chibi net) - Simple networking interface}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/net/http-server.html"]{(chibi net http-server) - Simple http-server with servlet support}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/net/servlet.html"]{(chibi net servlet) - HTTP servlets for http-server or CGI}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/optional.html"]{(chibi optional) - Syntax to support optional and named keyword arguments}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/parse.html"]{(chibi parse) - Parser combinators with convenient syntax}}
|
\item{\hyperlink["lib/chibi/parse.html"]{(chibi parse) - Parser combinators with convenient syntax}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}}
|
\item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}}
|
||||||
|
@ -1401,22 +1228,16 @@ namespace.
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/repl.html"]{(chibi repl) - A full-featured Read/Eval/Print Loop}}
|
\item{\hyperlink["lib/chibi/repl.html"]{(chibi repl) - A full-featured Read/Eval/Print Loop}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/shell.html"]{(chibi shell) - Process combinators with high-level pipeline syntax in the spirit of SCSH.}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formatting.}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}}
|
\item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/string.html"]{(chibi string) - Cursor-based string library (predecessor to SRFI 130)}}
|
\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - A combinator formatting library}}
|
||||||
|
|
||||||
|
\item{\hyperlink["lib/chibi/show/base.scm"]{(chibi show base) - Base combinator formatting}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/stty.html"]{(chibi stty) - A high-level interface to ioctl}}
|
\item{\hyperlink["lib/chibi/stty.html"]{(chibi stty) - A high-level interface to ioctl}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/sxml.html"]{(chibi sxml) - SXML utilities}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/system.html"]{(chibi system) - Access to the host system and current user information}}
|
\item{\hyperlink["lib/chibi/system.html"]{(chibi system) - Access to the host system and current user information}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/temp-file.html"]{(chibi temp-file) - Temporary file and directory creation}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/test.html"]{(chibi test) - A simple unit testing framework}}
|
\item{\hyperlink["lib/chibi/test.html"]{(chibi test) - A simple unit testing framework}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/time.html"]{(chibi time) - An interface to the current system time}}
|
\item{\hyperlink["lib/chibi/time.html"]{(chibi time) - An interface to the current system time}}
|
||||||
|
@ -1434,23 +1255,17 @@ namespace.
|
||||||
\section{Snow Package Manager}
|
\section{Snow Package Manager}
|
||||||
|
|
||||||
Beyond the distributed modules, Chibi comes with a package manager
|
Beyond the distributed modules, Chibi comes with a package manager
|
||||||
based on \hyperlink["https://small.r7rs.org/wiki/Snow/"]{Snow2}
|
based on \hyperlink["http://trac.sacrideo.us/wg/wiki/Snow"]{Snow2}
|
||||||
which can be used to share R7RS libraries. Packages are distributed
|
which can be used to share R7RS libraries. Packages are distributed
|
||||||
as tar gzipped files called "snowballs," and may contain multiple
|
as tar gzipped files called "snowballs," and may contain multiple
|
||||||
libraries. The program is installed as \scheme{snow-chibi}. The
|
libraries. The program is installed as \scheme{snow-chibi} and takes
|
||||||
"help" subcommand can be used to list all subcommands and options.
|
the following subcommands:
|
||||||
Note by default \scheme{snow-chibi} uses an image file to speed-up
|
|
||||||
loading (since it loads many libraries) - if you have any difficulties
|
|
||||||
with image files on your platform you can run
|
|
||||||
\command{snow-chibi --noimage} to disable this feature.
|
|
||||||
|
|
||||||
\subsubsection{Querying Packages and Status}
|
\subsubsection{Querying Packages and Status}
|
||||||
|
|
||||||
By default \scheme{snow-chibi} looks for packages in the public
|
By default \scheme{snow-chibi} looks for packages in the public
|
||||||
repository \hyperlink["http://snow-fort.org/"]{http://snow-fort.org/},
|
repository \hyperlink["http://snow-fort.org/"]{http://snow-fort.org/},
|
||||||
though you can customize this with the \scheme{--repository-uri} or
|
though you can customize this with the \scheme{--repository-uri} option.
|
||||||
\scheme{--repo} option (e.g. "http://snow-fort.org/s/repo.scm").
|
|
||||||
|
|
||||||
Packages can be browsed on the site, but you can also search and query
|
Packages can be browsed on the site, but you can also search and query
|
||||||
from the command-line tool.
|
from the command-line tool.
|
||||||
|
|
||||||
|
@ -1482,11 +1297,6 @@ older version, a warning is printed.}}
|
||||||
The basic package management functionality, installing upgrading and
|
The basic package management functionality, installing upgrading and
|
||||||
removing packages.
|
removing packages.
|
||||||
|
|
||||||
By default the packages will be managed for Chibi. You can specify
|
|
||||||
what Scheme implementation to install, upgrade... with
|
|
||||||
\scheme{--implementations} or \scheme{--impls} option. Specify "all"
|
|
||||||
to manage all supported implementations.
|
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
|
|
||||||
\item{install names ... - install packages
|
\item{install names ... - install packages
|
||||||
|
@ -1495,10 +1305,8 @@ use the dotted shorthand. Explicit names for packages are optional,
|
||||||
as a package can always be referred to by the name of any library it
|
as a package can always be referred to by the name of any library it
|
||||||
contains. If multiple packages provide libraries with the same name,
|
contains. If multiple packages provide libraries with the same name,
|
||||||
you will be asked to confirm which implementation to install.}
|
you will be asked to confirm which implementation to install.}
|
||||||
|
|
||||||
\p{You can also bypass the repository and install a manually downloaded
|
\p{You can also bypass the repository and install a manually downloaded
|
||||||
snowball by giving a path to that file instead of a name. No package
|
snowball by giving a path to that file instead of a name.}}
|
||||||
dependencies will be checked for install in this case}}
|
|
||||||
|
|
||||||
\item{upgrade names ... - upgrade installed packages
|
\item{upgrade names ... - upgrade installed packages
|
||||||
\p{Upgrade the packages if new versions are available.
|
\p{Upgrade the packages if new versions are available.
|
||||||
|
@ -1520,10 +1328,6 @@ update with this command.}}
|
||||||
Creating packages can be done with the \scheme{package} command,
|
Creating packages can be done with the \scheme{package} command,
|
||||||
though other commands allow for uploading to public repositories.
|
though other commands allow for uploading to public repositories.
|
||||||
|
|
||||||
By default the public repository is
|
|
||||||
\hyperlink["http://snow-fort.org/"]{http://snow-fort.org/} but you can
|
|
||||||
customize this with the \scheme{--host} option.
|
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
|
|
||||||
\item{package files ... - create a package
|
\item{package files ... - create a package
|
||||||
|
@ -1621,12 +1425,10 @@ command tells you which you currently have installed. The following
|
||||||
are currently supported:
|
are currently supported:
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
\item{chibi - version >= 0.7.3}
|
\item{chibi - native support as of version 0.7.3}
|
||||||
\item{chicken - version >= 4.9.0 with the \scheme{r7rs} egg}
|
\item{chicken - version >= 4.9.0 with the \scheme{r7rs} egg}
|
||||||
\item{cyclone - version >= 0.5.3}
|
|
||||||
\item{foment - version >= 0.4}
|
\item{foment - version >= 0.4}
|
||||||
\item{gauche - version >= 0.9.4}
|
\item{gauche - version >= 0.9.4}
|
||||||
\item{kawa - version >= 2.0; you need to add the install dir to the search path, e.g. \scheme{-Dkawa.import.path=/usr/local/share/kawa}}
|
\item{kawa - version >= 2.0; you need to add the install dir to the search path, e.g. \scheme{-Dkawa.import.path=/usr/local/share/kawa}}
|
||||||
\item{larceny - version 0.98; you need to add "lib/Snow" to the paths in startup.sch}
|
\item{larceny - version 0.98; you need to add "lib/Snow" to the paths in startup.sch}
|
||||||
\item{sagittarius - version >= 0.98}
|
|
||||||
]
|
]
|
||||||
|
|
|
@ -1,3 +0,0 @@
|
||||||
(import (scheme base))
|
|
||||||
|
|
||||||
(write-string "Hello world!\n")
|
|
|
@ -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)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -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))))))))
|
|
416
gc.c
416
gc.c
|
@ -6,14 +6,16 @@
|
||||||
|
|
||||||
#include "chibi/sexp.h"
|
#include "chibi/sexp.h"
|
||||||
|
|
||||||
#if SEXP_USE_TIME_GC
|
|
||||||
#include <sys/resource.h>
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#if SEXP_USE_MMAP_GC
|
#if SEXP_USE_MMAP_GC
|
||||||
#include <sys/mman.h>
|
#include <sys/mman.h>
|
||||||
#endif
|
#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_BANNER(x) ("**************** GC "x"\n")
|
||||||
|
|
||||||
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(1))
|
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(1))
|
||||||
|
@ -37,52 +39,14 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
|
||||||
return h;
|
return h;
|
||||||
}
|
}
|
||||||
|
|
||||||
#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS && !SEXP_USE_MALLOC
|
|
||||||
static size_t sexp_heap_total_size (sexp_heap h) {
|
static size_t sexp_heap_total_size (sexp_heap h) {
|
||||||
size_t total_size = 0;
|
size_t total_size = 0;
|
||||||
for (; h; h=h->next)
|
for (; h; h=h->next)
|
||||||
total_size += h->size;
|
total_size += h->size;
|
||||||
return total_size;
|
return total_size;
|
||||||
}
|
}
|
||||||
#endif
|
|
||||||
|
|
||||||
#if ! SEXP_USE_GLOBAL_HEAP
|
#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) {
|
void sexp_free_heap (sexp_heap heap) {
|
||||||
#if SEXP_USE_MMAP_GC
|
#if SEXP_USE_MMAP_GC
|
||||||
munmap(heap, sexp_heap_pad_size(heap->size));
|
munmap(heap, sexp_heap_pad_size(heap->size));
|
||||||
|
@ -128,7 +92,7 @@ void sexp_release_object(sexp ctx, sexp x) {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
SEXP_API sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
|
sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
|
||||||
sexp_uint_t res;
|
sexp_uint_t res;
|
||||||
sexp t;
|
sexp t;
|
||||||
if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
|
if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
|
||||||
|
@ -137,7 +101,7 @@ SEXP_API sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
|
||||||
res = sexp_type_size_of_object(t, x) + SEXP_GC_PAD;
|
res = sexp_type_size_of_object(t, x) + SEXP_GC_PAD;
|
||||||
#if SEXP_USE_DEBUG_GC
|
#if SEXP_USE_DEBUG_GC
|
||||||
if (res == 0) {
|
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;
|
return 1;
|
||||||
}
|
}
|
||||||
#endif
|
#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)
|
return sexp_in_heap_p(ctx, x) && sexp_valid_object_type_p(ctx, x)
|
||||||
&& sexp_valid_header_magic_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
|
#endif
|
||||||
|
|
||||||
static void sexp_mark_stack_push (sexp ctx, sexp *start, sexp *end) {
|
void sexp_mark (sexp ctx, sexp x) {
|
||||||
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) {
|
|
||||||
sexp_sint_t len;
|
sexp_sint_t len;
|
||||||
sexp t, *p, *q;
|
sexp t, *p, *q;
|
||||||
struct sexp_gc_var_t *saves;
|
struct sexp_gc_var_t *saves;
|
||||||
|
@ -263,44 +196,24 @@ static void sexp_mark_one (sexp ctx, sexp* types, sexp x) {
|
||||||
sexp_markedp(x) = 1;
|
sexp_markedp(x) = 1;
|
||||||
if (sexp_contextp(x)) {
|
if (sexp_contextp(x)) {
|
||||||
for (saves=sexp_context_saves(x); saves; saves=saves->next)
|
for (saves=sexp_context_saves(x); saves; saves=saves->next)
|
||||||
if (saves->var) sexp_mark_one(ctx, types, *(saves->var));
|
if (saves->var) sexp_mark(ctx, *(saves->var));
|
||||||
}
|
}
|
||||||
t = types[sexp_pointer_tag(x)];
|
t = sexp_object_type(ctx, x);
|
||||||
len = sexp_type_num_slots_of_object(t, x) - 1;
|
len = sexp_type_num_slots_of_object(t, x) - 1;
|
||||||
if (len >= 0) {
|
if (len >= 0) {
|
||||||
p = (sexp*) (((char*)x) + sexp_type_field_base(t));
|
p = (sexp*) (((char*)x) + sexp_type_field_base(t));
|
||||||
q = p + len;
|
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 */
|
q--; /* skip trailing immediates */
|
||||||
while (p < q && *q == q[-1])
|
while (p < q && *q == q[-1])
|
||||||
q--; /* skip trailing duplicates */
|
q--; /* skip trailing duplicates */
|
||||||
if (p < q) {
|
while (p < q)
|
||||||
sexp_mark_stack_push(ctx, p, q);
|
sexp_mark(ctx, *p++);
|
||||||
}
|
x = *p;
|
||||||
x = *q;
|
|
||||||
goto loop;
|
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
|
#if SEXP_USE_CONSERVATIVE_GC
|
||||||
|
|
||||||
int stack_references_pointer_p (sexp ctx, sexp x) {
|
int stack_references_pointer_p (sexp ctx, sexp x) {
|
||||||
|
@ -364,16 +277,12 @@ void sexp_conservative_mark (sexp ctx) {
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if SEXP_USE_WEAK_REFERENCES
|
#if SEXP_USE_WEAK_REFERENCES
|
||||||
int sexp_reset_weak_references(sexp ctx) {
|
void sexp_reset_weak_references(sexp ctx) {
|
||||||
int i, len, broke, all_reset_p;
|
int i, len, all_reset_p;
|
||||||
sexp_heap h;
|
sexp_heap h = sexp_context_heap(ctx);
|
||||||
sexp p, t, end, *v;
|
sexp p, t, end, *v;
|
||||||
sexp_free_list q, r;
|
sexp_free_list q, r;
|
||||||
if (sexp_not(sexp_global(ctx, SEXP_G_WEAK_OBJECTS_PRESENT)))
|
for ( ; h; h=h->next) { /* just scan the whole heap */
|
||||||
return 0;
|
|
||||||
broke = 0;
|
|
||||||
/* just scan the whole heap */
|
|
||||||
for (h = sexp_context_heap(ctx) ; h; h=h->next) {
|
|
||||||
p = sexp_heap_first_block(h);
|
p = sexp_heap_first_block(h);
|
||||||
q = h->free_list;
|
q = h->free_list;
|
||||||
end = sexp_heap_end(h);
|
end = sexp_heap_end(h);
|
||||||
|
@ -400,7 +309,6 @@ int sexp_reset_weak_references(sexp ctx) {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
if (all_reset_p) { /* ephemerons */
|
if (all_reset_p) { /* ephemerons */
|
||||||
broke++;
|
|
||||||
len += sexp_type_weak_len_extra(t);
|
len += sexp_type_weak_len_extra(t);
|
||||||
for ( ; i<len; i++) v[i] = SEXP_FALSE;
|
for ( ; i<len; i++) v[i] = SEXP_FALSE;
|
||||||
}
|
}
|
||||||
|
@ -409,14 +317,11 @@ int sexp_reset_weak_references(sexp ctx) {
|
||||||
p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
|
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
|
#else
|
||||||
#define sexp_reset_weak_references(ctx) 0
|
#define sexp_reset_weak_references(ctx)
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if SEXP_USE_FINALIZERS
|
|
||||||
sexp sexp_finalize (sexp ctx) {
|
sexp sexp_finalize (sexp ctx) {
|
||||||
size_t size;
|
size_t size;
|
||||||
sexp p, t, end;
|
sexp p, t, end;
|
||||||
|
@ -442,9 +347,6 @@ sexp sexp_finalize (sexp ctx) {
|
||||||
continue;
|
continue;
|
||||||
}
|
}
|
||||||
size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
|
size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
|
||||||
if (size == 0) {
|
|
||||||
return SEXP_FALSE;
|
|
||||||
}
|
|
||||||
if (!sexp_markedp(p)) {
|
if (!sexp_markedp(p)) {
|
||||||
t = sexp_object_type(ctx, p);
|
t = sexp_object_type(ctx, p);
|
||||||
finalizer = sexp_type_finalize(t);
|
finalizer = sexp_type_finalize(t);
|
||||||
|
@ -466,7 +368,6 @@ sexp sexp_finalize (sexp ctx) {
|
||||||
#endif
|
#endif
|
||||||
return sexp_make_fixnum(finalize_count);
|
return sexp_make_fixnum(finalize_count);
|
||||||
}
|
}
|
||||||
#endif
|
|
||||||
|
|
||||||
sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
|
sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
|
||||||
size_t freed, max_freed=0, sum_freed=0, size;
|
size_t freed, max_freed=0, sum_freed=0, size;
|
||||||
|
@ -487,7 +388,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
|
||||||
continue;
|
continue;
|
||||||
}
|
}
|
||||||
size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
|
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))
|
if (!sexp_valid_object_p(ctx, p))
|
||||||
fprintf(stderr, SEXP_BANNER("%p sweep: invalid object at %p"), ctx, p);
|
fprintf(stderr, SEXP_BANNER("%p sweep: invalid object at %p"), ctx, p);
|
||||||
if ((char*)q + q->size > (char*)p)
|
if ((char*)q + q->size > (char*)p)
|
||||||
|
@ -552,29 +453,17 @@ void sexp_mark_global_symbols(sexp ctx) {
|
||||||
|
|
||||||
sexp sexp_gc (sexp ctx, size_t *sum_freed) {
|
sexp sexp_gc (sexp ctx, size_t *sum_freed) {
|
||||||
sexp res, finalized SEXP_NO_WARN_UNUSED;
|
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_debug_printf("%p (heap: %p size: %lu)", ctx, sexp_context_heap(ctx),
|
||||||
sexp_heap_total_size(sexp_context_heap(ctx)));
|
sexp_heap_total_size(sexp_context_heap(ctx)));
|
||||||
#endif
|
|
||||||
sexp_mark_global_symbols(ctx);
|
sexp_mark_global_symbols(ctx);
|
||||||
sexp_mark(ctx, ctx);
|
sexp_mark(ctx, ctx);
|
||||||
sexp_conservative_mark(ctx);
|
sexp_conservative_mark(ctx);
|
||||||
sexp_reset_weak_references(ctx);
|
sexp_reset_weak_references(ctx);
|
||||||
finalized = sexp_finalize(ctx);
|
finalized = sexp_finalize(ctx);
|
||||||
res = sexp_sweep(ctx, sum_freed);
|
res = sexp_sweep(ctx, sum_freed);
|
||||||
++sexp_context_gc_count(ctx);
|
sexp_debug_printf("%p (freed: %lu max_freed: %lu finalized: %lu)", ctx,
|
||||||
#if SEXP_USE_TIME_GC
|
(sum_freed ? *sum_freed : 0), sexp_unbox_fixnum(res),
|
||||||
getrusage(RUSAGE_SELF, &end);
|
sexp_unbox_fixnum(finalized));
|
||||||
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
|
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -582,13 +471,12 @@ sexp_heap sexp_make_heap (size_t size, size_t max_size, size_t chunk_size) {
|
||||||
sexp_free_list free, next;
|
sexp_free_list free, next;
|
||||||
sexp_heap h;
|
sexp_heap h;
|
||||||
#if SEXP_USE_MMAP_GC
|
#if SEXP_USE_MMAP_GC
|
||||||
h = mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE,
|
h = mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE|PROT_EXEC,
|
||||||
MAP_ANON|MAP_PRIVATE, -1, 0);
|
MAP_ANON|MAP_PRIVATE, 0, 0);
|
||||||
if (h == MAP_FAILED) return NULL;
|
|
||||||
#else
|
#else
|
||||||
h = sexp_malloc(sexp_heap_pad_size(size));
|
h = sexp_malloc(sexp_heap_pad_size(size));
|
||||||
if (! h) return NULL;
|
|
||||||
#endif
|
#endif
|
||||||
|
if (! h) return NULL;
|
||||||
h->size = size;
|
h->size = size;
|
||||||
h->max_size = max_size;
|
h->max_size = max_size;
|
||||||
h->chunk_size = chunk_size;
|
h->chunk_size = chunk_size;
|
||||||
|
@ -613,46 +501,24 @@ sexp_heap sexp_make_heap (size_t size, size_t max_size, size_t chunk_size) {
|
||||||
|
|
||||||
int sexp_grow_heap (sexp ctx, size_t size, size_t chunk_size) {
|
int sexp_grow_heap (sexp ctx, size_t size, size_t chunk_size) {
|
||||||
size_t cur_size, new_size;
|
size_t cur_size, new_size;
|
||||||
sexp_heap tmp, h = sexp_heap_last(sexp_context_heap(ctx));
|
sexp_heap 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
|
|
||||||
cur_size = h->size;
|
cur_size = h->size;
|
||||||
new_size = (size_t) ceil(SEXP_GROW_HEAP_FACTOR * (double) (sexp_heap_align(((cur_size > size) ? cur_size : size))));
|
new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
|
||||||
tmp = sexp_make_heap(new_size, h->max_size, chunk_size);
|
h->next = sexp_make_heap(new_size, h->max_size, chunk_size);
|
||||||
if (tmp) {
|
|
||||||
tmp->next = h->next;
|
|
||||||
h->next = tmp;
|
|
||||||
}
|
|
||||||
return (h->next != NULL);
|
return (h->next != NULL);
|
||||||
}
|
}
|
||||||
|
|
||||||
void* sexp_try_alloc (sexp ctx, size_t size) {
|
void* sexp_try_alloc (sexp ctx, size_t size) {
|
||||||
sexp_free_list ls1, ls2, ls3;
|
sexp_free_list ls1, ls2, ls3;
|
||||||
sexp_heap h;
|
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) {
|
for (h=sexp_context_heap(ctx); h; h=h->next) {
|
||||||
#if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
|
#if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
|
||||||
if (h->chunk_size) {
|
if (h->chunk_size && h->chunk_size != size)
|
||||||
if (h->chunk_size != size)
|
|
||||||
continue;
|
continue;
|
||||||
found_fixed = 1;
|
|
||||||
} else if (found_fixed) { /* don't use a non-fixed heap */
|
|
||||||
return NULL;
|
|
||||||
}
|
|
||||||
#endif
|
#endif
|
||||||
for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) {
|
for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) {
|
||||||
if (ls2->size >= size) {
|
if (ls2->size >= size) {
|
||||||
#if SEXP_USE_DEBUG_GC > 1
|
#if SEXP_USE_DEBUG_GC
|
||||||
ls3 = (sexp_free_list) sexp_heap_end(h);
|
ls3 = (sexp_free_list) sexp_heap_end(h);
|
||||||
if (ls2 >= ls3)
|
if (ls2 >= ls3)
|
||||||
fprintf(stderr, "alloced %lu bytes past end of heap: %p (%lu) >= %p"
|
fprintf(stderr, "alloced %lu bytes past end of heap: %p (%lu) >= %p"
|
||||||
|
@ -675,53 +541,15 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
|
||||||
return NULL;
|
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* sexp_alloc (sexp ctx, size_t size) {
|
||||||
void *res;
|
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);
|
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;
|
size = sexp_heap_align(size) + SEXP_GC_PAD;
|
||||||
#if SEXP_USE_TRACK_ALLOC_SIZES
|
|
||||||
size_bucket = (size - SEXP_GC_PAD) / sexp_heap_align(1) - 1;
|
|
||||||
++sexp_context_alloc_histogram(ctx)[size_bucket >= SEXP_ALLOC_HISTOGRAM_BUCKETS ? SEXP_ALLOC_HISTOGRAM_BUCKETS-1 : size_bucket];
|
|
||||||
#endif
|
|
||||||
res = sexp_try_alloc(ctx, size);
|
res = sexp_try_alloc(ctx, size);
|
||||||
if (! res) {
|
if (! res) {
|
||||||
max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed));
|
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));
|
total_size = sexp_heap_total_size(sexp_context_heap(ctx));
|
||||||
#endif
|
|
||||||
if (((max_freed < size)
|
if (((max_freed < size)
|
||||||
|| ((total_size > sum_freed)
|
|| ((total_size > sum_freed)
|
||||||
&& (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO)))
|
&& (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO)))
|
||||||
|
@ -733,17 +561,177 @@ void* sexp_alloc (sexp ctx, size_t size) {
|
||||||
sexp_debug_printf("ran out of memory allocating %lu bytes => %p", size, res);
|
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;
|
return res;
|
||||||
}
|
}
|
||||||
#endif
|
|
||||||
|
|
||||||
|
#if ! SEXP_USE_GLOBAL_HEAP
|
||||||
|
|
||||||
|
void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags) {
|
||||||
|
sexp_sint_t i, off, len, freep, loadp;
|
||||||
|
sexp_free_list q;
|
||||||
|
sexp p, t, end, *v;
|
||||||
|
#if SEXP_USE_DL
|
||||||
|
sexp name;
|
||||||
|
#endif
|
||||||
|
freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP);
|
||||||
|
loadp = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_LOADP);
|
||||||
|
|
||||||
|
off = (sexp_sint_t)((sexp_sint_t)heap - (sexp_sint_t)from_heap);
|
||||||
|
heap->data += off;
|
||||||
|
end = (sexp) (heap->data + heap->size);
|
||||||
|
|
||||||
|
/* adjust the free list */
|
||||||
|
heap->free_list = (sexp_free_list) ((char*)heap->free_list + off);
|
||||||
|
for (q=heap->free_list; q->next; q=q->next)
|
||||||
|
q->next = (sexp_free_list) ((char*)q->next + off);
|
||||||
|
|
||||||
|
/* adjust data by traversing over the new heap */
|
||||||
|
p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
|
||||||
|
q = heap->free_list;
|
||||||
|
while (p < end) {
|
||||||
|
/* find the next free list pointer */
|
||||||
|
for ( ; q && ((char*)q < (char*)p); q=q->next)
|
||||||
|
;
|
||||||
|
if ((char*)q == (char*)p) { /* this is a free block, skip it */
|
||||||
|
p = (sexp) (((char*)p) + q->size);
|
||||||
|
} else {
|
||||||
|
t = (sexp)((char*)(types[sexp_pointer_tag(p)])
|
||||||
|
+ ((char*)types > (char*)p ? off : 0));
|
||||||
|
len = sexp_type_num_slots_of_object(t, p);
|
||||||
|
v = (sexp*) ((char*)p + sexp_type_field_base(t));
|
||||||
|
/* offset any pointers in the _destination_ heap */
|
||||||
|
for (i=0; i<len; i++)
|
||||||
|
if (v[i] && sexp_pointerp(v[i]))
|
||||||
|
v[i] = (sexp) ((char*)v[i] + off);
|
||||||
|
/* don't free unless specified - only the original cleans up */
|
||||||
|
if (! freep)
|
||||||
|
sexp_freep(p) = 0;
|
||||||
|
/* adjust context heaps, don't copy saved sexp_gc_vars */
|
||||||
|
if (sexp_contextp(p)) {
|
||||||
|
#if SEXP_USE_GREEN_THREADS
|
||||||
|
sexp_context_ip(p) += off;
|
||||||
|
#endif
|
||||||
|
sexp_context_last_fp(p) += off;
|
||||||
|
sexp_stack_top(sexp_context_stack(p)) = 0;
|
||||||
|
sexp_context_saves(p) = NULL;
|
||||||
|
sexp_context_heap(p) = heap;
|
||||||
|
} else if (sexp_bytecodep(p) && off != 0) {
|
||||||
|
for (i=0; i<sexp_bytecode_length(p); ) {
|
||||||
|
switch (sexp_bytecode_data(p)[i++]) {
|
||||||
|
case SEXP_OP_FCALL0: case SEXP_OP_FCALL1:
|
||||||
|
case SEXP_OP_FCALL2: case SEXP_OP_FCALL3:
|
||||||
|
case SEXP_OP_FCALL4: case SEXP_OP_CALL:
|
||||||
|
case SEXP_OP_TAIL_CALL: case SEXP_OP_PUSH:
|
||||||
|
case SEXP_OP_GLOBAL_REF: case SEXP_OP_GLOBAL_KNOWN_REF:
|
||||||
|
#if SEXP_USE_GREEN_THREADS
|
||||||
|
case SEXP_OP_PARAMETER_REF:
|
||||||
|
#endif
|
||||||
|
#if SEXP_USE_EXTENDED_FCALL
|
||||||
|
case SEXP_OP_FCALLN:
|
||||||
|
#endif
|
||||||
|
v = (sexp*)(&(sexp_bytecode_data(p)[i]));
|
||||||
|
if (v[0] && sexp_pointerp(v[0])) v[0] = (sexp) (((char*)v[0]) + off);
|
||||||
|
/* ... FALLTHROUGH ... */
|
||||||
|
case SEXP_OP_JUMP: case SEXP_OP_JUMP_UNLESS:
|
||||||
|
case SEXP_OP_STACK_REF: case SEXP_OP_CLOSURE_REF:
|
||||||
|
case SEXP_OP_LOCAL_REF: case SEXP_OP_LOCAL_SET:
|
||||||
|
case SEXP_OP_TYPEP:
|
||||||
|
#if SEXP_USE_RESERVE_OPCODE
|
||||||
|
case SEXP_OP_RESERVE:
|
||||||
|
#endif
|
||||||
|
i += sizeof(sexp); break;
|
||||||
|
case SEXP_OP_MAKE: case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_SET:
|
||||||
|
i += 2*sizeof(sexp); break;
|
||||||
|
case SEXP_OP_MAKE_PROCEDURE:
|
||||||
|
v = (sexp*)(&(sexp_bytecode_data(p)[i]));
|
||||||
|
if (v[2] && sexp_pointerp(v[2])) v[2] = (sexp) (((char*)v[2]) + off);
|
||||||
|
i += 3*sizeof(sexp); break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} else if (sexp_portp(p) && sexp_port_stream(p)) {
|
||||||
|
sexp_port_stream(p) = 0;
|
||||||
|
sexp_port_openp(p) = 0;
|
||||||
|
sexp_freep(p) = 0;
|
||||||
|
#if SEXP_USE_DL
|
||||||
|
} else if (loadp && sexp_dlp(p)) {
|
||||||
|
sexp_dl_handle(p) = NULL;
|
||||||
|
#endif
|
||||||
|
}
|
||||||
|
p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p))+SEXP_GC_PAD);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/* make a second pass to fix code references */
|
||||||
|
if (loadp) {
|
||||||
|
p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
|
||||||
|
q = heap->free_list;
|
||||||
|
while (p < end) {
|
||||||
|
/* find the next free list pointer */
|
||||||
|
for ( ; q && ((char*)q < (char*)p); q=q->next)
|
||||||
|
;
|
||||||
|
if ((char*)q == (char*)p) { /* this is a free block, skip it */
|
||||||
|
p = (sexp) (((char*)p) + q->size);
|
||||||
|
} else {
|
||||||
|
#if SEXP_USE_DL
|
||||||
|
if (sexp_opcodep(p) && sexp_opcode_func(p)) {
|
||||||
|
name = (sexp_opcode_data2(p) && sexp_stringp(sexp_opcode_data2(p))) ? sexp_opcode_data2(p) : sexp_opcode_name(p);
|
||||||
|
if (sexp_dlp(sexp_opcode_dl(p))) {
|
||||||
|
if (!sexp_dl_handle(sexp_opcode_dl(p)))
|
||||||
|
sexp_dl_handle(sexp_opcode_dl(p)) = dlopen(sexp_string_data(sexp_dl_file(sexp_opcode_dl(p))), RTLD_LAZY);
|
||||||
|
sexp_opcode_func(p) = dlsym(sexp_dl_handle(sexp_opcode_dl(p)), sexp_string_data(name));
|
||||||
|
} else {
|
||||||
|
sexp_opcode_func(p) = dlsym(SEXP_RTLD_DEFAULT, sexp_string_data(name));
|
||||||
|
}
|
||||||
|
} else
|
||||||
|
#endif
|
||||||
|
if (sexp_typep(p)) {
|
||||||
|
if (sexp_type_finalize(p)) {
|
||||||
|
/* TODO: handle arbitrary finalizers in images */
|
||||||
|
#if SEXP_USE_DL
|
||||||
|
if (sexp_type_tag(p) == SEXP_DL)
|
||||||
|
sexp_type_finalize(p) = SEXP_FINALIZE_DL;
|
||||||
|
else
|
||||||
|
#endif
|
||||||
|
sexp_type_finalize(p) = SEXP_FINALIZE_PORT;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
t = types[sexp_pointer_tag(p)];
|
||||||
|
p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)+SEXP_GC_PAD));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
|
||||||
|
sexp_sint_t off;
|
||||||
|
sexp_heap to, from = sexp_context_heap(ctx);
|
||||||
|
|
||||||
|
/* validate input, creating a new heap if needed */
|
||||||
|
if (from->next) {
|
||||||
|
return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx);
|
||||||
|
} else if (! dst || sexp_not(dst)) {
|
||||||
|
to = sexp_make_heap(from->size, from->max_size, from->chunk_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) {
|
void sexp_gc_init (void) {
|
||||||
#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC
|
#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC
|
||||||
|
@ -758,4 +746,4 @@ void sexp_gc_init (void) {
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
||||||
#endif /* ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC */
|
#endif
|
||||||
|
|
789
gc_heap.c
789
gc_heap.c
|
@ -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 */
|
|
|
@ -1,5 +1,5 @@
|
||||||
/* bignum.h -- header for bignum utilities */
|
/* bignum.h -- header for bignum utilities */
|
||||||
/* Copyright (c) 2009-2020 Alex Shinn. All rights reserved. */
|
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
||||||
/* BSD-style license: http://synthcode.com/license.txt */
|
/* BSD-style license: http://synthcode.com/license.txt */
|
||||||
|
|
||||||
#ifndef SEXP_BIGNUM_H
|
#ifndef SEXP_BIGNUM_H
|
||||||
|
@ -7,23 +7,7 @@
|
||||||
|
|
||||||
#include "chibi/eval.h"
|
#include "chibi/eval.h"
|
||||||
|
|
||||||
#if SEXP_USE_CUSTOM_LONG_LONGS
|
#if (SEXP_64_BIT) && defined(__GNUC__)
|
||||||
#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
|
|
||||||
typedef unsigned int uint128_t __attribute__((mode(TI)));
|
typedef unsigned int uint128_t __attribute__((mode(TI)));
|
||||||
typedef int sint128_t __attribute__((mode(TI)));
|
typedef int sint128_t __attribute__((mode(TI)));
|
||||||
typedef uint128_t sexp_luint_t;
|
typedef uint128_t sexp_luint_t;
|
||||||
|
@ -33,364 +17,6 @@ typedef unsigned long long sexp_luint_t;
|
||||||
typedef long long sexp_lsint_t;
|
typedef long long sexp_lsint_t;
|
||||||
#endif
|
#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_sint_t sexp_bignum_compare (sexp a, sexp b);
|
||||||
SEXP_API sexp sexp_compare (sexp ctx, 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);
|
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 sexp sexp_fixnum_to_bignum (sexp ctx, sexp a);
|
||||||
SEXP_API double sexp_bignum_to_double (sexp a);
|
SEXP_API double sexp_bignum_to_double (sexp a);
|
||||||
SEXP_API sexp sexp_double_to_bignum (sexp ctx, double f);
|
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_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 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_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);
|
SEXP_API sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b);
|
||||||
|
@ -419,8 +43,7 @@ SEXP_API sexp sexp_quotient (sexp ctx, sexp a, sexp b);
|
||||||
SEXP_API sexp sexp_remainder (sexp ctx, sexp a, sexp b);
|
SEXP_API sexp sexp_remainder (sexp ctx, sexp a, sexp b);
|
||||||
#if SEXP_USE_RATIOS
|
#if SEXP_USE_RATIOS
|
||||||
SEXP_API sexp sexp_double_to_ratio (sexp ctx, double f);
|
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 rat);
|
||||||
SEXP_API double sexp_ratio_to_double (sexp ctx, sexp rat);
|
|
||||||
SEXP_API sexp sexp_make_ratio (sexp ctx, sexp num, sexp den);
|
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_normalize (sexp ctx, sexp rat, sexp in);
|
||||||
SEXP_API sexp sexp_ratio_round (sexp ctx, sexp a);
|
SEXP_API sexp sexp_ratio_round (sexp ctx, sexp a);
|
||||||
|
|
|
@ -46,6 +46,8 @@ enum sexp_opcode_classes {
|
||||||
SEXP_OPC_NUM_OP_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
|
#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
|
||||||
SEXP_API const char** sexp_opcode_names;
|
SEXP_API const char** sexp_opcode_names;
|
||||||
#endif
|
#endif
|
||||||
|
@ -74,7 +76,7 @@ SEXP_API void sexp_bless_bytecode (sexp ctx, sexp bc);
|
||||||
#endif
|
#endif
|
||||||
SEXP_API sexp sexp_complete_bytecode (sexp ctx);
|
SEXP_API sexp sexp_complete_bytecode (sexp ctx);
|
||||||
SEXP_API void sexp_shrink_bcode (sexp ctx, sexp_uint_t i);
|
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 void sexp_stack_trace (sexp ctx, sexp out);
|
||||||
SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
|
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 ctx, sexp lambda, sexp name);
|
||||||
|
@ -92,7 +94,6 @@ SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n,
|
||||||
SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value);
|
SEXP_API 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_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 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_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_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_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
|
||||||
|
@ -128,15 +129,13 @@ SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from
|
||||||
SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
|
SEXP_API sexp sexp_make_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_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_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_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
|
||||||
SEXP_API sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
|
|
||||||
SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
|
SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
|
||||||
#if SEXP_USE_AUTO_FORCE
|
#if SEXP_USE_AUTO_FORCE
|
||||||
SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
|
SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
|
||||||
#endif
|
#endif
|
||||||
#if SEXP_USE_UTF8_STRINGS
|
#if SEXP_USE_UTF8_STRINGS
|
||||||
SEXP_API sexp sexp_read_utf8_char (sexp ctx, sexp port, int i);
|
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 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_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);
|
SEXP_API sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch);
|
||||||
|
@ -190,13 +189,10 @@ SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
|
||||||
SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
|
SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
|
||||||
#endif
|
#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)
|
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_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p)
|
|
||||||
#define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p)
|
|
||||||
#define sexp_define_foreign_proc(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_NONE,(const char*)#f,(sexp_proc1)f,NULL)
|
|
||||||
#define sexp_define_foreign_proc_rest(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_VARIADIC,(const char*)#f,(sexp_proc1)f,NULL)
|
|
||||||
|
|
||||||
#define sexp_env_key(x) sexp_car(x)
|
#define sexp_env_key(x) sexp_car(x)
|
||||||
#define sexp_env_value(x) sexp_cdr(x)
|
#define sexp_env_value(x) sexp_cdr(x)
|
||||||
|
@ -240,7 +236,6 @@ SEXP_API sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sex
|
||||||
SEXP_API sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req);
|
SEXP_API sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req);
|
||||||
#else
|
#else
|
||||||
SEXP_API sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port);
|
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
|
#endif
|
||||||
|
|
||||||
#if SEXP_USE_SIMPLIFY
|
#if SEXP_USE_SIMPLIFY
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
/* features.h -- general feature configuration */
|
/* features.h -- general feature configuration */
|
||||||
/* Copyright (c) 2009-2021 Alex Shinn. All rights reserved. */
|
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
||||||
/* BSD-style license: http://synthcode.com/license.txt */
|
/* BSD-style license: http://synthcode.com/license.txt */
|
||||||
|
|
||||||
/* uncomment this to disable most features */
|
/* uncomment this to disable most features */
|
||||||
|
@ -23,27 +23,16 @@
|
||||||
/* sexp_init_library(ctx, env) function provided. */
|
/* sexp_init_library(ctx, env) function provided. */
|
||||||
/* #define SEXP_USE_DL 0 */
|
/* #define SEXP_USE_DL 0 */
|
||||||
|
|
||||||
/* uncomment this to support statically compiled C libs */
|
/* uncomment this to statically compile all C libs */
|
||||||
/* Unless SEXP_USE_STATIC_LIBS_EMPTY is set (see below), this */
|
/* If set, this will statically include the clibs.c file */
|
||||||
/* will statically include the clibs.c file into the standard */
|
/* into the standard environment, so that you can have */
|
||||||
/* environment, so that you can have access to a predefined set */
|
/* access to a predefined set of C libraries without */
|
||||||
/* of C libraries without needing dynamic loading. The clibs.c */
|
/* needing dynamic loading. The clibs.c file is generated */
|
||||||
/* file is generated automatically by searching the lib directory */
|
/* automatically by searching the lib directory for */
|
||||||
/* for modules with include-shared, but can be hand-tailored to */
|
/* modules with include-shared, but can be hand-tailored */
|
||||||
/* your needs. You can also register your own C libraries using */
|
/* to your needs. */
|
||||||
/* sexp_add_static_libraries (see below). */
|
|
||||||
/* #define SEXP_USE_STATIC_LIBS 1 */
|
/* #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 */
|
/* uncomment this to disable detailed source info for debugging */
|
||||||
/* By default Chibi will associate source info with every */
|
/* By default Chibi will associate source info with every */
|
||||||
/* bytecode offset. By disabling this only lambda-level source */
|
/* bytecode offset. By disabling this only lambda-level source */
|
||||||
|
@ -75,15 +64,6 @@
|
||||||
/* if you suspect a bug in the native GC. */
|
/* if you suspect a bug in the native GC. */
|
||||||
/* #define SEXP_USE_BOEHM 1 */
|
/* #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 */
|
/* uncomment this to disable weak references */
|
||||||
/* #define SEXP_USE_WEAK_REFERENCES 0 */
|
/* #define SEXP_USE_WEAK_REFERENCES 0 */
|
||||||
|
|
||||||
|
@ -104,11 +84,6 @@
|
||||||
/* go away and you're not working on your own C extension. */
|
/* go away and you're not working on your own C extension. */
|
||||||
/* #define SEXP_USE_CONSERVATIVE_GC 1 */
|
/* #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 */
|
/* uncomment this to add additional native checks to only mark objects in the heap */
|
||||||
/* #define SEXP_USE_SAFE_GC_MARK 1 */
|
/* #define SEXP_USE_SAFE_GC_MARK 1 */
|
||||||
|
|
||||||
|
@ -125,9 +100,6 @@
|
||||||
/* uncomment this to add very verbose debugging stats to the native GC */
|
/* uncomment this to add very verbose debugging stats to the native GC */
|
||||||
/* #define SEXP_USE_DEBUG_GC 1 */
|
/* #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 */
|
/* uncomment this to enable "safe" field accessors for primitive types */
|
||||||
/* The sexp union type fields are abstracted away with macros of the */
|
/* The sexp union type fields are abstracted away with macros of the */
|
||||||
/* form sexp_<type>_<field>(<obj>), however these are just convenience */
|
/* form sexp_<type>_<field>(<obj>), however these are just convenience */
|
||||||
|
@ -188,27 +160,11 @@
|
||||||
/* uncomment this if you don't want 1## style approximate digits */
|
/* uncomment this if you don't want 1## style approximate digits */
|
||||||
/* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */
|
/* #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 */
|
/* uncomment this if you don't need extended math operations */
|
||||||
/* This includes the trigonometric and expt functions. */
|
/* This includes the trigonometric and expt functions. */
|
||||||
/* Automatically disabled if you've disabled flonums. */
|
/* Automatically disabled if you've disabled flonums. */
|
||||||
/* #define SEXP_USE_MATH 0 */
|
/* #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 */
|
/* uncomment this to disable warning about references to undefined variables */
|
||||||
/* This is something of a hack, but can be quite useful. */
|
/* This is something of a hack, but can be quite useful. */
|
||||||
/* It's very fast and doesn't involve any separate analysis */
|
/* It's very fast and doesn't involve any separate analysis */
|
||||||
|
@ -231,11 +187,6 @@
|
||||||
/* uncomment this to disable extended char names as defined in R7RS */
|
/* uncomment this to disable extended char names as defined in R7RS */
|
||||||
/* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */
|
/* #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 */
|
/* uncomment this to disable UTF-8 string support */
|
||||||
/* The default settings store strings in memory as UTF-8, */
|
/* The default settings store strings in memory as UTF-8, */
|
||||||
/* and assumes strings passed to/from the C FFI are UTF-8. */
|
/* and assumes strings passed to/from the C FFI are UTF-8. */
|
||||||
|
@ -246,32 +197,10 @@
|
||||||
/* Making them immutable allows for packed UTF-8 strings. */
|
/* Making them immutable allows for packed UTF-8 strings. */
|
||||||
/* #define SEXP_USE_MUTABLE_STRINGS 0 */
|
/* #define SEXP_USE_MUTABLE_STRINGS 0 */
|
||||||
|
|
||||||
/* uncomment this to enable precomputed index->cursor tables for strings */
|
/* uncomment this to base string ports on C streams */
|
||||||
/* This makes string-ref faster at the expensive of making string */
|
/* This historic option enables string and custom ports backed */
|
||||||
/* construction (including string-append and I/O) slower. */
|
/* by FILE* objects using memstreams and funopen/fopencookie. */
|
||||||
/* You can configure with SEXP_STRING_INDEX_TABLE_CHUNK_SIZE below, */
|
/* #define SEXP_USE_STRING_STREAMS 1 */
|
||||||
/* 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 disable automatic closing of ports */
|
/* uncomment this to disable automatic closing of ports */
|
||||||
/* If enabled, the underlying FILE* for file ports will be */
|
/* If enabled, the underlying FILE* for file ports will be */
|
||||||
|
@ -301,7 +230,7 @@
|
||||||
|
|
||||||
/* uncomment this to make the VM adhere to alignment rules */
|
/* uncomment this to make the VM adhere to alignment rules */
|
||||||
/* This is required on some platforms, e.g. ARM */
|
/* 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 */
|
/* These settings are configurable but only recommended for */
|
||||||
|
@ -327,15 +256,6 @@
|
||||||
#define SEXP_GROW_HEAP_RATIO 0.75
|
#define SEXP_GROW_HEAP_RATIO 0.75
|
||||||
#endif
|
#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 */
|
/* the default number of opcodes to run each thread for */
|
||||||
#ifndef SEXP_DEFAULT_QUANTUM
|
#ifndef SEXP_DEFAULT_QUANTUM
|
||||||
#define SEXP_DEFAULT_QUANTUM 500
|
#define SEXP_DEFAULT_QUANTUM 500
|
||||||
|
@ -345,21 +265,12 @@
|
||||||
#define SEXP_MAX_ANALYZE_DEPTH 8192
|
#define SEXP_MAX_ANALYZE_DEPTH 8192
|
||||||
#endif
|
#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 */
|
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
|
||||||
/************************************************************************/
|
/************************************************************************/
|
||||||
|
|
||||||
#ifndef SEXP_64_BIT
|
#ifndef SEXP_64_BIT
|
||||||
#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) || defined(__mips64__) || defined(__sparc64__) || defined(__arm64)
|
#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__)
|
||||||
#define SEXP_64_BIT 1
|
#define SEXP_64_BIT 1
|
||||||
#else
|
#else
|
||||||
#define SEXP_64_BIT 0
|
#define SEXP_64_BIT 0
|
||||||
|
@ -375,51 +286,6 @@
|
||||||
#endif
|
#endif
|
||||||
#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
|
#ifndef SEXP_USE_NO_FEATURES
|
||||||
#define SEXP_USE_NO_FEATURES 0
|
#define SEXP_USE_NO_FEATURES 0
|
||||||
#endif
|
#endif
|
||||||
|
@ -428,19 +294,9 @@
|
||||||
#define SEXP_USE_PEDANTIC 0
|
#define SEXP_USE_PEDANTIC 0
|
||||||
#endif
|
#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
|
#ifndef SEXP_USE_GREEN_THREADS
|
||||||
#if defined(_WIN32)
|
|
||||||
#define SEXP_USE_GREEN_THREADS 0
|
|
||||||
#else
|
|
||||||
#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES
|
#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES
|
||||||
#endif
|
#endif
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_DEBUG_THREADS
|
#ifndef SEXP_USE_DEBUG_THREADS
|
||||||
#define SEXP_USE_DEBUG_THREADS 0
|
#define SEXP_USE_DEBUG_THREADS 0
|
||||||
|
@ -471,28 +327,20 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_DL
|
#ifndef SEXP_USE_DL
|
||||||
#if defined(PLAN9)
|
#if defined(PLAN9) || defined(_WIN32)
|
||||||
#define SEXP_USE_DL 0
|
#define SEXP_USE_DL 0
|
||||||
#else
|
#else
|
||||||
#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
|
#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
|
||||||
#endif
|
#endif
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_STATIC_LIBS_EMPTY
|
|
||||||
#define SEXP_USE_STATIC_LIBS_EMPTY 0
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_STATIC_LIBS
|
#ifndef SEXP_USE_STATIC_LIBS
|
||||||
#define SEXP_USE_STATIC_LIBS SEXP_USE_STATIC_LIBS_EMPTY
|
#define SEXP_USE_STATIC_LIBS 0
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
/* don't include clibs.c - include separately or link */
|
/* don't include clibs.c - include separately or link */
|
||||||
#ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
|
#ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
|
||||||
#if defined(PLAN9) || SEXP_USE_STATIC_LIBS_EMPTY
|
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE defined(PLAN9)
|
||||||
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 0
|
|
||||||
#else
|
|
||||||
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 1
|
|
||||||
#endif
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_FULL_SOURCE_INFO
|
#ifndef SEXP_USE_FULL_SOURCE_INFO
|
||||||
|
@ -507,17 +355,9 @@
|
||||||
#define SEXP_USE_BOEHM 0
|
#define SEXP_USE_BOEHM 0
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifdef SEXP_USE_UNIFY_FILENOS_BY_NUMBER
|
|
||||||
#define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 0
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_WEAK_REFERENCES
|
#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
|
#define SEXP_USE_WEAK_REFERENCES ! SEXP_USE_NO_FEATURES
|
||||||
#endif
|
#endif
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
|
#ifndef SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
|
||||||
#define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 0
|
#define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 0
|
||||||
|
@ -539,14 +379,6 @@
|
||||||
#define SEXP_USE_DEBUG_GC 0
|
#define SEXP_USE_DEBUG_GC 0
|
||||||
#endif
|
#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
|
#ifndef SEXP_USE_SAFE_GC_MARK
|
||||||
#define SEXP_USE_SAFE_GC_MARK SEXP_USE_DEBUG_GC > 1
|
#define SEXP_USE_SAFE_GC_MARK SEXP_USE_DEBUG_GC > 1
|
||||||
#endif
|
#endif
|
||||||
|
@ -555,10 +387,6 @@
|
||||||
#define SEXP_USE_CONSERVATIVE_GC 0
|
#define SEXP_USE_CONSERVATIVE_GC 0
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_FINALIZERS
|
|
||||||
#define SEXP_USE_FINALIZERS 1
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_TRACK_ALLOC_SOURCE
|
#ifndef SEXP_USE_TRACK_ALLOC_SOURCE
|
||||||
#define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
|
#define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
|
||||||
#endif
|
#endif
|
||||||
|
@ -567,18 +395,6 @@
|
||||||
#define SEXP_USE_TRACK_ALLOC_BACKTRACE SEXP_USE_TRACK_ALLOC_SOURCE
|
#define SEXP_USE_TRACK_ALLOC_BACKTRACE SEXP_USE_TRACK_ALLOC_SOURCE
|
||||||
#endif
|
#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
|
#ifndef SEXP_BACKTRACE_SIZE
|
||||||
#define SEXP_BACKTRACE_SIZE 3
|
#define SEXP_BACKTRACE_SIZE 3
|
||||||
#endif
|
#endif
|
||||||
|
@ -616,7 +432,7 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
#ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
||||||
#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 1
|
#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
||||||
|
@ -690,10 +506,6 @@
|
||||||
#define SEXP_PLACEHOLDER_DIGIT '#'
|
#define SEXP_PLACEHOLDER_DIGIT '#'
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_PATCH_NON_DECIMAL_NUMERIC_FORMATS
|
|
||||||
#define SEXP_USE_PATCH_NON_DECIMAL_NUMERIC_FORMATS 1
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_MATH
|
#ifndef SEXP_USE_MATH
|
||||||
#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES
|
#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES
|
||||||
#endif
|
#endif
|
||||||
|
@ -710,27 +522,15 @@
|
||||||
#define SEXP_USE_OBJECT_BRACE_LITERALS (SEXP_USE_TYPE_DEFS && !SEXP_USE_NO_FEATURES)
|
#define SEXP_USE_OBJECT_BRACE_LITERALS (SEXP_USE_TYPE_DEFS && !SEXP_USE_NO_FEATURES)
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
/* Dangerous without shared object detection. */
|
||||||
#ifndef SEXP_USE_TYPE_PRINTERS
|
#ifndef SEXP_USE_TYPE_PRINTERS
|
||||||
#define SEXP_USE_TYPE_PRINTERS SEXP_USE_OBJECT_BRACE_LITERALS
|
#define SEXP_USE_TYPE_PRINTERS 0
|
||||||
#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
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_BYTEVECTOR_LITERALS
|
#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
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_BYTEVECTOR_HEX_LITERALS
|
|
||||||
#define SEXP_BYTEVECTOR_HEX_LITERALS SEXP_USE_BYTEVECTOR_LITERALS
|
|
||||||
#endif
|
|
||||||
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_SELF_PARAMETER
|
#ifndef SEXP_USE_SELF_PARAMETER
|
||||||
#define SEXP_USE_SELF_PARAMETER 1
|
#define SEXP_USE_SELF_PARAMETER 1
|
||||||
#endif
|
#endif
|
||||||
|
@ -783,10 +583,6 @@
|
||||||
#define SEXP_USE_EXTENDED_CHAR_NAMES ! SEXP_USE_NO_FEATURES
|
#define SEXP_USE_EXTENDED_CHAR_NAMES ! SEXP_USE_NO_FEATURES
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_READER_LABELS
|
|
||||||
#define SEXP_USE_READER_LABELS ! SEXP_USE_NO_FEATURES
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_UTF8_STRINGS
|
#ifndef SEXP_USE_UTF8_STRINGS
|
||||||
#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES
|
#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES
|
||||||
#endif
|
#endif
|
||||||
|
@ -802,20 +598,8 @@
|
||||||
#define SEXP_USE_PACKED_STRINGS 1
|
#define SEXP_USE_PACKED_STRINGS 1
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if SEXP_USE_PACKED_STRINGS
|
#ifndef SEXP_USE_STRING_STREAMS
|
||||||
#define SEXP_USE_STRING_INDEX_TABLE 0
|
#define SEXP_USE_STRING_STREAMS 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
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_AUTOCLOSE_PORTS
|
#ifndef SEXP_USE_AUTOCLOSE_PORTS
|
||||||
|
@ -823,11 +607,7 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_GC_FILE_DESCRIPTORS
|
#ifndef SEXP_USE_GC_FILE_DESCRIPTORS
|
||||||
#ifdef PLAN9
|
#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM && !defined(PLAN9))
|
||||||
#define SEXP_USE_GC_FILE_DESCRIPTORS 0
|
|
||||||
#else
|
|
||||||
#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM)
|
|
||||||
#endif
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_BIDIRECTIONAL_PORTS
|
#ifndef SEXP_USE_BIDIRECTIONAL_PORTS
|
||||||
|
@ -880,10 +660,6 @@
|
||||||
#define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000
|
#define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_MAX_VECTOR_LENGTH
|
|
||||||
#define SEXP_MAX_VECTOR_LENGTH (SEXP_MAX_FIXNUM >> 1)
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_DEFAULT_EQUAL_DEPTH
|
#ifndef SEXP_DEFAULT_EQUAL_DEPTH
|
||||||
#define SEXP_DEFAULT_EQUAL_DEPTH 10000
|
#define SEXP_DEFAULT_EQUAL_DEPTH 10000
|
||||||
#endif
|
#endif
|
||||||
|
@ -892,21 +668,8 @@
|
||||||
#define SEXP_DEFAULT_EQUAL_BOUND 100000000
|
#define SEXP_DEFAULT_EQUAL_BOUND 100000000
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_DEFAULT_WRITE_BOUND
|
|
||||||
#define SEXP_DEFAULT_WRITE_BOUND 10000
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_STRIP_SYNCLOS_BOUND
|
|
||||||
#define SEXP_STRIP_SYNCLOS_BOUND 10000
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_POLL_SLEEP_TIME
|
|
||||||
#define SEXP_POLL_SLEEP_TIME 5000
|
|
||||||
#define SEXP_POLL_SLEEP_TIME_MS 5
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_IMAGE_LOADING
|
#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
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_UNSAFE_PUSH
|
#ifndef SEXP_USE_UNSAFE_PUSH
|
||||||
|
@ -944,17 +707,13 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_ALIGNED_BYTECODE
|
#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
|
#define SEXP_USE_ALIGNED_BYTECODE 1
|
||||||
#else
|
#else
|
||||||
#define SEXP_USE_ALIGNED_BYTECODE 0
|
#define SEXP_USE_ALIGNED_BYTECODE 0
|
||||||
#endif
|
#endif
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_SIGNED_SHIFTS
|
|
||||||
#define SEXP_USE_SIGNED_SHIFTS 0
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifdef PLAN9
|
#ifdef PLAN9
|
||||||
#define strcasecmp cistrcmp
|
#define strcasecmp cistrcmp
|
||||||
#define strncasecmp cistrncmp
|
#define strncasecmp cistrncmp
|
||||||
|
@ -964,17 +723,6 @@
|
||||||
#define isinf(x) (isInf(x,1) || isInf(x,-1))
|
#define isinf(x) (isInf(x,1) || isInf(x,-1))
|
||||||
#define isnan(x) isNaN(x)
|
#define isnan(x) isNaN(x)
|
||||||
#elif defined(_WIN32)
|
#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 snprintf(buf, len, fmt, val) sprintf(buf, fmt, val)
|
||||||
#define strcasecmp lstrcmpi
|
#define strcasecmp lstrcmpi
|
||||||
#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2)
|
#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2)
|
||||||
|
@ -983,10 +731,6 @@
|
||||||
#define isnan(x) (x!=x)
|
#define isnan(x) (x!=x)
|
||||||
#define isinf(x) (x > DBL_MAX || x < -DBL_MAX)
|
#define isinf(x) (x > DBL_MAX || x < -DBL_MAX)
|
||||||
#endif
|
#endif
|
||||||
#elif !defined(__MINGW32__)
|
|
||||||
#error Unknown Win32 compiler!
|
|
||||||
#endif
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifdef _WIN32
|
#ifdef _WIN32
|
||||||
#define sexp_pos_infinity (DBL_MAX*DBL_MAX)
|
#define sexp_pos_infinity (DBL_MAX*DBL_MAX)
|
||||||
|
@ -1002,16 +746,12 @@
|
||||||
#define sexp_nan (0.0/0.0)
|
#define sexp_nan (0.0/0.0)
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifdef _WIN32
|
#ifdef __MINGW32__
|
||||||
#ifdef SEXP_STATIC_LIBRARY
|
|
||||||
#define SEXP_API extern
|
|
||||||
#else
|
|
||||||
#ifdef BUILDING_DLL
|
#ifdef BUILDING_DLL
|
||||||
#define SEXP_API __declspec(dllexport)
|
#define SEXP_API __declspec(dllexport)
|
||||||
#else
|
#else
|
||||||
#define SEXP_API __declspec(dllimport)
|
#define SEXP_API __declspec(dllimport)
|
||||||
#endif
|
#endif
|
||||||
#endif
|
|
||||||
#else
|
#else
|
||||||
#define SEXP_API extern
|
#define SEXP_API extern
|
||||||
#endif
|
#endif
|
||||||
|
|
|
@ -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 */
|
|
|
@ -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@"
|
|
|
@ -1,4 +1,3 @@
|
||||||
static struct sexp_huff_entry huff_table[] = {
|
|
||||||
{12, 0x0C00}, /* '\x00' */
|
{12, 0x0C00}, /* '\x00' */
|
||||||
{15, 0x0000}, /* '\x01' */
|
{15, 0x0000}, /* '\x01' */
|
||||||
{15, 0x4000}, /* '\x02' */
|
{15, 0x4000}, /* '\x02' */
|
||||||
|
@ -126,5 +125,4 @@ static struct sexp_huff_entry huff_table[] = {
|
||||||
{14, 0x0E00}, /* '|' */
|
{14, 0x0E00}, /* '|' */
|
||||||
{14, 0x2E00}, /* '}' */
|
{14, 0x2E00}, /* '}' */
|
||||||
{14, 0x1E00}, /* '~' */
|
{14, 0x1E00}, /* '~' */
|
||||||
{14, 0x3E00} /* '\x7f' */
|
{14, 0x3E00}, /* '\x7f' */
|
||||||
};
|
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
|
|
||||||
extern char _huff_tab1[8], _huff_tab2[8], _huff_tab3[2], _huff_tab4[2],
|
char _huff_tab1[8], _huff_tab2[8], _huff_tab3[2], _huff_tab4[2],
|
||||||
_huff_tab5[4], _huff_tab6[2], _huff_tab7[4], _huff_tab8[4],
|
_huff_tab5[4], _huff_tab6[2], _huff_tab7[4], _huff_tab8[4],
|
||||||
_huff_tab9[4], _huff_tab10[4], _huff_tab11[4], _huff_tab12[2],
|
_huff_tab9[4], _huff_tab10[4], _huff_tab11[4], _huff_tab12[2],
|
||||||
_huff_tab13[8], _huff_tab14[2], _huff_tab15[8], _huff_tab16[8],
|
_huff_tab13[8], _huff_tab14[2], _huff_tab15[8], _huff_tab16[8],
|
||||||
|
|
792
include/chibi/sexp.h
Normal file → Executable file
792
include/chibi/sexp.h
Normal file → Executable file
File diff suppressed because it is too large
Load diff
|
@ -1,4 +0,0 @@
|
||||||
[
|
|
||||||
"_main",
|
|
||||||
"_sexp_resume"
|
|
||||||
]
|
|
116
js/index.html
116
js/index.html
|
@ -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>
|
|
|
@ -1,2 +0,0 @@
|
||||||
Module['resume'] = Module.cwrap('sexp_resume', 'void', []);
|
|
||||||
|
|
|
@ -1,6 +0,0 @@
|
||||||
Module['preRun'].push(function () {
|
|
||||||
FS.writeFile('program.scm', Module['program']);
|
|
||||||
});
|
|
||||||
Module['arguments'] = Module['arguments'] || [];
|
|
||||||
Module['arguments'].unshift('program.scm');
|
|
||||||
|
|
|
@ -92,19 +92,19 @@ sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
|
||||||
/* Additional utilities. */
|
/* Additional utilities. */
|
||||||
|
|
||||||
sexp sexp_sockaddr_name (sexp ctx, sexp self, struct sockaddr* addr) {
|
sexp sexp_sockaddr_name (sexp ctx, sexp self, struct sockaddr* addr) {
|
||||||
char buf[INET6_ADDRSTRLEN];
|
char buf[24];
|
||||||
/* struct sockaddr_in *sa = (struct sockaddr_in *)addr; */
|
/* struct sockaddr_in *sa = (struct sockaddr_in *)addr; */
|
||||||
/* unsigned char *ptr = (unsigned char *)&(sa->sin_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]); */
|
/* sprintf(buf, "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
|
||||||
inet_ntop(addr->sa_family,
|
inet_ntop(addr->sa_family,
|
||||||
(addr->sa_family == AF_INET6 ?
|
(addr->sa_family == AF_INET6 ?
|
||||||
(void*)(&(((struct sockaddr_in6 *)addr)->sin6_addr)) :
|
(void*)(&(((struct sockaddr_in6 *)addr)->sin6_addr)) :
|
||||||
(void*)(&(((struct sockaddr_in *)addr)->sin_addr))),
|
(void*)(&(((struct sockaddr_in *)addr)->sin_addr))),
|
||||||
buf, INET6_ADDRSTRLEN);
|
buf, 24);
|
||||||
return sexp_c_string(ctx, buf, -1);
|
return sexp_c_string(ctx, buf, -1);
|
||||||
}
|
}
|
||||||
|
|
||||||
int sexp_sockaddr_port (sexp ctx, sexp self, struct sockaddr* addr) {
|
int sexp_sockaddr_port (sexp ctx, sexp self, struct sockaddr* addr) {
|
||||||
struct sockaddr_in *sa = (struct sockaddr_in *)addr;
|
struct sockaddr_in *sa = (struct sockaddr_in *)addr;
|
||||||
return ntohs(sa->sin_port);
|
return sa->sin_port;
|
||||||
}
|
}
|
||||||
|
|
|
@ -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))))
|
|
|
@ -1,19 +1,12 @@
|
||||||
;; app.scm -- unified option parsing and config
|
;; app.scm -- unified option parsing and config
|
||||||
;; Copyright (c) 2012-2024 Alex Shinn. All rights reserved.
|
;; Copyright (c) 2012-2015 Alex Shinn. All rights reserved.
|
||||||
;; BSD-style license: http://synthcode.com/license.txt
|
;; BSD-style license: http://synthcode.com/license.txt
|
||||||
|
|
||||||
;;> The high-level interface. Parses a command-line with optional
|
;;> The high-level interface. Given an application spec \var{spec},
|
||||||
;;> and/or positional arguments, with arbitrarily nested subcommands
|
;;> parses the given command-line arguments \var{args} into a config
|
||||||
;;> (optionally having their own arguments), and calls the
|
;;> object, prepended to the existing object \var{config} if given.
|
||||||
;;> corresponding main procedure on the parsed config.
|
;;> Then runs the corresponding command (or sub-command) procedure
|
||||||
;;>
|
;;> from \var{spec}.
|
||||||
;;> Given an application spec \var{spec}, parses the given
|
|
||||||
;;> command-line arguments \var{args} into a config object (from
|
|
||||||
;;> \scheme{(chibi config)}), prepended to the existing object
|
|
||||||
;;> \var{config} if given. Then runs the corresponding command (or
|
|
||||||
;;> sub-command) procedure from \var{spec} on the following arguments:
|
|
||||||
;;>
|
|
||||||
;;> \scheme{(<proc> <config> <spec> <positional args> ...)}
|
|
||||||
;;>
|
;;>
|
||||||
;;> The app spec should be a list of the form:
|
;;> The app spec should be a list of the form:
|
||||||
;;>
|
;;>
|
||||||
|
@ -22,13 +15,12 @@
|
||||||
;;> where clauses can be any of:
|
;;> where clauses can be any of:
|
||||||
;;>
|
;;>
|
||||||
;;> \itemlist[
|
;;> \itemlist[
|
||||||
;;> \item{\scheme{(@ <opt-spec>)} - option spec, described below}
|
;;> \item[\scheme{(@ <opt-spec>)} - option spec, described below]
|
||||||
;;> \item{\scheme{(begin: <begin-proc>)} - procedure to run before main}
|
;;> \item[\scheme{(begin: <begin-proc>)} - procedure to run before main]
|
||||||
;;> \item{\scheme{(end: <end-proc>)} - procedure to run after 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{(<proc> args ...)} - main procedure (args only for documentation)}
|
;;> \item[\scheme{<app-spec>} - a subcommand described by the nested spec]
|
||||||
;;> \item{\scheme{<app-spec>} - a subcommand described by the nested spec}
|
;;> \item[\scheme{(or <app-spec> ...)} - an alternate list of subcommands]
|
||||||
;;> \item{\scheme{(or <app-spec> ...)} - an alternate list of subcommands}
|
|
||||||
;;> ]
|
;;> ]
|
||||||
;;>
|
;;>
|
||||||
;;> For subcommands the symbolic command name must match, though it is
|
;;> For subcommands the symbolic command name must match, though it is
|
||||||
|
@ -48,7 +40,7 @@
|
||||||
;;>
|
;;>
|
||||||
;;> \itemlist[
|
;;> \itemlist[
|
||||||
;;> \item{\scheme{boolean} - boolean, associated value optional, allowing \scheme{--noname} to indicate \scheme{#false}}
|
;;> \item{\scheme{boolean} - boolean, associated value optional, allowing \scheme{--noname} to indicate \scheme{#false}}
|
||||||
;;> \item{\scheme{char} - a single character}
|
;;> \item{[\scheme{char} - a single character}
|
||||||
;;> \item{\scheme{integer} - an exact integer}
|
;;> \item{\scheme{integer} - an exact integer}
|
||||||
;;> \item{\scheme{real} - any real number}
|
;;> \item{\scheme{real} - any real number}
|
||||||
;;> \item{\scheme{number} - any real or complex number}
|
;;> \item{\scheme{number} - any real or complex number}
|
||||||
|
@ -63,43 +55,7 @@
|
||||||
;;> files, whereas the app specs include embedded procedure objects so
|
;;> files, whereas the app specs include embedded procedure objects so
|
||||||
;;> are typically written with \scheme{quasiquote}.
|
;;> are typically written with \scheme{quasiquote}.
|
||||||
;;>
|
;;>
|
||||||
;;> Complete Example - stripped down ls(1):
|
;;> Complete Example:
|
||||||
;;>
|
|
||||||
;;> \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{
|
;;> \schemeblock{
|
||||||
;;> (run-application
|
;;> (run-application
|
||||||
|
@ -107,11 +63,11 @@
|
||||||
;;> "Zookeeper Application"
|
;;> "Zookeeper Application"
|
||||||
;;> (@
|
;;> (@
|
||||||
;;> (animals (list symbol) "list of animals to act on (default all)")
|
;;> (animals (list symbol) "list of animals to act on (default all)")
|
||||||
;;> (lions boolean (#\\l) "also apply the action to lions"))
|
;;> (lions boolean (#\l) "also apply the action to lions"))
|
||||||
;;> (or
|
;;> (or
|
||||||
;;> (feed "feed the animals" () (,feed animals ...))
|
;;> (feed "feed the animals" () (,feed animals ...))
|
||||||
;;> (wash "wash the animals" (@ (soap boolean)) (,wash animals ...))
|
;;> (wash "wash the animals" (@ (soap boolean)) (,wash animals ...))
|
||||||
;;> (help "print help" (,app-help-command))))
|
;;> (help "print help" (,app-help-command)))
|
||||||
;;> (command-line)
|
;;> (command-line)
|
||||||
;;> (conf-load (string-append (get-environment-variable "HOME") "/.zoo")))
|
;;> (conf-load (string-append (get-environment-variable "HOME") "/.zoo")))
|
||||||
;;> }
|
;;> }
|
||||||
|
@ -169,7 +125,7 @@
|
||||||
(let ((args (or (and (pair? o) (car o)) (command-line)))
|
(let ((args (or (and (pair? o) (car o)) (command-line)))
|
||||||
(config (and (pair? o) (pair? (cdr o)) (cadr o))))
|
(config (and (pair? o) (pair? (cdr o)) (cadr o))))
|
||||||
(cond
|
(cond
|
||||||
((parse-app '() (cdr spec) '() (cdr args) config #f #f '())
|
((parse-app '() (cdr spec) '() (cdr args) config #f #f)
|
||||||
=> (lambda (v)
|
=> (lambda (v)
|
||||||
(let ((proc (vector-ref v 0))
|
(let ((proc (vector-ref v 0))
|
||||||
(cfg (vector-ref v 1))
|
(cfg (vector-ref v 1))
|
||||||
|
@ -177,14 +133,13 @@
|
||||||
(init (vector-ref v 3))
|
(init (vector-ref v 3))
|
||||||
(end (vector-ref v 4)))
|
(end (vector-ref v 4)))
|
||||||
(if init (init cfg))
|
(if init (init cfg))
|
||||||
(let ((res (apply proc cfg spec args)))
|
(apply proc cfg spec args)
|
||||||
(if end (end cfg))
|
(if end (end cfg)))))
|
||||||
res))))
|
|
||||||
((null? (cdr args))
|
((null? (cdr args))
|
||||||
(app-help spec args)
|
(app-help spec args)
|
||||||
(error "Expected a command"))
|
(error "Expected a command"))
|
||||||
(else
|
(else
|
||||||
(error "Unknown command" args)))))
|
(error "Unknown command" (cdr args))))))
|
||||||
|
|
||||||
;;> Parse a single command-line argument from \var{args} according to
|
;;> Parse a single command-line argument from \var{args} according to
|
||||||
;;> \var{conf-spec}, and returns a list of two values: the
|
;;> \var{conf-spec}, and returns a list of two values: the
|
||||||
|
@ -194,7 +149,7 @@
|
||||||
;;> \var{fail} with a single string argument describing the error,
|
;;> \var{fail} with a single string argument describing the error,
|
||||||
;;> returning that result.
|
;;> returning that result.
|
||||||
|
|
||||||
(define (parse-option prefix conf-spec args types fail)
|
(define (parse-option prefix conf-spec args fail)
|
||||||
(define (parse-value type str)
|
(define (parse-value type str)
|
||||||
(cond
|
(cond
|
||||||
((not (string? str))
|
((not (string? str))
|
||||||
|
@ -231,10 +186,7 @@
|
||||||
res))
|
res))
|
||||||
#f))
|
#f))
|
||||||
(else
|
(else
|
||||||
(cond
|
(list str #f))))))
|
||||||
((assq type types)
|
|
||||||
=> (lambda (cell) (list ((cadr cell) str) #f)))
|
|
||||||
(else (list str #f))))))))
|
|
||||||
(define (lookup-conf-spec conf-spec syms strs)
|
(define (lookup-conf-spec conf-spec syms strs)
|
||||||
(let ((sym (car syms))
|
(let ((sym (car syms))
|
||||||
(str (car strs)))
|
(str (car strs)))
|
||||||
|
@ -349,7 +301,7 @@
|
||||||
;;> is the list of remaining non-option arguments. Calls fail on
|
;;> is the list of remaining non-option arguments. Calls fail on
|
||||||
;;> error and tries to continue processing from the result.
|
;;> error and tries to continue processing from the result.
|
||||||
|
|
||||||
(define (parse-options prefix conf-spec orig-args types fail)
|
(define (parse-options prefix conf-spec orig-args fail)
|
||||||
(let lp ((args orig-args)
|
(let lp ((args orig-args)
|
||||||
(opts (make-conf '() #f (cons 'options orig-args) #f)))
|
(opts (make-conf '() #f (cons 'options orig-args) #f)))
|
||||||
(cond
|
(cond
|
||||||
|
@ -359,7 +311,7 @@
|
||||||
(not (eqv? #\- (string-ref (car args) 0))))
|
(not (eqv? #\- (string-ref (car args) 0))))
|
||||||
(cons opts (if (equal? (car args) "--") (cdr args) args)))
|
(cons opts (if (equal? (car args) "--") (cdr args) args)))
|
||||||
(else
|
(else
|
||||||
(let ((val+args (parse-option prefix conf-spec args types fail)))
|
(let ((val+args (parse-option prefix conf-spec args fail)))
|
||||||
(lp (cdr val+args)
|
(lp (cdr val+args)
|
||||||
(conf-set opts (caar val+args) (cdar val+args))))))))
|
(conf-set opts (caar val+args) (cdar val+args))))))))
|
||||||
|
|
||||||
|
@ -379,92 +331,59 @@
|
||||||
;;> all prefixed by \var{prefix}. The original \var{spec} is used for
|
;;> all prefixed by \var{prefix}. The original \var{spec} is used for
|
||||||
;;> \scheme{app-help}.
|
;;> \scheme{app-help}.
|
||||||
|
|
||||||
(define (parse-app prefix spec opt-spec args config init end types . o)
|
(define (parse-app prefix spec opt-spec args config init end . o)
|
||||||
(define (next-prefix prefix name)
|
(define (next-prefix prefix name)
|
||||||
(append (if (null? prefix) '(command) prefix) (list name)))
|
(append (if (null? prefix) '(command) prefix) (list name)))
|
||||||
(define (prev-prefix prefix)
|
(define (prev-prefix prefix)
|
||||||
(cond ((and (= 2 (length prefix))) '())
|
(cond ((and (= 2 (length prefix))))
|
||||||
((null? prefix) '())
|
((null? prefix) '())
|
||||||
(else (reverse (cdr (reverse 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)
|
(let ((fail (if (pair? o)
|
||||||
(car o)
|
(car o)
|
||||||
(lambda (prefix spec opt args reason)
|
(lambda (prefix spec opt args reason)
|
||||||
(cond
|
;; TODO: search for closest option in "unknown" case
|
||||||
((and (string=? reason "unknown option")
|
(error reason opt)))))
|
||||||
(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
|
(cond
|
||||||
((null? spec)
|
((null? spec)
|
||||||
(error "no procedure in application 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))
|
((pair? (car spec))
|
||||||
(case (caar spec)
|
(case (caar spec)
|
||||||
((@)
|
((@)
|
||||||
(let* ((tail (cdar spec))
|
(let* ((new-opt-spec (cadr (car 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
|
(new-fail
|
||||||
(lambda (new-prefix new-spec new-opt new-args reason)
|
(lambda (new-prefix new-spec new-opt new-args reason)
|
||||||
(parse-option (prev-prefix prefix) opt-spec new-args types fail)))
|
(parse-options (prev-prefix prefix) opt-spec new-args fail)))
|
||||||
(cfg+args (parse-options prefix new-opt-spec args types new-fail))
|
(cfg+args (parse-options prefix new-opt-spec args new-fail))
|
||||||
(config (conf-append (car cfg+args) config))
|
(config (conf-append (car cfg+args) config))
|
||||||
(args (cdr cfg+args)))
|
(args (cdr cfg+args)))
|
||||||
(parse-app prefix (cdr spec) new-opt-spec args config
|
(parse-app prefix (cdr spec) new-opt-spec args config
|
||||||
init end types new-fail)))
|
init end new-fail)))
|
||||||
((or)
|
((or)
|
||||||
(any (lambda (x) (parse-app prefix x opt-spec args config init end types))
|
(any (lambda (x) (parse-app prefix x opt-spec args config init end))
|
||||||
(cdar spec)))
|
(cdar spec)))
|
||||||
((begin:)
|
((begin:)
|
||||||
(parse-app prefix (cdr spec) opt-spec args config
|
(parse-app prefix (cdr spec) opt-spec args config
|
||||||
(cadr (car spec)) end types fail))
|
(cadr (car spec)) end fail))
|
||||||
((end:)
|
((end:)
|
||||||
(parse-app prefix (cdr spec) opt-spec args config
|
(parse-app prefix (cdr spec) opt-spec args config
|
||||||
init (cadr (car spec)) types fail))
|
init (cadr (car spec)) fail))
|
||||||
((types:)
|
|
||||||
(parse-app prefix (cdr spec) opt-spec args config
|
|
||||||
init end (cdr (car spec)) fail))
|
|
||||||
(else
|
(else
|
||||||
(if (procedure? (caar spec))
|
(if (procedure? (caar spec))
|
||||||
(vector (caar spec) config args init end) ; TODO: verify
|
(vector (caar spec) config args init end) ; TODO: verify
|
||||||
(parse-app prefix (car spec) opt-spec args config
|
(parse-app prefix (car spec) opt-spec args config
|
||||||
init end types fail)))))
|
init end fail)))))
|
||||||
((symbol? (car spec))
|
((symbol? (car spec))
|
||||||
(and (pair? args)
|
(and (pair? args)
|
||||||
(eq? (car spec) (string->symbol (car args)))
|
(eq? (car spec) (string->symbol (car args)))
|
||||||
(let ((prefix (next-prefix prefix (car spec))))
|
(let ((prefix (next-prefix prefix (car spec))))
|
||||||
(parse-app prefix (cdr spec) opt-spec (cdr args) config
|
(parse-app prefix (cdr spec) opt-spec (cdr args) config
|
||||||
init end types fail))))
|
init end fail))))
|
||||||
((procedure? (car spec))
|
((procedure? (car spec))
|
||||||
(vector (car spec) config args init end))
|
(vector (car spec) config args init end))
|
||||||
(else
|
(else
|
||||||
(if (not (string? (car spec)))
|
(if (not (string? (car spec)))
|
||||||
(error "unknown application spec" (car spec)))
|
(error "unknown application spec" (car spec)))
|
||||||
(parse-app prefix (cdr spec) opt-spec args config init end types fail)))))
|
(parse-app prefix (cdr spec) opt-spec args config init end fail)))))
|
||||||
|
|
||||||
(define (print-command-help command out)
|
(define (print-command-help command out)
|
||||||
(cond
|
(cond
|
||||||
|
@ -538,7 +457,7 @@
|
||||||
(and (pair? (car ls)) (memq (caar ls) '(begin: end:) )))
|
(and (pair? (car ls)) (memq (caar ls) '(begin: end:) )))
|
||||||
(lp (cdr ls) (car ls) commands options))
|
(lp (cdr ls) (car ls) commands options))
|
||||||
((and (pair? (car ls)) (eq? '@ (caar ls)))
|
((and (pair? (car ls)) (eq? '@ (caar ls)))
|
||||||
(lp (cdr ls) docs commands (append options (cdar ls))))
|
(lp (cdr ls) docs commands (append options (cadr (car ls)))))
|
||||||
((and (pair? (car ls)) (symbol? (caar ls)))
|
((and (pair? (car ls)) (symbol? (caar ls)))
|
||||||
;; don't print nested commands
|
;; don't print nested commands
|
||||||
(if (pair? commands)
|
(if (pair? commands)
|
||||||
|
|
|
@ -9,6 +9,5 @@
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(srfi 1)
|
(srfi 1)
|
||||||
(chibi config)
|
(chibi config)
|
||||||
(chibi edit-distance)
|
|
||||||
(chibi string))
|
(chibi string))
|
||||||
(include "app.scm"))
|
(include "app.scm"))
|
||||||
|
|
|
@ -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)))
|
|
|
@ -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"))
|
|
|
@ -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))))
|
|
|
@ -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)))))
|
|
265
lib/chibi/ast.c
265
lib/chibi/ast.c
|
@ -1,35 +1,13 @@
|
||||||
/* ast.c -- interface to the Abstract Syntax Tree */
|
/* 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 */
|
/* BSD-style license: http://synthcode.com/license.txt */
|
||||||
|
|
||||||
#include <chibi/eval.h>
|
#include <chibi/eval.h>
|
||||||
|
|
||||||
#ifndef PLAN9
|
#ifndef PLAN9
|
||||||
#include <stdlib.h>
|
|
||||||
#include <errno.h>
|
#include <errno.h>
|
||||||
#endif
|
#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
|
#if ! SEXP_USE_BOEHM
|
||||||
extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
|
extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
|
||||||
#endif
|
#endif
|
||||||
|
@ -62,7 +40,7 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
|
||||||
sexp_gc_release2(ctx);
|
sexp_gc_release2(ctx);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
|
static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
|
||||||
sexp cell;
|
sexp cell;
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
||||||
cell = sexp_env_cell(ctx, env, id, 0);
|
cell = sexp_env_cell(ctx, env, id, 0);
|
||||||
|
@ -72,55 +50,33 @@ sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, s
|
||||||
id = sexp_synclo_expr(id);
|
id = sexp_synclo_expr(id);
|
||||||
}
|
}
|
||||||
cell = sexp_env_cell(ctx, env, id, 0);
|
cell = sexp_env_cell(ctx, env, id, 0);
|
||||||
if (!cell && sexp_truep(createp))
|
if (!cell && createp)
|
||||||
cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
|
cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
|
||||||
}
|
}
|
||||||
return cell ? cell : SEXP_FALSE;
|
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);
|
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
|
||||||
return sexp_procedure_code(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);
|
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
|
||||||
return sexp_procedure_vars(proc);
|
return sexp_procedure_vars(proc);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
|
static sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
|
||||||
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
|
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
|
||||||
return sexp_make_fixnum(sexp_procedure_num_args(proc));
|
return sexp_make_fixnum(sexp_procedure_num_args(proc));
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
|
static sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
|
||||||
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
|
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
|
||||||
return sexp_make_boolean(sexp_procedure_variadic_p(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) {
|
static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
|
||||||
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) {
|
|
||||||
if (! sexp_opcodep(op))
|
if (! sexp_opcodep(op))
|
||||||
return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
|
return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
|
||||||
else if (! sexp_opcode_name(op))
|
else if (! sexp_opcode_name(op))
|
||||||
|
@ -147,7 +103,7 @@ static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
|
||||||
return res;
|
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;
|
sexp res;
|
||||||
if (!op)
|
if (!op)
|
||||||
return sexp_type_by_index(ctx, SEXP_OBJECT);
|
return sexp_type_by_index(ctx, SEXP_OBJECT);
|
||||||
|
@ -161,7 +117,7 @@ sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
|
||||||
return sexp_translate_opcode_type(ctx, res);
|
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;
|
sexp res;
|
||||||
int p = sexp_unbox_fixnum(k);
|
int p = sexp_unbox_fixnum(k);
|
||||||
if (! sexp_opcodep(op))
|
if (! sexp_opcodep(op))
|
||||||
|
@ -180,7 +136,7 @@ sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, se
|
||||||
default:
|
default:
|
||||||
res = sexp_opcode_arg3_type(op);
|
res = sexp_opcode_arg3_type(op);
|
||||||
if (res && sexp_vectorp(res)) {
|
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));
|
res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
|
||||||
else
|
else
|
||||||
res = sexp_type_by_index(ctx, SEXP_OBJECT);
|
res = sexp_type_by_index(ctx, SEXP_OBJECT);
|
||||||
|
@ -190,17 +146,17 @@ sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, se
|
||||||
return sexp_translate_opcode_type(ctx, res);
|
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);
|
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
|
||||||
return sexp_make_fixnum(sexp_opcode_class(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);
|
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
|
||||||
return sexp_make_fixnum(sexp_opcode_code(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 data;
|
||||||
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
|
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
|
||||||
data = sexp_opcode_data(op);
|
data = sexp_opcode_data(op);
|
||||||
|
@ -211,41 +167,29 @@ sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
|
||||||
sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
|
sexp_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);
|
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
|
||||||
return sexp_make_fixnum(sexp_opcode_num_args(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);
|
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
|
||||||
return sexp_make_boolean(sexp_opcode_variadic_p(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);
|
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
|
||||||
return sexp_make_fixnum(sexp_port_line(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_portp, SEXP_IPORT, p);
|
||||||
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
|
||||||
sexp_port_line(p) = sexp_unbox_fixnum(i);
|
sexp_port_line(p) = sexp_unbox_fixnum(i);
|
||||||
return SEXP_VOID;
|
return SEXP_VOID;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_get_port_sourcep (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
|
static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||||
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)
|
if (!x)
|
||||||
return sexp_type_by_index(ctx, SEXP_OBJECT);
|
return sexp_type_by_index(ctx, SEXP_OBJECT);
|
||||||
if (sexp_pointerp(x))
|
if (sexp_pointerp(x))
|
||||||
|
@ -268,43 +212,41 @@ sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||||
return sexp_type_by_index(ctx, SEXP_OBJECT);
|
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) {
|
static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
||||||
if (sexp_truep(e2)) sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2);
|
return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
|
||||||
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_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
||||||
return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
|
return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
|
static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
||||||
sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
|
sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
|
||||||
sexp_env_lambda(e) = lam;
|
sexp_env_lambda(e) = lam;
|
||||||
return SEXP_VOID;
|
return SEXP_VOID;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
|
static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
||||||
return sexp_make_boolean(sexp_env_syntactic_p(e));
|
return sexp_make_boolean(sexp_env_syntactic_p(e));
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
|
static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
||||||
sexp_env_syntactic_p(e) = sexp_truep(synp);
|
sexp_env_syntactic_p(e) = sexp_truep(synp);
|
||||||
return SEXP_VOID;
|
return SEXP_VOID;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
|
static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
||||||
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
|
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
|
||||||
return sexp_env_cell_define(ctx, env, name, value, NULL);
|
return sexp_env_cell_define(ctx, env, name, value, NULL);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
|
static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
|
||||||
sexp_gc_var1(tmp);
|
sexp_gc_var1(tmp);
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
||||||
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
|
sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
|
||||||
|
@ -314,45 +256,38 @@ sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name,
|
||||||
return SEXP_VOID;
|
return SEXP_VOID;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
|
static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
|
||||||
sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
|
sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
|
||||||
return sexp_make_fixnum(sexp_core_code(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);
|
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
|
||||||
return sexp_type_name(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);
|
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
|
||||||
return sexp_type_cpl(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);
|
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
|
||||||
return sexp_type_slots(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);
|
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
|
||||||
return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(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_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);
|
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
|
||||||
return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE;
|
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) {
|
static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||||
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) {
|
|
||||||
sexp t;
|
sexp t;
|
||||||
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
|
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
|
||||||
return SEXP_ZERO;
|
return SEXP_ZERO;
|
||||||
|
@ -360,40 +295,15 @@ sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||||
return sexp_make_fixnum(sexp_type_size_of_object(t, x));
|
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) {
|
static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
|
||||||
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) {
|
|
||||||
sexp x = (sexp)sexp_unbox_fixnum(i);
|
sexp x = (sexp)sexp_unbox_fixnum(i);
|
||||||
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
|
||||||
if (!x || sexp_pointerp(x))
|
if (sexp_pointerp(x))
|
||||||
return dflt;
|
return dflt;
|
||||||
return x;
|
return x;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_object_to_integer (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
|
||||||
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) {
|
|
||||||
sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
|
sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
|
||||||
sexp_lambda_name(res) = name;
|
sexp_lambda_name(res) = name;
|
||||||
sexp_lambda_params(res) = params;
|
sexp_lambda_params(res) = params;
|
||||||
|
@ -407,7 +317,7 @@ sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp pa
|
||||||
return res;
|
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 res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
|
||||||
sexp_lambda_name(res) = sexp_lambda_name(lambda);
|
sexp_lambda_name(res) = sexp_lambda_name(lambda);
|
||||||
sexp_lambda_params(res) = sexp_lambda_params(lambda);
|
sexp_lambda_params(res) = sexp_lambda_params(lambda);
|
||||||
|
@ -421,21 +331,21 @@ sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
|
||||||
return res;
|
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 res = sexp_alloc_type(ctx, set, SEXP_SET);
|
||||||
sexp_set_var(res) = var;
|
sexp_set_var(res) = var;
|
||||||
sexp_set_value(res) = value;
|
sexp_set_value(res) = value;
|
||||||
return res;
|
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 res = sexp_alloc_type(ctx, ref, SEXP_REF);
|
||||||
sexp_ref_name(res) = name;
|
sexp_ref_name(res) = name;
|
||||||
sexp_ref_cell(res) = cell;
|
sexp_ref_cell(res) = cell;
|
||||||
return res;
|
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 res = sexp_alloc_type(ctx, cnd, SEXP_CND);
|
||||||
sexp_cnd_test(res) = test;
|
sexp_cnd_test(res) = test;
|
||||||
sexp_cnd_pass(res) = pass;
|
sexp_cnd_pass(res) = pass;
|
||||||
|
@ -443,26 +353,26 @@ sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass,
|
||||||
return res;
|
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 res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
|
||||||
sexp_seq_ls(res) = ls;
|
sexp_seq_ls(res) = ls;
|
||||||
return res;
|
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 res = sexp_alloc_type(ctx, lit, SEXP_LIT);
|
||||||
sexp_lit_value(res) = value;
|
sexp_lit_value(res) = value;
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
|
static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
|
||||||
sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO);
|
sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO);
|
||||||
sexp_macro_proc(res) = proc;
|
sexp_macro_proc(res) = proc;
|
||||||
sexp_macro_env(res) = env;
|
sexp_macro_env(res) = env;
|
||||||
return res;
|
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;
|
sexp ctx2 = ctx;
|
||||||
if (sexp_envp(e)) {
|
if (sexp_envp(e)) {
|
||||||
ctx2 = sexp_make_child_context(ctx, NULL);
|
ctx2 = sexp_make_child_context(ctx, NULL);
|
||||||
|
@ -471,12 +381,12 @@ sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
|
||||||
return sexp_analyze(ctx2, x);
|
return sexp_analyze(ctx2, x);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
|
static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
|
||||||
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
||||||
return sexp_extend_env(ctx, env, vars, value);
|
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_var2(ls, res);
|
||||||
sexp_gc_preserve2(ctx, ls, res);
|
sexp_gc_preserve2(ctx, ls, res);
|
||||||
res = x;
|
res = x;
|
||||||
|
@ -488,7 +398,7 @@ sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||||
return res;
|
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;
|
size_t sum_freed=0;
|
||||||
#if SEXP_USE_BOEHM
|
#if SEXP_USE_BOEHM
|
||||||
GC_gcollect();
|
GC_gcollect();
|
||||||
|
@ -498,34 +408,20 @@ sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
|
||||||
return sexp_make_unsigned_integer(ctx, sum_freed);
|
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
|
#if SEXP_USE_GREEN_THREADS
|
||||||
sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
|
static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
|
||||||
sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P);
|
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_val;
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
#endif
|
#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 sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
|
||||||
|
sexp ls;
|
||||||
sexp_gc_var1(res);
|
sexp_gc_var1(res);
|
||||||
sexp_gc_preserve1(ctx, res);
|
sexp_gc_preserve1(ctx, res);
|
||||||
res = SEXP_NULL;
|
res = SEXP_NULL;
|
||||||
#if SEXP_USE_GREEN_THREADS
|
#if SEXP_USE_GREEN_THREADS
|
||||||
sexp ls;
|
|
||||||
for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
|
for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||||
sexp_push(ctx, res, sexp_car(ls));
|
sexp_push(ctx, res, sexp_car(ls));
|
||||||
for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
|
for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||||
|
@ -536,18 +432,15 @@ sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
|
||||||
return res;
|
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;
|
const char *res;
|
||||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
|
||||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
|
||||||
sexp_assert_type(ctx, sexp_string_cursorp, SEXP_STRING_CURSOR, start);
|
res = strstr(sexp_string_data(x), sexp_string_data(y));
|
||||||
if (sexp_unbox_string_cursor(start) > sexp_string_size(x))
|
return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE;
|
||||||
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;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
|
static 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;
|
unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
|
||||||
sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
|
sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
|
||||||
start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
|
start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
|
||||||
|
@ -558,9 +451,9 @@ sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp
|
||||||
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
|
||||||
if (from < 0 || from > to)
|
if (from < 0 || from > to)
|
||||||
return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
|
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))
|
if (start < 0 || start > sexp_string_size(src))
|
||||||
return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
|
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))
|
if (end < start || end > sexp_string_size(src))
|
||||||
return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
|
return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
|
||||||
pfrom = (unsigned char*)sexp_string_data(dst) + from;
|
pfrom = (unsigned char*)sexp_string_data(dst) + from;
|
||||||
pto = (unsigned char*)sexp_string_data(dst) + to;
|
pto = (unsigned char*)sexp_string_data(dst) + to;
|
||||||
|
@ -578,7 +471,7 @@ sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp
|
||||||
return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
|
return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
|
static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
|
||||||
#ifdef PLAN9
|
#ifdef PLAN9
|
||||||
return SEXP_FALSE;
|
return SEXP_FALSE;
|
||||||
#else
|
#else
|
||||||
|
@ -586,7 +479,7 @@ sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
|
||||||
#endif
|
#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
|
#ifdef PLAN9
|
||||||
return SEXP_FALSE;
|
return SEXP_FALSE;
|
||||||
#else
|
#else
|
||||||
|
@ -601,22 +494,22 @@ sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||||
#endif
|
#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);
|
return sexp_free_vars(ctx, x, SEXP_NULL);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
|
static sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
|
||||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
|
||||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
|
||||||
return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
|
return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
|
static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
|
||||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
|
||||||
return sexp_make_boolean(unsetenv(sexp_string_data(name)));
|
return sexp_make_boolean(unsetenv(sexp_string_data(name)));
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
|
static sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
|
||||||
sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
|
sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
|
||||||
sexp_exception_message(res) = SEXP_TRAMPOLINE;
|
sexp_exception_message(res) = SEXP_TRAMPOLINE;
|
||||||
return res;
|
return res;
|
||||||
|
@ -626,7 +519,6 @@ sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
|
||||||
sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, 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 sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
|
||||||
sexp_gc_var2(sym, str);
|
|
||||||
if (!(sexp_version_compatible(ctx, version, sexp_version)
|
if (!(sexp_version_compatible(ctx, version, sexp_version)
|
||||||
&& sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
|
&& sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
|
||||||
return SEXP_ABI_ERROR;
|
return SEXP_ABI_ERROR;
|
||||||
|
@ -659,7 +551,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
|
sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
|
||||||
sexp_define_type(ctx, "Cnd", SEXP_CND);
|
sexp_define_type(ctx, "Cnd", SEXP_CND);
|
||||||
sexp_define_type(ctx, "Set", SEXP_SET);
|
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, "Ref", SEXP_REF);
|
||||||
sexp_define_type(ctx, "Seq", SEXP_SEQ);
|
sexp_define_type(ctx, "Seq", SEXP_SEQ);
|
||||||
sexp_define_type(ctx, "Lit", SEXP_LIT);
|
sexp_define_type(ctx, "Lit", SEXP_LIT);
|
||||||
|
@ -677,6 +568,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
|
sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
|
||||||
sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
|
sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
|
||||||
sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
|
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, "type?", SEXP_TYPE);
|
||||||
sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE);
|
sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE);
|
||||||
sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT);
|
sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT);
|
||||||
|
@ -700,28 +592,22 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
|
sexp_define_accessors(ctx, env, SEXP_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, 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, 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, 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_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_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_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, 2, "bytecode-name", "bytecode-name-set!");
|
||||||
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-literals", NULL);
|
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-literals", NULL);
|
||||||
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-source", NULL);
|
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 4, "bytecode-source", NULL);
|
||||||
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
|
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
|
||||||
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL);
|
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL);
|
||||||
sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL);
|
sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL);
|
||||||
sexp_define_accessors(ctx, env, SEXP_MACRO, 1, "macro-env", 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, 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-code", 1, sexp_get_procedure_code);
|
||||||
sexp_define_foreign(ctx, env, "procedure-vars", 1, sexp_get_procedure_vars);
|
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-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-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(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-lambda", 4, sexp_make_lambda_op, SEXP_NULL);
|
||||||
sexp_define_foreign_opt(ctx, env, "make-cnd", 3, sexp_make_cnd_op, SEXP_VOID);
|
sexp_define_foreign_opt(ctx, env, "make-cnd", 3, sexp_make_cnd_op, SEXP_VOID);
|
||||||
|
@ -744,15 +630,12 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
|
sexp_define_foreign(ctx, env, "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", 1, sexp_get_port_line);
|
||||||
sexp_define_foreign(ctx, env, "port-line-set!", 2, sexp_set_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-of", 1, sexp_type_of);
|
||||||
sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op);
|
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-cpl", 1, sexp_type_cpl_op);
|
||||||
sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_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-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", 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-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", 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-lambda-set!", 2, sexp_env_lambda_set_op);
|
||||||
|
@ -762,19 +645,13 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
|
sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
|
||||||
sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
|
sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
|
||||||
sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
|
sexp_define_foreign(ctx, env, "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, "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", 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
|
#if SEXP_USE_GREEN_THREADS
|
||||||
sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
|
sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
|
||||||
#endif
|
#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(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-contains", 2, sexp_string_contains);
|
||||||
sexp_define_foreign(ctx, env, "string-cursor-copy!", 5, sexp_string_cursor_copy);
|
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, "errno", 0, sexp_errno);
|
||||||
sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
|
sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
|
||||||
|
@ -782,11 +659,5 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv);
|
sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv);
|
||||||
sexp_define_foreign(ctx, env, "unsetenv", 1, sexp_unsetenv);
|
sexp_define_foreign(ctx, env, "unsetenv", 1, sexp_unsetenv);
|
||||||
sexp_define_foreign(ctx, env, "abort", 1, sexp_abort);
|
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;
|
return SEXP_VOID;
|
||||||
}
|
}
|
||||||
|
|
|
@ -109,34 +109,6 @@
|
||||||
((opcode? x) (cond ((opcode-name x) => string->symbol) (else x)))
|
((opcode? x) (cond ((opcode-name x) => string->symbol) (else x)))
|
||||||
(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}
|
;;> \section{Types}
|
||||||
|
|
||||||
;;> All objects have an associated type, and types may have parent
|
;;> All objects have an associated type, and types may have parent
|
||||||
|
@ -149,32 +121,32 @@
|
||||||
;;> used in the \scheme{match} \scheme{($ ...)} syntax.
|
;;> used in the \scheme{match} \scheme{($ ...)} syntax.
|
||||||
|
|
||||||
;;> \itemlist[
|
;;> \itemlist[
|
||||||
;;> \item{\scheme{Object} - the parent of all types}
|
;;> \item{\scheme{<object>} - the parent of all types}
|
||||||
;;> \item{\scheme{Number} - abstract numeric type}
|
;;> \item{\scheme{<number>} - abstract numeric type}
|
||||||
;;> \item{\scheme{Bignum} - arbitrary precision exact integers}
|
;;> \item{\scheme{<bignum>} - arbitrary precision exact integers}
|
||||||
;;> \item{\scheme{Flonum} - inexact real numbers}
|
;;> \item{\scheme{<flonum>} - inexact real numbers}
|
||||||
;;> \item{\scheme{Integer} - abstract integer type}
|
;;> \item{\scheme{<integer>} - abstract integer type}
|
||||||
;;> \item{\scheme{Symbol} - symbols}
|
;;> \item{\scheme{<symbol>} - symbols}
|
||||||
;;> \item{\scheme{Char} - character}
|
;;> \item{\scheme{<char>} - character}
|
||||||
;;> \item{\scheme{Boolean} - \scheme{#t} or \scheme{#f}}
|
;;> \item{\scheme{<boolean>} - \scheme{#t} or \scheme{#f}}
|
||||||
;;> \item{\scheme{String} - strings of characters}
|
;;> \item{\scheme{<string>} - strings of characters}
|
||||||
;;> \item{\scheme{Byte-Vector} - uniform vector of octets}
|
;;> \item{\scheme{<byte-vector>} - uniform vector of octets}
|
||||||
;;> \item{\scheme{Pair} - a \var{car} and \var{cdr}, the basis for lists}
|
;;> \item{\scheme{<pair>} - a \var{car} and \var{cdr}, the basis for lists}
|
||||||
;;> \item{\scheme{Vector} - vectors}
|
;;> \item{\scheme{<vector>} - vectors}
|
||||||
;;> \item{\scheme{Opcode} - a primitive opcode or C function}
|
;;> \item{\scheme{<opcode>} - a primitive opcode or C function}
|
||||||
;;> \item{\scheme{Procedure} - a closure}
|
;;> \item{\scheme{<procedure>} - a closure}
|
||||||
;;> \item{\scheme{Bytecode} - the compiled code for a closure}
|
;;> \item{\scheme{<bytecode>} - the compiled code for a closure}
|
||||||
;;> \item{\scheme{Env} - an environment structure}
|
;;> \item{\scheme{<env>} - an environment structure}
|
||||||
;;> \item{\scheme{Macro} - a macro object, usually not first-class}
|
;;> \item{\scheme{<macro>} - a macro object, usually not first-class}
|
||||||
;;> \item{\scheme{Lam} - a lambda AST type}
|
;;> \item{\scheme{<lam>} - a lambda AST type}
|
||||||
;;> \item{\scheme{Cnd} - an conditional AST type (i.e. \scheme{if})}
|
;;> \item{\scheme{<cnd>} - an conditional AST type (i.e. \scheme{if})}
|
||||||
;;> \item{\scheme{Ref} - a reference AST type}
|
;;> \item{\scheme{<ref>} - a reference AST type}
|
||||||
;;> \item{\scheme{Set} - a mutation AST type (i.e. \scheme{set!})}
|
;;> \item{\scheme{<set>} - a mutation AST type (i.e. \scheme{set!})}
|
||||||
;;> \item{\scheme{Seq} - a sequence AST type}
|
;;> \item{\scheme{<seq>} - a sequence AST type}
|
||||||
;;> \item{\scheme{Lit} - a literal AST type}
|
;;> \item{\scheme{<lit>} - a literal AST type}
|
||||||
;;> \item{\scheme{Sc} - a syntactic closure}
|
;;> \item{\scheme{<sc>} - a syntactic closure}
|
||||||
;;> \item{\scheme{Context} - a context object (including threads)}
|
;;> \item{\scheme{<context>} - a context object (including threads)}
|
||||||
;;> \item{\scheme{Exception} - an exception object}
|
;;> \item{\scheme{<exception>} - an exception object}
|
||||||
;;> ]
|
;;> ]
|
||||||
|
|
||||||
;;> The following extended type predicates may also be used to test
|
;;> The following extended type predicates may also be used to test
|
||||||
|
@ -250,8 +222,6 @@
|
||||||
;;> \item{\scheme{(macro-procedure f)} - the macro procedure}
|
;;> \item{\scheme{(macro-procedure f)} - the macro procedure}
|
||||||
;;> \item{\scheme{(macro-env f)} - the environment the macro was defined in}
|
;;> \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-source f)} - the source location the macro was defined in}
|
||||||
;;> \item{\scheme{(macro-aux f)} - custom auxiliary data stored with the macro}
|
|
||||||
;;> \item{\scheme{(macro-aux-set! f x)}}
|
|
||||||
;;> ]
|
;;> ]
|
||||||
|
|
||||||
;;> \subsection{Bytecode Objects}
|
;;> \subsection{Bytecode Objects}
|
||||||
|
@ -381,29 +351,11 @@
|
||||||
;;> Returns the interpretation of the integer \var{n} as
|
;;> Returns the interpretation of the integer \var{n} as
|
||||||
;;> an immediate object, useful for debugging.
|
;;> an immediate object, useful for debugging.
|
||||||
|
|
||||||
;;> \procedure{(string-contains str pat [start])}
|
;;> \procedure{(string-contains str pat)}
|
||||||
|
|
||||||
;;> Returns the first string cursor of \var{pat} in \var{str},
|
;;> Returns the first string cursor of \var{pat} in \var{str},
|
||||||
;;> of \scheme{#f} if it's not found.
|
;;> of \scheme{#f} if it's not found.
|
||||||
|
|
||||||
(cond-expand
|
|
||||||
(safe-string-cursors
|
|
||||||
(define orig-string-contains string-contains)
|
|
||||||
(set! string-contains
|
|
||||||
(lambda (str pat . o)
|
|
||||||
(let ((res
|
|
||||||
(if (pair? o)
|
|
||||||
(orig-string-contains str pat (string-cursor-where (car o)))
|
|
||||||
(orig-string-contains str pat))))
|
|
||||||
(and res (make-string-cursor str res (string-size str)))))))
|
|
||||||
(else
|
|
||||||
))
|
|
||||||
|
|
||||||
;;> \procedure{(string-cursor-copy! dst src from start end)}
|
|
||||||
|
|
||||||
;;> Copies the characters from \var{src}[\var{start}..\var{end}]
|
|
||||||
;;> to \var{dst} starting at \var{from}.
|
|
||||||
|
|
||||||
;;> \procedure{(safe-setenv name value)}
|
;;> \procedure{(safe-setenv name value)}
|
||||||
|
|
||||||
;;> Equivalent to \scheme{setenv} but does nothing and returns
|
;;> Equivalent to \scheme{setenv} but does nothing and returns
|
||||||
|
@ -436,7 +388,3 @@
|
||||||
(else
|
(else
|
||||||
(define-syntax atomically
|
(define-syntax atomically
|
||||||
(syntax-rules () ((atomically . body) (begin . body))))))
|
(syntax-rules () ((atomically . body) (begin . body))))))
|
||||||
|
|
||||||
(define (thread-interrupt! thread)
|
|
||||||
(if (%thread-interrupt! thread)
|
|
||||||
(yield!)))
|
|
||||||
|
|
|
@ -1,12 +1,11 @@
|
||||||
|
|
||||||
(define-library (chibi ast)
|
(define-library (chibi ast)
|
||||||
(export
|
(export
|
||||||
analyze optimize env-cell ast->sexp macroexpand identifier-syntax
|
analyze optimize env-cell ast->sexp macroexpand type-of
|
||||||
type-of
|
|
||||||
Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env
|
Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env
|
||||||
Number Bignum Flonum Integer Complex Char Boolean
|
Number Bignum Flonum Integer Complex Char Boolean
|
||||||
Symbol String Byte-Vector Vector Pair File-Descriptor
|
Symbol String Byte-Vector Vector Pair File-Descriptor
|
||||||
Context Lam Cnd Set Set-Syn Ref Seq Lit Sc Exception Core
|
Context Lam Cnd Set Ref Seq Lit Sc Exception Core
|
||||||
syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core?
|
syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core?
|
||||||
environment? bytecode? exception? macro? context? file-descriptor?
|
environment? bytecode? exception? macro? context? file-descriptor?
|
||||||
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
|
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
|
||||||
|
@ -21,29 +20,23 @@
|
||||||
lambda-source-set!
|
lambda-source-set!
|
||||||
cnd-test cnd-pass cnd-fail
|
cnd-test cnd-pass cnd-fail
|
||||||
cnd-test-set! cnd-pass-set! cnd-fail-set!
|
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!
|
ref-name ref-cell ref-name-set! ref-cell-set!
|
||||||
seq-ls seq-ls-set! lit-value lit-value-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 exception-source
|
||||||
opcode-name opcode-num-params opcode-return-type opcode-param-type
|
opcode-name opcode-num-params opcode-return-type opcode-param-type
|
||||||
opcode-class opcode-code opcode-data opcode-variadic? opcode?
|
opcode-class opcode-code opcode-data opcode-variadic?
|
||||||
macro-procedure macro-env macro-source macro-aux macro-aux-set!
|
macro-procedure macro-env macro-source
|
||||||
procedure-code procedure-vars procedure-name procedure-name-set!
|
procedure-code procedure-vars procedure-name procedure-name-set!
|
||||||
procedure-arity procedure-variadic? procedure-variable-transformer?
|
procedure-arity procedure-variadic?
|
||||||
procedure-flags make-variable-transformer make-procedure procedure?
|
|
||||||
bytecode-name bytecode-literals bytecode-source
|
bytecode-name bytecode-literals bytecode-source
|
||||||
port-line port-line-set! port-source? port-source?-set!
|
port-line port-line-set!
|
||||||
extend-env env-parent env-parent-set! env-lambda env-lambda-set!
|
extend-env env-parent env-parent-set! env-lambda env-lambda-set!
|
||||||
env-define! env-push! env-syntactic? env-syntactic?-set! core-code
|
env-define! env-push! env-syntactic? env-syntactic?-set! core-code
|
||||||
type-name type-cpl type-parent type-slots type-num-slots
|
type-name type-cpl type-parent type-slots type-num-slots type-printer
|
||||||
type-printer type-printer-set!
|
object-size integer->immediate gc atomically thread-list abort
|
||||||
object-size object->integer integer->immediate gc gc-usecs gc-count
|
|
||||||
atomically thread-list abort
|
|
||||||
string-contains string-cursor-copy! errno integer->error-string
|
string-contains string-cursor-copy! errno integer->error-string
|
||||||
flatten-dot update-free-vars! setenv unsetenv safe-setenv
|
flatten-dot update-free-vars! setenv unsetenv safe-setenv)
|
||||||
immutable? immutable-string make-immutable!
|
|
||||||
thread-interrupt!
|
|
||||||
chibi-version)
|
|
||||||
(import (chibi))
|
(import (chibi))
|
||||||
(include-shared "ast")
|
(include-shared "ast")
|
||||||
(include "ast.scm"))
|
(include "ast.scm"))
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
(define-library (chibi base64-test)
|
(define-library (chibi base64-test)
|
||||||
(export run-tests)
|
(export run-tests)
|
||||||
(import (scheme base) (chibi base64) (chibi string) (chibi test))
|
(import (chibi) (chibi base64) (chibi test))
|
||||||
(begin
|
(begin
|
||||||
(define (run-tests)
|
(define (run-tests)
|
||||||
(test-begin "base64")
|
(test-begin "base64")
|
||||||
|
|
|
@ -141,18 +141,18 @@
|
||||||
dst
|
dst
|
||||||
j
|
j
|
||||||
(bitwise-ior (arithmetic-shift b1 2)
|
(bitwise-ior (arithmetic-shift b1 2)
|
||||||
(bit-field b2 4 6)))
|
(extract-bit-field 2 4 b2)))
|
||||||
(bytevector-u8-set!
|
(bytevector-u8-set!
|
||||||
dst
|
dst
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(bitwise-ior
|
(bitwise-ior
|
||||||
(arithmetic-shift (bit-field b2 0 4) 4)
|
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
|
||||||
(bit-field b3 2 6)))
|
(extract-bit-field 4 2 b3)))
|
||||||
(bytevector-u8-set!
|
(bytevector-u8-set!
|
||||||
dst
|
dst
|
||||||
(+ j 2)
|
(+ j 2)
|
||||||
(bitwise-ior
|
(bitwise-ior
|
||||||
(arithmetic-shift (bit-field b3 0 2) 6)
|
(arithmetic-shift (extract-bit-field 2 0 b3) 6)
|
||||||
c))
|
c))
|
||||||
(lp (+ i 1) (+ j 3)
|
(lp (+ i 1) (+ j 3)
|
||||||
*outside-char* *outside-char* *outside-char*)))))))
|
*outside-char* *outside-char* *outside-char*)))))))
|
||||||
|
@ -172,7 +172,7 @@
|
||||||
(bytevector-u8-set! dst
|
(bytevector-u8-set! dst
|
||||||
j
|
j
|
||||||
(bitwise-ior (arithmetic-shift b1 2)
|
(bitwise-ior (arithmetic-shift b1 2)
|
||||||
(bit-field b2 4 6)))
|
(extract-bit-field 2 4 b2)))
|
||||||
(cond
|
(cond
|
||||||
((eqv? b3 *outside-char*)
|
((eqv? b3 *outside-char*)
|
||||||
(+ j 1))
|
(+ j 1))
|
||||||
|
@ -180,8 +180,8 @@
|
||||||
(bytevector-u8-set! dst
|
(bytevector-u8-set! dst
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(bitwise-ior
|
(bitwise-ior
|
||||||
(arithmetic-shift (bit-field b2 0 4) 4)
|
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
|
||||||
(bit-field b3 2 6)))
|
(extract-bit-field 4 2 b3)))
|
||||||
(+ j 2))))))
|
(+ j 2))))))
|
||||||
|
|
||||||
;;> Variation of the above to read and write to ports.
|
;;> Variation of the above to read and write to ports.
|
||||||
|
@ -193,15 +193,14 @@
|
||||||
(current-output-port))))
|
(current-output-port))))
|
||||||
(cond
|
(cond
|
||||||
((not (binary-port? in))
|
((not (binary-port? in))
|
||||||
(let ((str (port->string in)))
|
(write-string (base64-decode-string (port->string in)) out))
|
||||||
(write-string (base64-decode-string str) out)))
|
|
||||||
(else
|
(else
|
||||||
(let ((src (make-bytevector decode-src-length))
|
(let ((src (make-bytevector decode-src-length))
|
||||||
(dst (make-bytevector decode-dst-length)))
|
(dst (make-bytevector decode-dst-length)))
|
||||||
(let lp ((offset 0))
|
(let lp ((offset 0))
|
||||||
(let ((src-len
|
(let ((src-len
|
||||||
(+ offset
|
(+ offset
|
||||||
(read-bytevector! src in offset decode-src-length))))
|
(read-bytevector! decode-src-length src in offset))))
|
||||||
(cond
|
(cond
|
||||||
((= src-len decode-src-length)
|
((= src-len decode-src-length)
|
||||||
;; read a full chunk: decode, write and loop
|
;; read a full chunk: decode, write and loop
|
||||||
|
@ -210,12 +209,12 @@
|
||||||
(lambda (src-offset dst-len b1 b2 b3)
|
(lambda (src-offset dst-len b1 b2 b3)
|
||||||
(cond
|
(cond
|
||||||
((and (< src-offset src-len)
|
((and (< src-offset src-len)
|
||||||
(eqv? #x3D (bytevector-u8-ref src src-offset)))
|
(eqv? #\= (string-ref src src-offset)))
|
||||||
;; done
|
;; done
|
||||||
(let ((dst-len (base64-decode-finish dst 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-bytevector dst out 0 dst-len)))
|
||||||
((eqv? b1 *outside-char*)
|
((eqv? b1 *outside-char*)
|
||||||
(write-bytevector dst out 0 dst-len)
|
(write-string dst out 0 dst-len)
|
||||||
(lp 0))
|
(lp 0))
|
||||||
(else
|
(else
|
||||||
(write-bytevector dst out 0 dst-len)
|
(write-bytevector dst out 0 dst-len)
|
||||||
|
@ -238,7 +237,7 @@
|
||||||
src 0 src-len dst
|
src 0 src-len dst
|
||||||
(lambda (src-offset dst-len b1 b2 b3)
|
(lambda (src-offset dst-len b1 b2 b3)
|
||||||
(let ((dst-len (base64-decode-finish dst 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
|
;; encoding
|
||||||
|
@ -259,7 +258,8 @@
|
||||||
res))
|
res))
|
||||||
|
|
||||||
(define (base64-encode-bytevector! bv start end res)
|
(define (base64-encode-bytevector! bv start end res)
|
||||||
(let ((limit (- end 2)))
|
(let* ((res-len (bytevector-length res))
|
||||||
|
(limit (- end 2)))
|
||||||
(let lp ((i start) (j 0))
|
(let lp ((i start) (j 0))
|
||||||
(if (>= i limit)
|
(if (>= i limit)
|
||||||
(case (- end i)
|
(case (- end i)
|
||||||
|
@ -271,8 +271,7 @@
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
|
(enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
|
||||||
(bytevector-u8-set! res (+ j 2) (char->integer #\=))
|
(bytevector-u8-set! res (+ j 2) (char->integer #\=))
|
||||||
(bytevector-u8-set! res (+ j 3) (char->integer #\=))
|
(bytevector-u8-set! res (+ j 3) (char->integer #\=))))
|
||||||
(+ j 4)))
|
|
||||||
((2)
|
((2)
|
||||||
(let ((b1 (bytevector-u8-ref bv i))
|
(let ((b1 (bytevector-u8-ref bv i))
|
||||||
(b2 (bytevector-u8-ref bv (+ i 1))))
|
(b2 (bytevector-u8-ref bv (+ i 1))))
|
||||||
|
@ -282,15 +281,13 @@
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(enc (bitwise-ior
|
(enc (bitwise-ior
|
||||||
(arithmetic-shift (bitwise-and #b11 b1) 4)
|
(arithmetic-shift (bitwise-and #b11 b1) 4)
|
||||||
(bit-field b2 4 8))))
|
(extract-bit-field 4 4 b2))))
|
||||||
(bytevector-u8-set!
|
(bytevector-u8-set!
|
||||||
res
|
res
|
||||||
(+ j 2)
|
(+ j 2)
|
||||||
(enc (arithmetic-shift (bit-field b2 0 4) 2)))
|
(enc (arithmetic-shift (extract-bit-field 4 0 b2)
|
||||||
(bytevector-u8-set! res (+ j 3) (char->integer #\=))
|
2)))
|
||||||
(+ j 4)))
|
(bytevector-u8-set! res (+ j 3) (char->integer #\=)))))
|
||||||
(else
|
|
||||||
j))
|
|
||||||
(let ((b1 (bytevector-u8-ref bv i))
|
(let ((b1 (bytevector-u8-ref bv i))
|
||||||
(b2 (bytevector-u8-ref bv (+ i 1)))
|
(b2 (bytevector-u8-ref bv (+ i 1)))
|
||||||
(b3 (bytevector-u8-ref bv (+ i 2))))
|
(b3 (bytevector-u8-ref bv (+ i 2))))
|
||||||
|
@ -300,13 +297,13 @@
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(enc (bitwise-ior
|
(enc (bitwise-ior
|
||||||
(arithmetic-shift (bitwise-and #b11 b1) 4)
|
(arithmetic-shift (bitwise-and #b11 b1) 4)
|
||||||
(bit-field b2 4 8))))
|
(extract-bit-field 4 4 b2))))
|
||||||
(bytevector-u8-set!
|
(bytevector-u8-set!
|
||||||
res
|
res
|
||||||
(+ j 2)
|
(+ j 2)
|
||||||
(enc (bitwise-ior
|
(enc (bitwise-ior
|
||||||
(arithmetic-shift (bit-field b2 0 4) 2)
|
(arithmetic-shift (extract-bit-field 4 0 b2) 2)
|
||||||
(bit-field b3 6 8))))
|
(extract-bit-field 2 6 b3))))
|
||||||
(bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
|
(bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
|
||||||
(lp (+ i 3) (+ j 4)))))))
|
(lp (+ i 3) (+ j 4)))))))
|
||||||
|
|
||||||
|
@ -319,19 +316,17 @@
|
||||||
(current-output-port))))
|
(current-output-port))))
|
||||||
(cond
|
(cond
|
||||||
((not (binary-port? in))
|
((not (binary-port? in))
|
||||||
(let ((str (port->string in)))
|
(write-string (base64-encode-string (port->string in)) out))
|
||||||
(write-string (base64-encode-string str) out)))
|
|
||||||
(else
|
(else
|
||||||
(let ((src (make-bytevector encode-src-length))
|
(let ((src (make-string encode-src-length))
|
||||||
(dst (make-bytevector
|
(dst (make-string
|
||||||
(arithmetic-shift (quotient encode-src-length 3) 2))))
|
(arithmetic-shift (quotient encode-src-length 3) 2))))
|
||||||
(let lp ()
|
(let lp ()
|
||||||
(let ((n (read-bytevector! src in 0 2048)))
|
(let ((n (read-bytevector! src in 0 2048)))
|
||||||
(base64-encode-bytevector! src 0 n dst)
|
(base64-encode-bytevector! src 0 n dst)
|
||||||
(write-bytevector dst out 0 (* 4 (quotient (+ n 2) 3)))
|
(write-bytevector dst out 0 (* 3 (quotient (+ n 3) 4)))
|
||||||
(if (= n 2048)
|
(if (= n 2048)
|
||||||
(lp)
|
(lp)))))))))
|
||||||
(flush-output-port out)))))))))
|
|
||||||
|
|
||||||
;;> Return a base64 encoded representation of the string \var{str} as
|
;;> Return a base64 encoded representation of the string \var{str} as
|
||||||
;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
|
;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
|
||||||
|
@ -364,7 +359,7 @@
|
||||||
(string-append
|
(string-append
|
||||||
prefix (substring str 0 first-max-col) "?=" nl "\t" prefix)
|
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)
|
effective-max-col)
|
||||||
(string-append "?=" nl "\t" prefix))
|
(string-append "?=" nl "\t" prefix))
|
||||||
"?=")))))
|
"?=")))))
|
||||||
|
|
|
@ -3,35 +3,6 @@
|
||||||
(export base64-encode base64-encode-string base64-encode-bytevector
|
(export base64-encode base64-encode-string base64-encode-bytevector
|
||||||
base64-decode base64-decode-string base64-decode-bytevector
|
base64-decode base64-decode-string base64-decode-bytevector
|
||||||
base64-encode-header)
|
base64-encode-header)
|
||||||
(import (scheme base)
|
(import (scheme base) (srfi 33) (chibi io)
|
||||||
(chibi string))
|
(only (chibi) string-concatenate))
|
||||||
(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))))))))))
|
|
||||||
(include "base64.scm"))
|
(include "base64.scm"))
|
||||||
|
|
|
@ -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
|
|
||||||
() ()))))
|
|
|
@ -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))))
|
|
|
@ -1,160 +1,300 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(define (read-u16/be in)
|
||||||
;; Binary Records
|
(let* ((i (read-u8 in))
|
||||||
|
(j (read-u8 in)))
|
||||||
|
(if (eof-object? j)
|
||||||
|
(error "end of input")
|
||||||
|
(+ (arithmetic-shift i 8) j))))
|
||||||
|
|
||||||
;;> \macro{(define-binary-record-type <name> [<bindings> ...] (block: <fields> ...))}
|
(define (read-u16/le in)
|
||||||
;;>
|
(let* ((i (read-u8 in))
|
||||||
;;> Defines a new record type that supports serializing to and from
|
(j (read-u8 in)))
|
||||||
;;> binary ports. The generated procedures accept keyword-style
|
(if (eof-object? j)
|
||||||
;;> arguments:
|
(error "end of input")
|
||||||
;;>
|
(+ (arithmetic-shift j 8) i))))
|
||||||
;;> \itemlist[
|
|
||||||
;;> \item{\scheme{(make: <constructor-name>)}}
|
;; Record types with user-specified binary formats.
|
||||||
;;> \item{\scheme{(pred: <predicate-name>)}}
|
;; A work in progress, but sufficient for tar files.
|
||||||
;;> \item{\scheme{(read: <reader-name>)}}
|
|
||||||
;;> \item{\scheme{(write: <writer-name>)}}
|
(define (assert-read-u8 in i)
|
||||||
;;> \item{\scheme{(block: <fields> ...)}}
|
(let ((i2 (read-u8 in)))
|
||||||
;;> ]
|
(if (not (eqv? i i2))
|
||||||
;;>
|
(error "unexpected value: " i i2)
|
||||||
;;> The fields are also similar to \scheme{define-record-type} but
|
i2)))
|
||||||
;;> with an additional type:
|
|
||||||
;;>
|
(define (assert-read-char in ch)
|
||||||
;;> \scheme{(field (type args ...) getter setter)}
|
(let ((ch2 (read-char in)))
|
||||||
;;>
|
(if (not (eqv? ch ch2))
|
||||||
;;> Built-in types include:
|
(error "unexpected value: " ch ch2)
|
||||||
;;>
|
ch2)))
|
||||||
;;> \itemlist[
|
|
||||||
;;> \item{\scheme{(u8)} - a single byte in [0, 255]}
|
(define (assert-read-string in s)
|
||||||
;;> \item{\scheme{(u16/le)} - a little-endian short integer}
|
(let ((s2 (read-string (string-length s) in)))
|
||||||
;;> \item{\scheme{(u16/be)} - a big-endian short integer}
|
(if (not (equal? s s2))
|
||||||
;;> \item{\scheme{(fixed-string <length>)} - a fixed-length utf-8 string}
|
(error "unexpected value: " s s2)
|
||||||
;;> \item{\scheme{(padded-string <length> (pad <pad-char>))} - a utf-8 string padded to a given length}
|
s2)))
|
||||||
;;> \item{\scheme{(octal <length>)} - an integer in octal string format}
|
|
||||||
;;> \item{\scheme{(decimal <length>)} - an integer in decimal string format}
|
(define (assert-read-bytevector in bv)
|
||||||
;;> \item{\scheme{(hexadecimal <length>)} - an integer in hexadecimal string format}
|
(let ((bv2 (read-bytevector (bytevector-length bv) in)))
|
||||||
;;> ]
|
(if (not (equal? bv bv2))
|
||||||
;;>
|
(error "unexpected value: " bv bv2)
|
||||||
;;> In addition, the field can be a literal (char, string or
|
bv2)))
|
||||||
;;> bytevector), for instance as a file magic sequence or fixed
|
|
||||||
;;> separator. The fields (and any constants) are serialized in the
|
(define (assert-read-integer in len radix)
|
||||||
;;> order they appear in the block. For example, the header of a GIF
|
(let* ((s (string-trim (read-string len in)
|
||||||
;;> file could be defined as:
|
(lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
|
||||||
;;>
|
(n (if (equal? s "") 0 (string->number s radix))))
|
||||||
;;> \example{
|
(or n (error "invalid number syntax: " s))))
|
||||||
;;> (define-binary-record-type gif-header
|
|
||||||
;;> (make: make-gif-header)
|
(define (read-padded-string in len pad)
|
||||||
;;> (pred: gif-header?)
|
(string-trim-right (read-string len in) pad))
|
||||||
;;> (read: read-gif-header)
|
|
||||||
;;> (write: write-gif-header)
|
(define (expand-read rename in spec)
|
||||||
;;> (block:
|
(case (car spec)
|
||||||
;;> "GIF89a"
|
((literal)
|
||||||
;;> (width (u16/le) gif-header-width)
|
(let ((val (cadr spec)))
|
||||||
;;> (height (u16/le) gif-header-height)
|
(cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
|
||||||
;;> (gct (u8) gif-header-gct)
|
((char? val) `(,(rename 'assert-read-char) ,in ,val))
|
||||||
;;> (bgcolor (u8) gif-header-gbcolor)
|
((string? val) `(,(rename 'assert-read-string) ,in ,val))
|
||||||
;;> (aspect-ratio (u8) gif-header-aspect-ratio)
|
((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
|
||||||
;;> ))
|
(else (error "unknown binary literal: " val)))))
|
||||||
;;> }
|
((u8)
|
||||||
;;>
|
`(,(rename 'read-u8) ,in))
|
||||||
;;> For a more complex example see the \scheme{(chibi tar)}
|
((u16/be)
|
||||||
;;> implementation.
|
`(,(rename 'read-u16/be) ,in))
|
||||||
;;>
|
((u16/le)
|
||||||
;;> The binary type itself is a macro used to expand to a predicate
|
`(,(rename 'read-u16/le) ,in))
|
||||||
;;> and reader/writer procedures, which can be defined with
|
((octal)
|
||||||
;;> \scheme{define-binary-type}. For example,
|
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
|
||||||
;;>
|
((decimal)
|
||||||
;;> \example{
|
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
|
||||||
;;> (define-binary-type (u8)
|
((hexadecimal)
|
||||||
;;> (lambda (x) (and (exact-integer? x) (<= 0 x 255)))
|
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
|
||||||
;;> read-u8
|
((fixed-string)
|
||||||
;;> write-u8)
|
(let ((len (cadr spec)))
|
||||||
;;> }
|
`(,(rename 'read-string) ,len ,in)))
|
||||||
|
((padded-string)
|
||||||
|
(let ((len (cadr spec))
|
||||||
|
(pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
|
||||||
|
`(,(rename 'read-padded-string) ,in ,len ,pad)))
|
||||||
|
(else
|
||||||
|
(error "unknown binary format: " spec))))
|
||||||
|
|
||||||
|
(define (string-pad-left str len . o)
|
||||||
|
(let ((diff (- len (string-length str)))
|
||||||
|
(pad-ch (if (pair? o) (car o) #\space)))
|
||||||
|
(if (positive? diff)
|
||||||
|
(string-append (make-string diff pad-ch) str)
|
||||||
|
str)))
|
||||||
|
|
||||||
|
(define (string-pad-right str len . o)
|
||||||
|
(let ((diff (- len (string-length str)))
|
||||||
|
(pad-ch (if (pair? o) (car o) #\space)))
|
||||||
|
(if (positive? diff)
|
||||||
|
(string-append str (make-string diff pad-ch))
|
||||||
|
str)))
|
||||||
|
|
||||||
|
(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
|
||||||
|
(let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch)))
|
||||||
|
(cond
|
||||||
|
((>= (string-length s) len)
|
||||||
|
(error "number too large for width" n radix len))
|
||||||
|
(else
|
||||||
|
(write-string s out)
|
||||||
|
(write-char right-pad-ch out)))))
|
||||||
|
|
||||||
|
(define (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))
|
||||||
|
|
||||||
|
(define (expand-write rename out val spec)
|
||||||
|
(let ((_if (rename 'if))
|
||||||
|
(_not (rename 'not))
|
||||||
|
(_let (rename 'let))
|
||||||
|
(_string-length (rename 'string-length))
|
||||||
|
(_write-string (rename 'write-string))
|
||||||
|
(_write-bytevector (rename 'write-bytevector))
|
||||||
|
(_error (rename 'error))
|
||||||
|
(_> (rename '>))
|
||||||
|
(_= (rename '=)))
|
||||||
|
(case (car spec)
|
||||||
|
((literal)
|
||||||
|
(let ((val (cadr spec)))
|
||||||
|
(cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
|
||||||
|
((char? val) `(,(rename 'write-char) ,val ,out))
|
||||||
|
((string? val) `(,_write-string ,val ,out))
|
||||||
|
((bytevector? val) `(,_write-bytevector ,val ,out))
|
||||||
|
(else (error "unknown binary literal: " val)))))
|
||||||
|
((u8)
|
||||||
|
`(,(rename 'write-u8) ,val ,out))
|
||||||
|
((u16/be)
|
||||||
|
`(,(rename 'write-u16/be) ,val ,out))
|
||||||
|
((u16/le)
|
||||||
|
`(,(rename 'write-u16/le) ,val ,out))
|
||||||
|
((octal)
|
||||||
|
`(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
|
||||||
|
((decimal)
|
||||||
|
`(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
|
||||||
|
((hexadecimal)
|
||||||
|
`(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
|
||||||
|
((fixed-string)
|
||||||
|
(let ((len (cadr spec)))
|
||||||
|
`(,_if (,_not (,_= ,len (,_string-length ,val)))
|
||||||
|
(,_error "wrong field length: " ,val ,len)
|
||||||
|
(,_write-string ,val ,out))))
|
||||||
|
((padded-string)
|
||||||
|
(let ((len (cadr spec))
|
||||||
|
(pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
|
||||||
|
`(,_let ((l (,_string-length ,val)))
|
||||||
|
(,_if (,_> l ,len)
|
||||||
|
(,_error "field too large: " ,val ,len)
|
||||||
|
(,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
|
||||||
|
,out)))))
|
||||||
|
(else
|
||||||
|
(error "unknown binary format: " spec)))))
|
||||||
|
|
||||||
|
(define (expand-assert rename spec x v)
|
||||||
|
(let ((_if (rename 'if))
|
||||||
|
(_not (rename 'not))
|
||||||
|
(_error (rename 'error))
|
||||||
|
(_integer? (rename 'integer?))
|
||||||
|
(_string? (rename 'string?))
|
||||||
|
(_string-length (rename 'string-length))
|
||||||
|
(_> (rename '>)))
|
||||||
|
(case (car spec)
|
||||||
|
((literal) #t)
|
||||||
|
((u8 u16/be u16/le octal decimal hexadecimal)
|
||||||
|
`(,_if (,_not (,_integer? ,v))
|
||||||
|
(,_error "expected an integer" ,v)))
|
||||||
|
((fixed-string padded-string)
|
||||||
|
(let ((len (cadr spec)))
|
||||||
|
`(,_if (,_not (,_string? ,v))
|
||||||
|
(,_error "expected a string" ,v)
|
||||||
|
(,_if (,_> (,_string-length ,v) ,len)
|
||||||
|
(,_error "string too long" ,v ,len)))))
|
||||||
|
(else (error "unknown binary format: " spec)))))
|
||||||
|
|
||||||
|
(define (expand-default rename spec)
|
||||||
|
(case (car spec)
|
||||||
|
((literal) (cadr spec))
|
||||||
|
((u8 u16/be u16/le octal decimal hexadecimal) 0)
|
||||||
|
((fixed-string) (make-string (cadr spec) #\space))
|
||||||
|
((padded-string) "")
|
||||||
|
(else (error "unknown binary format: " spec))))
|
||||||
|
|
||||||
|
(define (param-ref ls key . o)
|
||||||
|
(cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
|
||||||
|
|
||||||
|
(define (symbol-append a b)
|
||||||
|
(string->symbol (string-append (symbol->string a) (symbol->string b))))
|
||||||
|
|
||||||
|
(define-record-type Field
|
||||||
|
(make-field name get set raw-set spec)
|
||||||
|
field?
|
||||||
|
(name field-name)
|
||||||
|
(get field-get)
|
||||||
|
(set field-set)
|
||||||
|
(raw-set field-raw-set)
|
||||||
|
(spec field-spec))
|
||||||
|
|
||||||
|
(define (extract-fields type ls)
|
||||||
|
(let lp ((ls ls) (res '()))
|
||||||
|
(cond
|
||||||
|
((null? ls)
|
||||||
|
(reverse res))
|
||||||
|
((not (pair? (car ls)))
|
||||||
|
(lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
|
||||||
|
(else
|
||||||
|
(let* ((name (caar ls))
|
||||||
|
(get (or (param-ref (car ls) 'getter)
|
||||||
|
(and (not (eq? name '_))
|
||||||
|
(symbol-append type (symbol-append '- name)))))
|
||||||
|
(set (or (param-ref (car ls) 'setter)
|
||||||
|
(and (not (eq? name '_))
|
||||||
|
(symbol-append (symbol-append type '-)
|
||||||
|
(symbol-append name '-set!)))))
|
||||||
|
(raw-set (and set (symbol-append '% set)))
|
||||||
|
(spec0 (cadr (car ls)))
|
||||||
|
(spec (if (pair? spec0) spec0 (list spec0))))
|
||||||
|
(lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
|
||||||
|
|
||||||
(define-syntax define-binary-record-type
|
(define-syntax define-binary-record-type
|
||||||
(syntax-rules ()
|
(er-macro-transformer
|
||||||
((define-binary-record-type name x ...)
|
(lambda (expr rename compare)
|
||||||
(defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
|
(let ((name (cadr expr))
|
||||||
() () ()))))
|
(ls (cddr expr)))
|
||||||
|
(if (not (and (identifier? name) (every list? ls)))
|
||||||
(define-syntax defrec
|
(error "invalid syntax: " expr))
|
||||||
(syntax-rules (make: pred: read: write: block:)
|
(let* ((type (or (param-ref ls 'type) (symbol-append 'type- name)))
|
||||||
((defrec () n m p r w
|
(pred (or (param-ref ls 'predicate) (symbol-append name '?)))
|
||||||
((field-tmp field-read field-read-expr field-write field-write-expr field-get) ...)
|
(make (or (param-ref ls 'make) (symbol-append 'make- name)))
|
||||||
((field getter . s) ...)
|
(make-spec (if (pair? make) make (list make)))
|
||||||
(def-setter ...))
|
(%make (rename (symbol-append '% (car make-spec))))
|
||||||
(begin
|
(%%make (rename (symbol-append '%% (car make-spec))))
|
||||||
(define-record-type n (m field ...) p
|
(reader (or (param-ref ls 'read) (symbol-append 'read- name)))
|
||||||
(field getter . s) ...)
|
(writer (or (param-ref ls 'write) (symbol-append 'write- name)))
|
||||||
(define r
|
(block (assq 'block ls))
|
||||||
(let ((field-read field-read-expr) ...)
|
(_begin (rename 'begin))
|
||||||
(lambda (in)
|
(_define (rename 'define))
|
||||||
(let* ((field-tmp (field-read in)) ...)
|
(_define-record-type (rename 'define-record-type))
|
||||||
(m field ...)))))
|
(_let (rename 'let)))
|
||||||
(define w
|
(if (not block)
|
||||||
(let ((field-write field-write-expr) ...)
|
(error "missing binary record block: " expr))
|
||||||
(lambda (x out)
|
(let* ((fields (extract-fields name (cdr block)))
|
||||||
(field-write (field-get x) out) ...)))
|
(named-fields (filter (lambda (f) (not (eq? '_ (field-name f))))
|
||||||
def-setter ...)
|
fields)))
|
||||||
;; workaround for impls which strip hygiene from top-level defs
|
`(,_begin
|
||||||
;; for some reason, works in chicken but not across libraries
|
(,_define ,name ',ls)
|
||||||
;;
|
(,_define-record-type
|
||||||
;; (begin
|
,type (,%%make) ,pred
|
||||||
;; (define-values (n m p getter ... setter ...)
|
,@(map
|
||||||
;; (let ()
|
(lambda (f)
|
||||||
;; (define-record-type n (m field ...) p
|
`(,(field-name f) ,(field-get f) ,(field-raw-set f)))
|
||||||
;; (field getter . s) ...)
|
named-fields))
|
||||||
;; (def setter val) ...
|
,@(map
|
||||||
;; (values (record-rtd n) m p getter ... setter ...)))
|
(lambda (f)
|
||||||
;; (define r
|
`(,_define (,(field-set f) x v)
|
||||||
;; (let ((field-read field-read-expr) ...)
|
,(expand-assert rename (field-spec f) 'x 'v)
|
||||||
;; (lambda (in)
|
(,(field-raw-set f) x v)))
|
||||||
;; (let* ((field-tmp (field-read in)) ...)
|
named-fields)
|
||||||
;; (m field ...)))))
|
(,_define (,%make)
|
||||||
;; (define w
|
(let ((res (,%%make)))
|
||||||
;; (let ((field-write field-write-expr) ...)
|
,@(map
|
||||||
;; (lambda (x out)
|
(lambda (f)
|
||||||
;; (field-write (field-get x) out) ...))))
|
`(,(field-raw-set f)
|
||||||
)
|
res
|
||||||
((defrec ((make: x) . rest) n m p r w b f s)
|
,(expand-default rename (field-spec f))))
|
||||||
(defrec rest n x p r w b f s))
|
named-fields)
|
||||||
((defrec ((pred: x) . rest) n m p r w b f s)
|
res))
|
||||||
(defrec rest n m x r w b f s))
|
(,_define ,make-spec
|
||||||
((defrec ((read: x) . rest) n m p r w b f s)
|
(,_let ((res (,%make)))
|
||||||
(defrec rest n m p x w b f s))
|
,@(map
|
||||||
((defrec ((write: x) . rest) n m p r w b f s)
|
(lambda (x)
|
||||||
(defrec rest n m p r x b f s))
|
(let ((field (find (lambda (f) (eq? x (field-name f)))
|
||||||
((defrec ((block: (field (type . args) getter setter) . fields) . rest) n m p r w b f s)
|
fields)))
|
||||||
(defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w b f s))
|
`(,(field-set field) res ,x)))
|
||||||
((defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w
|
(cdr make-spec))
|
||||||
(b ...) (f ...) (s ...))
|
res))
|
||||||
(defrec ((block: . fields) . rest) n m p r w
|
(,_define (,reader in)
|
||||||
(b ...
|
(,_let ((res (,%make)))
|
||||||
(field read-tmp (type read: args) write-tmp (type write: args) getter))
|
,@(map
|
||||||
(f ...
|
(lambda (f)
|
||||||
(field getter tmp-setter))
|
(if (eq? '_ (field-name f))
|
||||||
(s ...
|
(expand-read rename 'in (field-spec f))
|
||||||
(define setter
|
`(,(field-set f)
|
||||||
(let ((pred? (type pred: args)))
|
res
|
||||||
(lambda (x val)
|
,(expand-read rename 'in (field-spec f)))))
|
||||||
(if (not (pred? val))
|
fields)
|
||||||
(error "invalid val for" 'field val))
|
res))
|
||||||
(tmp-setter x val)))))))
|
(,_define (,writer x out)
|
||||||
((defrec ((block: (field (type . args) getter) . fields) . rest) n m p r w
|
,@(map
|
||||||
(b ...) (f ...) s)
|
(lambda (f)
|
||||||
(defrec ((block: . fields) . rest) n m p r w
|
(expand-write rename
|
||||||
(b ...
|
'out
|
||||||
(field read-tmp (type read: args) write-tmp (type write: args) getter))
|
`(,(field-get f) x)
|
||||||
(f ...
|
(field-spec f)))
|
||||||
(field getter))
|
fields)))))))))
|
||||||
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))
|
|
||||||
))
|
|
||||||
|
|
|
@ -1,46 +1,11 @@
|
||||||
|
|
||||||
(define-library (chibi binary-record)
|
(define-library (chibi binary-record)
|
||||||
(import (scheme base) (srfi 1))
|
(import (scheme base)
|
||||||
|
(srfi 1) (srfi 9)
|
||||||
|
(chibi io) (chibi string)
|
||||||
|
(only (chibi) identifier? er-macro-transformer))
|
||||||
(cond-expand
|
(cond-expand
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
((library (srfi 60)) (import (srfi 60)))
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
(else (import (srfi 33))))
|
||||||
(else (import (srfi 60))))
|
(export define-binary-record-type)
|
||||||
(cond-expand
|
(include "binary-record.scm"))
|
||||||
((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"))))
|
|
||||||
|
|
|
@ -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)))
|
|
|
@ -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))))
|
|
|
@ -33,46 +33,6 @@
|
||||||
(arithmetic-shift (bytevector-u8-ref bv (+ i 2)) 8)
|
(arithmetic-shift (bytevector-u8-ref bv (+ i 2)) 8)
|
||||||
(bytevector-u8-ref bv (+ i 3))))
|
(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}
|
;;> \section{Integer conversion}
|
||||||
|
|
||||||
;;> Convert an unsigned integer \var{n} to a bytevector representing
|
;;> Convert an unsigned integer \var{n} to a bytevector representing
|
||||||
|
|
|
@ -5,37 +5,12 @@
|
||||||
(export
|
(export
|
||||||
bytevector-u16-ref-le bytevector-u16-ref-be
|
bytevector-u16-ref-le bytevector-u16-ref-be
|
||||||
bytevector-u32-ref-le bytevector-u32-ref-be
|
bytevector-u32-ref-le bytevector-u32-ref-be
|
||||||
bytevector-ber-ref bytevector-ber-set!
|
|
||||||
bytevector-pad-left
|
bytevector-pad-left
|
||||||
integer->bytevector bytevector->integer
|
integer->bytevector bytevector->integer
|
||||||
integer->hex-string hex-string->integer
|
integer->hex-string hex-string->integer
|
||||||
bytevector->hex-string hex-string->bytevector
|
bytevector->hex-string hex-string->bytevector)
|
||||||
bytevector-ieee-single-ref
|
(import (scheme base))
|
||||||
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
|
(cond-expand
|
||||||
(big-endian
|
((library (srfi 60)) (import (srfi 60)))
|
||||||
(begin
|
(else (import (srfi 33))))
|
||||||
(define-syntax native-endianness
|
(include "bytevector.scm"))
|
||||||
(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"))))
|
|
||||||
|
|
|
@ -1,42 +1,42 @@
|
||||||
;; char-set:lower-case
|
;; 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
|
;; 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
|
;; char-set:title-case
|
||||||
(define char-set:title-case (immutable-char-set (%make-iset 0 0 0 #f #f)))
|
(define char-set:title-case (immutable-char-set (%make-iset 0 0 0 #f #f)))
|
||||||
|
|
||||||
;; char-set:letter
|
;; 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
|
;; 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
|
;; 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
|
;; 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
|
;; 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
|
;; char-set:digit
|
||||||
(define char-set:digit (immutable-char-set (%make-iset 48 57 #f #f #f)))
|
(define char-set:digit (immutable-char-set (%make-iset 48 57 #f #f #f)))
|
||||||
|
|
||||||
;; char-set:letter+digit
|
;; 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
|
;; 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
|
;; 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
|
;; 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
|
;; 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)))
|
||||||
|
|
||||||
|
|
|
@ -2,11 +2,9 @@
|
||||||
(define (char-set . args)
|
(define (char-set . args)
|
||||||
(list->char-set args))
|
(list->char-set args))
|
||||||
|
|
||||||
(define (ucs-range->char-set start end . o)
|
;; This is a mistake in the SRFI-14 design - end should be inclusive.
|
||||||
(let ((res (make-iset start (- end 1))))
|
(define (ucs-range->char-set start end)
|
||||||
(if (and (pair? o) (pair? (cdr o)))
|
(make-iset start (- end 1)))
|
||||||
(iset-union res (cadr o))
|
|
||||||
res)))
|
|
||||||
|
|
||||||
(define char-set-copy iset-copy)
|
(define char-set-copy iset-copy)
|
||||||
|
|
||||||
|
@ -18,8 +16,8 @@
|
||||||
(define (char-set-for-each proc cset)
|
(define (char-set-for-each proc cset)
|
||||||
(iset-for-each (lambda (i) (proc (integer->char i))) cset))
|
(iset-for-each (lambda (i) (proc (integer->char i))) cset))
|
||||||
|
|
||||||
(define (list->char-set ls . o)
|
(define (list->char-set ls)
|
||||||
(apply list->iset (map char->integer ls) o))
|
(list->iset (map char->integer ls)))
|
||||||
(define (char-set->list cset)
|
(define (char-set->list cset)
|
||||||
(map integer->char (iset->list cset)))
|
(map integer->char (iset->list cset)))
|
||||||
|
|
||||||
|
@ -28,10 +26,10 @@
|
||||||
(define (char-set->string cset)
|
(define (char-set->string cset)
|
||||||
(list->string (char-set->list cset)))
|
(list->string (char-set->list cset)))
|
||||||
|
|
||||||
(define (char-set-adjoin! cset . o)
|
(define (char-set-adjoin! cset ch)
|
||||||
(apply iset-adjoin! cset (map char->integer o)))
|
(iset-adjoin! cset (char->integer ch)))
|
||||||
(define (char-set-adjoin cset . o)
|
(define (char-set-adjoin cset ch)
|
||||||
(apply iset-adjoin cset (map char->integer o)))
|
(iset-adjoin cset (char->integer ch)))
|
||||||
|
|
||||||
(define char-set-union iset-union)
|
(define char-set-union iset-union)
|
||||||
(define char-set-union! iset-union!)
|
(define char-set-union! iset-union!)
|
||||||
|
|
File diff suppressed because one or more lines are too long
|
@ -76,18 +76,13 @@
|
||||||
;;> Returns true iff \var{x} is a config object.
|
;;> Returns true iff \var{x} is a config object.
|
||||||
|
|
||||||
(define-record-type Config
|
(define-record-type Config
|
||||||
(%make-conf alist parent source timestamp)
|
(make-conf alist parent source timestamp)
|
||||||
conf?
|
conf?
|
||||||
(alist conf-alist conf-alist-set!)
|
(alist conf-alist conf-alist-set!)
|
||||||
(parent conf-parent conf-parent-set!)
|
(parent conf-parent conf-parent-set!)
|
||||||
(source conf-source conf-source-set!)
|
(source conf-source conf-source-set!)
|
||||||
(timestamp conf-timestamp conf-timestamp-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)
|
(define (assq-tail key alist)
|
||||||
(let lp ((ls alist))
|
(let lp ((ls alist))
|
||||||
(and (pair? ls)
|
(and (pair? ls)
|
||||||
|
@ -111,12 +106,7 @@
|
||||||
(else (lp (cdr ls) (cons (car ls) rev))))))
|
(else (lp (cdr ls) (cons (car ls) rev))))))
|
||||||
|
|
||||||
(define (read-from-file file . opt)
|
(define (read-from-file file . opt)
|
||||||
(guard (exn
|
(guard (exn (else (and (pair? opt) (car opt))))
|
||||||
(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)))
|
(call-with-input-file file read)))
|
||||||
|
|
||||||
(define (alist? x)
|
(define (alist? x)
|
||||||
|
@ -461,7 +451,7 @@
|
||||||
(every* (lambda (x)
|
(every* (lambda (x)
|
||||||
(and (pair? x)
|
(and (pair? x)
|
||||||
(conf-verify-match key-def (car x) warn)
|
(conf-verify-match key-def (car x) warn)
|
||||||
(conf-verify-match val-def (cell-value) warn)))
|
(conf-verify-match val-def (cell-value x) warn)))
|
||||||
(cell-list)))))
|
(cell-list)))))
|
||||||
((conf)
|
((conf)
|
||||||
(and (alist? (cell-list))
|
(and (alist? (cell-list))
|
||||||
|
|
|
@ -10,18 +10,6 @@
|
||||||
;; This is only used for config verification, it's acceptable to
|
;; This is only used for config verification, it's acceptable to
|
||||||
;; substitute file existence for the stronger directory check.
|
;; substitute file existence for the stronger directory check.
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(chibi
|
(chibi (import (only (chibi filesystem) file-directory?)))
|
||||||
(import (only (meta) warn))
|
(else (begin (define file-directory? file-exists?))))
|
||||||
(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"))
|
(include "config.scm"))
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
(define-library (chibi crypto md5-test)
|
(define-library (chibi crypto md5-test)
|
||||||
(export run-tests)
|
(export run-tests)
|
||||||
(import (scheme base) (chibi crypto md5) (chibi test))
|
(import (chibi) (chibi crypto md5) (chibi test))
|
||||||
(begin
|
(begin
|
||||||
(define (run-tests)
|
(define (run-tests)
|
||||||
(test-begin "md5")
|
(test-begin "md5")
|
||||||
|
|
|
@ -5,8 +5,7 @@
|
||||||
(define-library (chibi crypto md5)
|
(define-library (chibi crypto md5)
|
||||||
(import (scheme base) (chibi bytevector))
|
(import (scheme base) (chibi bytevector))
|
||||||
(cond-expand
|
(cond-expand
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
((library (srfi 60)) (import (srfi 60)))
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
(else (import (srfi 33))))
|
||||||
(else (import (srfi 60))))
|
|
||||||
(export md5)
|
(export md5)
|
||||||
(include "md5.scm"))
|
(include "md5.scm"))
|
||||||
|
|
|
@ -6,28 +6,23 @@
|
||||||
(chibi test))
|
(chibi test))
|
||||||
(begin
|
(begin
|
||||||
(define (run-tests)
|
(define (run-tests)
|
||||||
|
|
||||||
(define (test-key key)
|
|
||||||
(test #t (rsa-key? key))
|
|
||||||
(test #t (positive? (rsa-key-n key)))
|
|
||||||
(test #t (positive? (rsa-key-e key)))
|
|
||||||
(test #t (positive? (rsa-key-d key)))
|
|
||||||
(test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
|
|
||||||
|
|
||||||
(test-begin "rsa")
|
(test-begin "rsa")
|
||||||
|
|
||||||
;; Verify an explicit key.
|
;; Verify an explicit key.
|
||||||
|
|
||||||
;; p = 61, q = 53
|
;; p = 61, q = 53
|
||||||
(let* ((priv-key (rsa-key-gen-from-primes 8 61 53))
|
(define priv-key (rsa-key-gen-from-primes 8 61 53))
|
||||||
(pub-key (rsa-pub-key priv-key)))
|
(define pub-key (rsa-pub-key priv-key))
|
||||||
|
|
||||||
(test 439 (rsa-sign priv-key 42))
|
(test 439 (rsa-sign priv-key 42))
|
||||||
(test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
|
(test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
|
||||||
(let ((msg 42))
|
|
||||||
(test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg)))))
|
|
||||||
|
|
||||||
(let* ((priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
|
(let ((msg 42))
|
||||||
(pub-key2 (rsa-pub-key priv-key2)))
|
(test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg))))
|
||||||
|
|
||||||
|
(define priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
|
||||||
|
(define pub-key2 (rsa-pub-key priv-key2))
|
||||||
|
|
||||||
(let ((msg 42))
|
(let ((msg 42))
|
||||||
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
|
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
|
||||||
|
|
||||||
|
@ -41,10 +36,17 @@
|
||||||
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
|
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
|
||||||
|
|
||||||
(let ((msg #u8(42)))
|
(let ((msg #u8(42)))
|
||||||
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg)))))
|
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
|
||||||
|
|
||||||
;; Key generation.
|
;; Key generation.
|
||||||
|
|
||||||
|
(define (test-key key)
|
||||||
|
(test #t (rsa-key? key))
|
||||||
|
(test #t (positive? (rsa-key-n key)))
|
||||||
|
(test #t (positive? (rsa-key-e key)))
|
||||||
|
(test #t (positive? (rsa-key-d key)))
|
||||||
|
(test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
|
||||||
|
|
||||||
(test-key (rsa-key-gen 8))
|
(test-key (rsa-key-gen 8))
|
||||||
(test-key (rsa-key-gen 16))
|
(test-key (rsa-key-gen 16))
|
||||||
(test-key (rsa-key-gen 32))
|
(test-key (rsa-key-gen 32))
|
||||||
|
|
|
@ -5,9 +5,8 @@
|
||||||
(import (scheme base) (srfi 27)
|
(import (scheme base) (srfi 27)
|
||||||
(chibi bytevector) (chibi math prime))
|
(chibi bytevector) (chibi math prime))
|
||||||
(cond-expand
|
(cond-expand
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
((library (srfi 60)) (import (srfi 60)))
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
(else (import (srfi 33))))
|
||||||
(else (import (srfi 60))))
|
|
||||||
(export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key
|
(export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key
|
||||||
rsa-encrypt rsa-decrypt rsa-sign rsa-verify rsa-verify?
|
rsa-encrypt rsa-decrypt rsa-sign rsa-verify rsa-verify?
|
||||||
rsa-key? rsa-key-bits rsa-key-n rsa-key-e rsa-key-d
|
rsa-key? rsa-key-bits rsa-key-n rsa-key-e rsa-key-d
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
(define-library (chibi crypto sha2-test)
|
(define-library (chibi crypto sha2-test)
|
||||||
(export run-tests)
|
(export run-tests)
|
||||||
(import (scheme base) (chibi crypto sha2) (chibi test))
|
(import (chibi) (chibi io) (chibi crypto sha2) (chibi test))
|
||||||
(begin
|
(begin
|
||||||
(define (run-tests)
|
(define (run-tests)
|
||||||
(test-begin "sha2")
|
(test-begin "sha2")
|
||||||
|
|
|
@ -11,9 +11,8 @@
|
||||||
(include-shared "crypto"))
|
(include-shared "crypto"))
|
||||||
(else
|
(else
|
||||||
(cond-expand
|
(cond-expand
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
((library (srfi 60)) (import (srfi 60)))
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
(else (import (srfi 33))))
|
||||||
(else (import (srfi 60))))
|
|
||||||
(import (chibi bytevector))
|
(import (chibi bytevector))
|
||||||
(include "sha2.scm"))))
|
(include "sha2.scm"))))
|
||||||
|
|
||||||
|
|
|
@ -1,98 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi csv-test)
|
|
||||||
(import (scheme base)
|
|
||||||
(srfi 227)
|
|
||||||
(chibi csv)
|
|
||||||
(chibi test))
|
|
||||||
(export run-tests)
|
|
||||||
(begin
|
|
||||||
(define string->csv
|
|
||||||
(opt-lambda (str (reader (csv-read->list)))
|
|
||||||
(reader (open-input-string str))))
|
|
||||||
(define csv->string
|
|
||||||
(opt-lambda (row (writer (csv-writer)))
|
|
||||||
(let ((out (open-output-string)))
|
|
||||||
(writer row out)
|
|
||||||
(get-output-string out))))
|
|
||||||
(define (run-tests)
|
|
||||||
(test-begin "(chibi csv)")
|
|
||||||
(test-assert (eof-object? (string->csv "")))
|
|
||||||
(test '("1997" "Ford" "E350")
|
|
||||||
(string->csv "1997,Ford,E350"))
|
|
||||||
(test '("1997" "Ford" "E350")
|
|
||||||
(string->csv "\n1997,Ford,E350"))
|
|
||||||
(test '(" ")
|
|
||||||
(string->csv " \n1997,Ford,E350"))
|
|
||||||
(test '("" "")
|
|
||||||
(string->csv ",\n1997,Ford,E350"))
|
|
||||||
(test '("1997" "Ford" "E350")
|
|
||||||
(string->csv "\"1997\",\"Ford\",\"E350\""))
|
|
||||||
(test '("1997" "Ford" "E350" "Super, luxurious truck")
|
|
||||||
(string->csv "1997,Ford,E350,\"Super, luxurious truck\""))
|
|
||||||
(test '("1997" "Ford" "E350" "Super, \"luxurious\" truck")
|
|
||||||
(string->csv "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\""))
|
|
||||||
(test '("1997" "Ford" "E350" "Go get one now\nthey are going fast")
|
|
||||||
(string->csv "1997,Ford,E350,\"Go get one now
|
|
||||||
they are going fast\""))
|
|
||||||
(test '("1997" "Ford" "E350")
|
|
||||||
(string->csv
|
|
||||||
"# this is a comment\n1997,Ford,E350"
|
|
||||||
(csv-read->list
|
|
||||||
(csv-parser (csv-grammar '((comment-chars #\#)))))))
|
|
||||||
(let ((parser (csv-parser (csv-grammar '((quote-non-numeric? . #t))))))
|
|
||||||
(test-error (string->csv "1997,\"Ford\",E350" (csv-read->list parser)))
|
|
||||||
(test '(1997 "Ford" "E350")
|
|
||||||
(string->csv "1997,\"Ford\",\"E350\"" (csv-read->list parser))))
|
|
||||||
(test '("1997" "Fo\"rd" "E3\"50")
|
|
||||||
(string->csv "1997\tFo\"rd\tE3\"50"
|
|
||||||
(csv-read->list (csv-parser default-tsv-grammar))))
|
|
||||||
(test '#("1997" "Ford" "E350")
|
|
||||||
(string->csv "1997,Ford,E350" (csv-read->vector)))
|
|
||||||
(test '#("1997" "Ford" "E350")
|
|
||||||
(string->csv "1997,Ford,E350" (csv-read->fixed-vector 3)))
|
|
||||||
(test-error
|
|
||||||
(string->csv "1997,Ford,E350" (csv-read->fixed-vector 2)))
|
|
||||||
(let ((city-csv "Los Angeles,34°03′N,118°15′W
|
|
||||||
New York City,40°42′46″N,74°00′21″W
|
|
||||||
Paris,48°51′24″N,2°21′03″E"))
|
|
||||||
(test '(*TOP*
|
|
||||||
(row (col-0 "Los Angeles")
|
|
||||||
(col-1 "34°03′N")
|
|
||||||
(col-2 "118°15′W"))
|
|
||||||
(row (col-0 "New York City")
|
|
||||||
(col-1 "40°42′46″N")
|
|
||||||
(col-2 "74°00′21″W"))
|
|
||||||
(row (col-0 "Paris")
|
|
||||||
(col-1 "48°51′24″N")
|
|
||||||
(col-2 "2°21′03″E")))
|
|
||||||
((csv->sxml) (open-input-string city-csv)))
|
|
||||||
(test '(*TOP*
|
|
||||||
(city (name "Los Angeles")
|
|
||||||
(latitude "34°03′N")
|
|
||||||
(longitude "118°15′W"))
|
|
||||||
(city (name "New York City")
|
|
||||||
(latitude "40°42′46″N")
|
|
||||||
(longitude "74°00′21″W"))
|
|
||||||
(city (name "Paris")
|
|
||||||
(latitude "48°51′24″N")
|
|
||||||
(longitude "2°21′03″E")))
|
|
||||||
((csv->sxml 'city '(name latitude longitude))
|
|
||||||
(open-input-string city-csv)))
|
|
||||||
(test 3 (csv-num-rows default-csv-grammar (open-input-string city-csv)))
|
|
||||||
(test 0 (csv-num-rows default-csv-grammar (open-input-string "")))
|
|
||||||
(test 1 (csv-num-rows default-csv-grammar (open-input-string "x"))))
|
|
||||||
(test "1997,Ford,E350\n"
|
|
||||||
(csv->string '("1997" "Ford" "E350")))
|
|
||||||
(test "1997,Ford,E350,\"Super, luxurious truck\"\n"
|
|
||||||
(csv->string '("1997" "Ford" "E350" "Super, luxurious truck")))
|
|
||||||
(test "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\"\n"
|
|
||||||
(csv->string '("1997" "Ford" "E350" "Super, \"luxurious\" truck")))
|
|
||||||
(test "1997,Ford,E350,\"Go get one now\nthey are going fast\"\n"
|
|
||||||
(csv->string
|
|
||||||
'("1997" "Ford" "E350" "Go get one now\nthey are going fast")))
|
|
||||||
(test "1997,Ford,E350\n"
|
|
||||||
(csv->string '(1997 "Ford" E350)))
|
|
||||||
(test "1997,\"Ford\",\"E350\"\n"
|
|
||||||
(csv->string '(1997 "Ford" E350)
|
|
||||||
(csv-writer (csv-grammar '((quote-non-numeric? . #t))))))
|
|
||||||
(test-end))))
|
|
|
@ -1,498 +0,0 @@
|
||||||
|
|
||||||
;;> \section{CSV Grammars}
|
|
||||||
|
|
||||||
;;> CSV is a simple and compact format for tabular data, which has
|
|
||||||
;;> made it popular for a variety of tasks since the early days of
|
|
||||||
;;> computing. Unfortunately, there are many incompatible dialects
|
|
||||||
;;> requiring a grammar to specify all of the different options.
|
|
||||||
|
|
||||||
(define-record-type Csv-Grammar
|
|
||||||
(make-csv-grammar separator-chars quote-char quote-doubling-escapes? escape-char record-separator comment-chars quote-non-numeric?)
|
|
||||||
csv-grammar?
|
|
||||||
(separator-chars csv-grammar-separator-chars csv-grammar-separator-chars-set!)
|
|
||||||
(quote-char csv-grammar-quote-char csv-grammar-quote-char-set!)
|
|
||||||
(quote-doubling-escapes? csv-grammar-quote-doubling-escapes? csv-grammar-quote-doubling-escapes?-set!)
|
|
||||||
(escape-char csv-grammar-escape-char csv-grammar-escape-char-set!)
|
|
||||||
(record-separator csv-grammar-record-separator csv-grammar-record-separator-set!)
|
|
||||||
(comment-chars csv-grammar-comment-chars csv-grammar-comment-chars-set!)
|
|
||||||
(quote-non-numeric? csv-grammar-quote-non-numeric? csv-grammar-quote-non-numeric?-set!))
|
|
||||||
|
|
||||||
;; TODO: Other options to consider:
|
|
||||||
;; - strip-leading/trailing-whitespace?
|
|
||||||
;; - newlines-in-quotes?
|
|
||||||
|
|
||||||
;;> Creates a new CSV grammar from the given spec, an alist of symbols
|
|
||||||
;;> to values. The following options are supported:
|
|
||||||
;;>
|
|
||||||
;;> \itemlist[
|
|
||||||
;;> \item{\scheme{'separator-chars} - A non-empty list of characters used to delimit fields, by default \scheme{'(#\\,)} (comma-separated).}
|
|
||||||
;;> \item{\scheme{'quote-char} - A single character used to quote fields containing special characters, or \scheme{#f} to disable quoting, by default \scheme{#\\"} (a double-quote).}
|
|
||||||
;;> \item{\scheme{'quote-doubling-escapes?} - If true, two successive \scheme{quote-char}s within quotes are treated as a single escaped \scheme{quote-char} (default true).}
|
|
||||||
;;> \item{\scheme{'escape-char} - A single character used to escape characters within quoted fields, or \scheme{#f} to disable escapes, by default \scheme{#f} (no explicit escape, use quote doubling).}
|
|
||||||
;;> \item{\scheme{'record-separator} - A single character used to delimit the record (row), or one of the symbols \scheme{'cr}, \scheme{'crlf}, \scheme{'lf} or \scheme{'lax}. These correspond to sequences of carriage return and line feed, or in the case of \scheme{'lax} any of the other three sequences. Defaults to \scheme{'lax}.}
|
|
||||||
;;> \item{\scheme{'comment-chars} - A list of characters which if found at the start of a record indicate it is a comment, discarding all characters through to the next record-separator. Defaults to the empty list (no comments).}
|
|
||||||
;;> ]
|
|
||||||
;;>
|
|
||||||
;;> Example Gecos grammar:
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> (csv-grammar
|
|
||||||
;;> '((separator-chars #\\:)
|
|
||||||
;;> (quote-char . #f)))
|
|
||||||
;;> }
|
|
||||||
(define (csv-grammar spec)
|
|
||||||
(let ((grammar (make-csv-grammar '(#\,) #\" #t #f 'lax '() #f)))
|
|
||||||
(for-each
|
|
||||||
(lambda (x)
|
|
||||||
(case (car x)
|
|
||||||
((separator-chars delimiter)
|
|
||||||
(csv-grammar-separator-chars-set! grammar (cdr x)))
|
|
||||||
((quote-char)
|
|
||||||
(csv-grammar-quote-char-set! grammar (cdr x)))
|
|
||||||
((quote-doubling-escapes?)
|
|
||||||
(csv-grammar-quote-doubling-escapes?-set! grammar (cdr x)))
|
|
||||||
((escape-char)
|
|
||||||
(csv-grammar-escape-char-set! grammar (cdr x)))
|
|
||||||
((record-separator newline-type)
|
|
||||||
(let ((rec-sep
|
|
||||||
(case (cdr x)
|
|
||||||
((crlf lax) (cdr x))
|
|
||||||
((cr) #\return)
|
|
||||||
((lf) #\newline)
|
|
||||||
(else
|
|
||||||
(if (char? (cdr x))
|
|
||||||
(cdr x)
|
|
||||||
(error "invalid record-separator, expected a char or one of 'lax or 'crlf" (cdr x)))))))
|
|
||||||
(csv-grammar-escape-char-set! grammar (cdr x))))
|
|
||||||
((comment-chars)
|
|
||||||
(csv-grammar-comment-chars-set! grammar (cdr x)))
|
|
||||||
((quote-non-numeric?)
|
|
||||||
(csv-grammar-quote-non-numeric?-set! grammar (cdr x)))
|
|
||||||
(else
|
|
||||||
(error "unknown csv-grammar spec" x))))
|
|
||||||
spec)
|
|
||||||
grammar))
|
|
||||||
|
|
||||||
;;> The default CSV grammar for convenience, with all of the defaults
|
|
||||||
;;> from \scheme{csv-grammar}, i.e. comma-delimited with \scheme{#\"}
|
|
||||||
;;> for quoting, doubled to escape.
|
|
||||||
(define default-csv-grammar
|
|
||||||
(csv-grammar '()))
|
|
||||||
|
|
||||||
;;> The default TSV grammar for convenience, splitting fields only on
|
|
||||||
;;> tabs, with no quoting or escaping.
|
|
||||||
(define default-tsv-grammar
|
|
||||||
(csv-grammar '((separator-chars #\tab) (quote-char . #f))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
;;> \section{CSV Parsers}
|
|
||||||
|
|
||||||
;;> Parsers are low-level utilities to perform operations on records a
|
|
||||||
;;> field at a time. You generally want to work with readers, which
|
|
||||||
;;> build on this to build records into familiar data structures.
|
|
||||||
|
|
||||||
;;> Parsers follow the rules of a grammar to parse a single CSV
|
|
||||||
;;> record, possible comprised of multiple fields. A parser is a
|
|
||||||
;;> procedure of three arguments which performs a fold operation over
|
|
||||||
;;> the fields of the record. The parser signature is:
|
|
||||||
;;> \scheme{(parser kons knil in)}, where \scheme{kons} itself is
|
|
||||||
;;> a procedure of three arguments: \scheme{(proc acc index field)}.
|
|
||||||
;;> \scheme{proc} is called on each field of the record, in order,
|
|
||||||
;;> along with its zero-based \scheme{index} and the accumulated
|
|
||||||
;;> result of the last call, starting with \scheme{knil}.
|
|
||||||
|
|
||||||
;;> Returns a new CSV parser for the given \var{grammar}. The parser
|
|
||||||
;;> by itself can be used to parse a record at a time.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> (let ((parse (csv-parser)))
|
|
||||||
;;> (parse (lambda (vec i field) (vector-set! vec i (string->number field)) vec)
|
|
||||||
;;> (make-vector 3)
|
|
||||||
;;> (open-input-string "1,2,3")))
|
|
||||||
;;> }
|
|
||||||
(define csv-parser
|
|
||||||
(opt-lambda ((grammar default-csv-grammar))
|
|
||||||
(lambda (kons knil in)
|
|
||||||
(when (pair? (csv-grammar-comment-chars grammar))
|
|
||||||
(let lp ()
|
|
||||||
(when (memv (peek-char in) (csv-grammar-comment-chars grammar))
|
|
||||||
(csv-skip-line in grammar)
|
|
||||||
(lp))))
|
|
||||||
(let lp ((acc knil)
|
|
||||||
(index 0)
|
|
||||||
(quoted? #f)
|
|
||||||
(out (open-output-string)))
|
|
||||||
(define (get-field)
|
|
||||||
(let ((field (get-output-string out)))
|
|
||||||
(cond
|
|
||||||
((and (zero? index) (equal? field "")) field)
|
|
||||||
((and (csv-grammar-quote-non-numeric? grammar) (not quoted?))
|
|
||||||
(or (string->number field)
|
|
||||||
(error "unquoted field is not numeric" field)))
|
|
||||||
(else field))))
|
|
||||||
(define (finish-row)
|
|
||||||
(let ((field (get-field)))
|
|
||||||
(if (and (zero? index) (equal? field ""))
|
|
||||||
;; empty row, read again
|
|
||||||
(lp acc index #f out)
|
|
||||||
(kons acc index field))))
|
|
||||||
(let ((ch (read-char in)))
|
|
||||||
(cond
|
|
||||||
((eof-object? ch)
|
|
||||||
(let ((field (get-field)))
|
|
||||||
(if (and (zero? index) (equal? field ""))
|
|
||||||
;; no data
|
|
||||||
ch
|
|
||||||
(kons acc index field))))
|
|
||||||
((memv ch (csv-grammar-separator-chars grammar))
|
|
||||||
(lp (kons acc index (get-field))
|
|
||||||
(+ index 1)
|
|
||||||
#f
|
|
||||||
(open-output-string)))
|
|
||||||
((eqv? ch (csv-grammar-quote-char grammar))
|
|
||||||
;; TODO: Consider a strict mode to enforce no text
|
|
||||||
;; before/after the quoted text.
|
|
||||||
(csv-read-quoted in out grammar)
|
|
||||||
(lp acc index #t out))
|
|
||||||
((eqv? ch (csv-grammar-record-separator grammar))
|
|
||||||
(finish-row))
|
|
||||||
((and (eqv? ch #\return)
|
|
||||||
(memq (csv-grammar-record-separator grammar) '(crlf lax)))
|
|
||||||
(cond
|
|
||||||
((eqv? (peek-char in) #\newline)
|
|
||||||
(read-char in)
|
|
||||||
(finish-row))
|
|
||||||
((eq? (csv-grammar-record-separator grammar) 'lax)
|
|
||||||
(finish-row))
|
|
||||||
(else
|
|
||||||
(write-char ch out)
|
|
||||||
(lp acc (+ index 1) quoted? out))))
|
|
||||||
((and (eqv? ch #\newline)
|
|
||||||
(eq? (csv-grammar-record-separator grammar) 'lax))
|
|
||||||
(finish-row))
|
|
||||||
(else
|
|
||||||
(write-char ch out)
|
|
||||||
(lp acc index quoted? out))))))))
|
|
||||||
|
|
||||||
(define (csv-skip-line in grammar)
|
|
||||||
(let lp ()
|
|
||||||
(let ((ch (read-char in)))
|
|
||||||
(cond
|
|
||||||
((eof-object? ch))
|
|
||||||
((eqv? ch (csv-grammar-record-separator grammar)))
|
|
||||||
((and (eqv? ch #\newline)
|
|
||||||
(eq? (csv-grammar-record-separator grammar) 'lax)))
|
|
||||||
((and (eqv? ch #\return)
|
|
||||||
(memq (csv-grammar-record-separator grammar) '(crlf lax)))
|
|
||||||
(cond
|
|
||||||
((eqv? (peek-char in) #\newline) (read-char in))
|
|
||||||
((eq? (csv-grammar-record-separator grammar) 'lax))
|
|
||||||
(else (lp))))
|
|
||||||
(else (lp))))))
|
|
||||||
|
|
||||||
(define (csv-read-quoted in out grammar)
|
|
||||||
(let lp ()
|
|
||||||
(let ((ch (read-char in)))
|
|
||||||
(cond
|
|
||||||
((eof-object? ch)
|
|
||||||
(error "unterminated csv quote" (get-output-string out)))
|
|
||||||
((eqv? ch (csv-grammar-quote-char grammar))
|
|
||||||
(when (and (csv-grammar-quote-doubling-escapes? grammar)
|
|
||||||
(eqv? ch (peek-char in)))
|
|
||||||
(write-char (read-char in) out)
|
|
||||||
(lp)))
|
|
||||||
((eqv? ch (csv-grammar-escape-char grammar))
|
|
||||||
(write-char (read-char in) out)
|
|
||||||
(lp))
|
|
||||||
(else
|
|
||||||
;; TODO: Consider an option to disable newlines in quotes.
|
|
||||||
(write-char ch out)
|
|
||||||
(lp))))))
|
|
||||||
|
|
||||||
(define (csv-skip-quoted in grammar)
|
|
||||||
(let lp ()
|
|
||||||
(let ((ch (read-char in)))
|
|
||||||
(cond
|
|
||||||
((eof-object? ch)
|
|
||||||
(error "unterminated csv quote"))
|
|
||||||
((eqv? ch (csv-grammar-quote-char grammar))
|
|
||||||
(when (and (csv-grammar-quote-doubling-escapes? grammar)
|
|
||||||
(eqv? ch (peek-char in)))
|
|
||||||
(read-char in)
|
|
||||||
(lp)))
|
|
||||||
((eqv? ch (csv-grammar-escape-char grammar))
|
|
||||||
(read-char in)
|
|
||||||
(lp))
|
|
||||||
(else
|
|
||||||
(lp))))))
|
|
||||||
|
|
||||||
;;> Returns the number of rows in the input.
|
|
||||||
(define csv-num-rows
|
|
||||||
(opt-lambda ((grammar default-csv-grammar)
|
|
||||||
(in (current-input-port)))
|
|
||||||
(let lp ((num-rows 0) (start? #t))
|
|
||||||
(let ((ch (read-char in)))
|
|
||||||
(cond
|
|
||||||
((eof-object? ch) (if start? num-rows (+ num-rows 1)))
|
|
||||||
((eqv? ch (csv-grammar-quote-char grammar))
|
|
||||||
(csv-skip-quoted in grammar)
|
|
||||||
(lp num-rows #f))
|
|
||||||
((eqv? ch (csv-grammar-record-separator grammar))
|
|
||||||
(lp (+ num-rows 1) #f))
|
|
||||||
((and (eqv? ch #\return)
|
|
||||||
(memq (csv-grammar-record-separator grammar) '(crlf lax)))
|
|
||||||
(cond
|
|
||||||
((eqv? (peek-char in) #\newline)
|
|
||||||
(read-char in)
|
|
||||||
(lp (+ num-rows 1) #t))
|
|
||||||
((eq? (csv-grammar-record-separator grammar) 'lax)
|
|
||||||
(lp (+ num-rows 1) #t))
|
|
||||||
(else
|
|
||||||
(lp num-rows #f))))
|
|
||||||
((and (eqv? ch #\newline)
|
|
||||||
(eq? (csv-grammar-record-separator grammar) 'lax))
|
|
||||||
(lp (+ num-rows 1) #t))
|
|
||||||
(else
|
|
||||||
(lp num-rows #f)))))))
|
|
||||||
|
|
||||||
;;> \section{CSV Readers}
|
|
||||||
|
|
||||||
;;> A CSV reader reads a single record, returning some representation
|
|
||||||
;;> of it. You can either loop manually with these or pass them to
|
|
||||||
;;> one of the high-level utilities to operate on a whole CSV file at
|
|
||||||
;;> a time.
|
|
||||||
|
|
||||||
;;> The simplest reader, simply returns the field string values in
|
|
||||||
;;> order as a list.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> ((csv-read->list) (open-input-string "foo,bar,baz"))
|
|
||||||
;;> }
|
|
||||||
(define csv-read->list
|
|
||||||
(opt-lambda ((parser (csv-parser)))
|
|
||||||
(opt-lambda ((in (current-input-port)))
|
|
||||||
(let ((res (parser (lambda (ls i field) (cons field ls)) '() in)))
|
|
||||||
(if (pair? res)
|
|
||||||
(reverse res)
|
|
||||||
res)))))
|
|
||||||
|
|
||||||
;;> The equivalent of \scheme{csv-read->list} but returns a vector.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> ((csv-read->vector) (open-input-string "foo,bar,baz"))
|
|
||||||
;;> }
|
|
||||||
(define csv-read->vector
|
|
||||||
(opt-lambda ((parser (csv-parser)))
|
|
||||||
(let ((reader (csv-read->list parser)))
|
|
||||||
(opt-lambda ((in (current-input-port)))
|
|
||||||
(let ((res (reader in)))
|
|
||||||
(if (pair? res)
|
|
||||||
(list->vector res)
|
|
||||||
res))))))
|
|
||||||
|
|
||||||
;;> The same as \scheme{csv-read->vector} but requires the vector to
|
|
||||||
;;> be of a fixed size, and may be more efficient.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> ((csv-read->fixed-vector 3) (open-input-string "foo,bar,baz"))
|
|
||||||
;;> }
|
|
||||||
(define csv-read->fixed-vector
|
|
||||||
(opt-lambda (size (parser (csv-parser)))
|
|
||||||
(opt-lambda ((in (current-input-port)))
|
|
||||||
(let ((res (make-vector size)))
|
|
||||||
(let ((len (parser (lambda (prev-i i field) (vector-set! res i field) i)
|
|
||||||
0
|
|
||||||
in)))
|
|
||||||
(if (zero? len)
|
|
||||||
(eof-object)
|
|
||||||
res))))))
|
|
||||||
|
|
||||||
;;> Returns an SXML representation of the record, as a row with
|
|
||||||
;;> multiple named columns.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> ((csv-read->sxml 'city '(name latitude longitude))
|
|
||||||
;;> (open-input-string "Tokyo,35°41′23″N,139°41′32″E"))
|
|
||||||
;;> }
|
|
||||||
(define csv-read->sxml
|
|
||||||
(opt-lambda ((row-name 'row)
|
|
||||||
(column-names
|
|
||||||
(lambda (i)
|
|
||||||
(string->symbol (string-append "col-" (number->string i)))))
|
|
||||||
(parser (csv-parser)))
|
|
||||||
(define (get-column-name i)
|
|
||||||
(if (procedure? column-names)
|
|
||||||
(column-names i)
|
|
||||||
(list-ref column-names i)))
|
|
||||||
(opt-lambda ((in (current-input-port)))
|
|
||||||
(let ((res (parser (lambda (ls i field)
|
|
||||||
`((,(get-column-name i) ,field) ,@ls))
|
|
||||||
(list row-name)
|
|
||||||
in)))
|
|
||||||
(if (pair? res)
|
|
||||||
(reverse res)
|
|
||||||
res)))))
|
|
||||||
|
|
||||||
;;> \section{CSV Utilities}
|
|
||||||
|
|
||||||
;;> A folding operation on records. \var{proc} is called successively
|
|
||||||
;;> on each row and the accumulated result.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> (csv-fold
|
|
||||||
;;> (lambda (row acc) (cons (cadr (assq 'name (cdr row))) acc))
|
|
||||||
;;> '()
|
|
||||||
;;> (csv-read->sxml 'city '(name latitude longitude))
|
|
||||||
;;> (open-input-string
|
|
||||||
;;> "Tokyo,35°41′23″N,139°41′32″E
|
|
||||||
;;> Paris,48°51′24″N,2°21′03″E"))
|
|
||||||
;;> }
|
|
||||||
(define csv-fold
|
|
||||||
(opt-lambda (proc
|
|
||||||
knil
|
|
||||||
(reader (csv-read->list))
|
|
||||||
(in (current-input-port)))
|
|
||||||
(let lp ((acc knil))
|
|
||||||
(let ((row (reader in)))
|
|
||||||
(cond
|
|
||||||
((eof-object? row) acc)
|
|
||||||
(else (lp (proc row acc))))))))
|
|
||||||
|
|
||||||
;;> An iterator which simply calls \var{proc} on each record in the
|
|
||||||
;;> input in order.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> (let ((count 0))
|
|
||||||
;;> (csv-for-each
|
|
||||||
;;> (lambda (row) (if (string->number (car row)) (set! count (+ 1 count))))
|
|
||||||
;;> (csv-read->list)
|
|
||||||
;;> (open-input-string
|
|
||||||
;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
|
|
||||||
;;> count)
|
|
||||||
;;> }
|
|
||||||
(define csv-for-each
|
|
||||||
(opt-lambda (proc
|
|
||||||
(reader (csv-read->list))
|
|
||||||
(in (current-input-port)))
|
|
||||||
(csv-fold (lambda (row acc) (proc row)) #f reader in)))
|
|
||||||
|
|
||||||
;;> Returns a list containing the result of calling \var{proc} on each
|
|
||||||
;;> element in the input.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> (csv-map
|
|
||||||
;;> (lambda (row) (string->symbol (cadr row)))
|
|
||||||
;;> (csv-read->list)
|
|
||||||
;;> (open-input-string
|
|
||||||
;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
|
|
||||||
;;> }
|
|
||||||
(define csv-map
|
|
||||||
(opt-lambda (proc
|
|
||||||
(reader (csv-read->list))
|
|
||||||
(in (current-input-port)))
|
|
||||||
(reverse (csv-fold (lambda (row acc) (cons (proc row) acc)) '() reader in))))
|
|
||||||
|
|
||||||
;;> Returns a list of all of the read records in the input.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> (csv->list
|
|
||||||
;;> (csv-read->list)
|
|
||||||
;;> (open-input-string
|
|
||||||
;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
|
|
||||||
;;> }
|
|
||||||
(define csv->list
|
|
||||||
(opt-lambda ((reader (csv-read->list))
|
|
||||||
(in (current-input-port)))
|
|
||||||
(csv-map (lambda (row) row) reader in)))
|
|
||||||
|
|
||||||
;;> Returns an SXML representation of the CSV.
|
|
||||||
;;>
|
|
||||||
;;> \example{
|
|
||||||
;;> ((csv->sxml 'city '(name latitude longitude))
|
|
||||||
;;> (open-input-string
|
|
||||||
;;> "Tokyo,35°41′23″N,139°41′32″E
|
|
||||||
;;> Paris,48°51′24″N,2°21′03″E"))
|
|
||||||
;;> }
|
|
||||||
(define csv->sxml
|
|
||||||
(opt-lambda ((row-name 'row)
|
|
||||||
(column-names
|
|
||||||
(lambda (i)
|
|
||||||
(string->symbol (string-append "col-" (number->string i)))))
|
|
||||||
(parser (csv-parser)))
|
|
||||||
(opt-lambda ((in (current-input-port)))
|
|
||||||
(cons '*TOP*
|
|
||||||
(csv->list (csv-read->sxml row-name column-names parser) in)))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
;;> \section{CSV Writers}
|
|
||||||
|
|
||||||
(define (write->string obj)
|
|
||||||
(let ((out (open-output-string)))
|
|
||||||
(write obj out)
|
|
||||||
(get-output-string out)))
|
|
||||||
|
|
||||||
(define (csv-grammar-char-needs-quoting? grammar ch)
|
|
||||||
(or (eqv? ch (csv-grammar-quote-char grammar))
|
|
||||||
(eqv? ch (csv-grammar-escape-char grammar))
|
|
||||||
(memv ch (csv-grammar-separator-chars grammar))
|
|
||||||
(eqv? ch (csv-grammar-record-separator grammar))
|
|
||||||
(memv ch '(#\newline #\return))))
|
|
||||||
|
|
||||||
(define (csv-write-quoted obj out grammar)
|
|
||||||
(let ((in (open-input-string (if (string? obj) obj (write->string obj)))))
|
|
||||||
(write-char (csv-grammar-quote-char grammar) out)
|
|
||||||
(let lp ()
|
|
||||||
(let ((ch (read-char in)))
|
|
||||||
(cond
|
|
||||||
((eof-object? ch))
|
|
||||||
((or (eqv? ch (csv-grammar-quote-char grammar))
|
|
||||||
(eqv? ch (csv-grammar-escape-char grammar)))
|
|
||||||
(cond
|
|
||||||
((and (csv-grammar-quote-doubling-escapes? grammar)
|
|
||||||
(eqv? ch (csv-grammar-quote-char grammar)))
|
|
||||||
(write-char ch out))
|
|
||||||
((csv-grammar-escape-char grammar)
|
|
||||||
=> (lambda (esc) (write-char esc out)))
|
|
||||||
(else (error "no quote defined for" ch grammar)))
|
|
||||||
(write-char ch out)
|
|
||||||
(lp))
|
|
||||||
(else
|
|
||||||
(write-char ch out)
|
|
||||||
(lp)))))
|
|
||||||
(write-char (csv-grammar-quote-char grammar) out)))
|
|
||||||
|
|
||||||
(define csv-writer
|
|
||||||
(opt-lambda ((grammar default-csv-grammar))
|
|
||||||
(opt-lambda (row (out (current-output-port)))
|
|
||||||
(let lp ((ls row) (first? #t))
|
|
||||||
(when (pair? ls)
|
|
||||||
(unless first?
|
|
||||||
(write-char (car (csv-grammar-separator-chars grammar)) out))
|
|
||||||
(if (or (and (csv-grammar-quote-non-numeric? grammar)
|
|
||||||
(not (number? (car ls))))
|
|
||||||
(and (string? (car ls))
|
|
||||||
(string-any
|
|
||||||
(lambda (ch) (csv-grammar-char-needs-quoting? grammar ch))
|
|
||||||
(car ls)))
|
|
||||||
(and (not (string? (car ls)))
|
|
||||||
(not (number? (car ls)))
|
|
||||||
(not (symbol? (car ls)))))
|
|
||||||
(csv-write-quoted (car ls) out grammar)
|
|
||||||
(display (car ls) out))
|
|
||||||
(lp (cdr ls) #f)))
|
|
||||||
(write-string
|
|
||||||
(case (csv-grammar-record-separator grammar)
|
|
||||||
((crlf) "\r\n")
|
|
||||||
((lf lax) "\n")
|
|
||||||
((cr) "\r")
|
|
||||||
(else (string (csv-grammar-record-separator grammar))))
|
|
||||||
out))))
|
|
||||||
|
|
||||||
(define csv-write
|
|
||||||
(opt-lambda ((writer (csv-writer)))
|
|
||||||
(opt-lambda (rows (out (current-output-port)))
|
|
||||||
(for-each
|
|
||||||
(lambda (row) (writer row out))
|
|
||||||
rows))))
|
|
|
@ -1,11 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi csv)
|
|
||||||
(import (scheme base) (scheme write) (srfi 130) (srfi 227))
|
|
||||||
(export csv-grammar csv-parser csv-grammar?
|
|
||||||
default-csv-grammar default-tsv-grammar
|
|
||||||
csv-read->list csv-read->vector csv-read->fixed-vector
|
|
||||||
csv-read->sxml csv-num-rows
|
|
||||||
csv-fold csv-map csv->list csv-for-each csv->sxml
|
|
||||||
csv-writer csv-write
|
|
||||||
csv-skip-line)
|
|
||||||
(include "csv.scm"))
|
|
|
@ -1,63 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi diff-test)
|
|
||||||
(import (scheme base) (chibi diff))
|
|
||||||
(export run-tests)
|
|
||||||
(cond-expand
|
|
||||||
(chibi (import (chibi test)))
|
|
||||||
(else
|
|
||||||
(import (scheme write))
|
|
||||||
;; inline (chibi test) to avoid circular dependencies in snow
|
|
||||||
;; installations
|
|
||||||
(begin
|
|
||||||
(define-syntax test
|
|
||||||
(syntax-rules ()
|
|
||||||
((test expect expr)
|
|
||||||
(test 'expr expect expr))
|
|
||||||
((test name expect expr)
|
|
||||||
(guard (exn (else (display "!\nERROR: ") (write name) (newline)
|
|
||||||
(write exn) (newline)))
|
|
||||||
(let* ((res expr)
|
|
||||||
(pass? (equal? expect expr)))
|
|
||||||
(display (if pass? "." "x"))
|
|
||||||
(cond
|
|
||||||
((not pass?)
|
|
||||||
(display "\nFAIL: ") (write name) (newline))))))))
|
|
||||||
(define (test-begin name)
|
|
||||||
(display name))
|
|
||||||
(define (test-end)
|
|
||||||
(newline)))))
|
|
||||||
(begin
|
|
||||||
(define (run-tests)
|
|
||||||
(test-begin "diff")
|
|
||||||
(test '((#\A 1 0) (#\C 2 2))
|
|
||||||
(lcs-with-positions '(#\G #\A #\C) '(#\A #\G #\C #\A #\T)))
|
|
||||||
(test '(#\A #\C)
|
|
||||||
(lcs '(#\G #\A #\C) '(#\A #\G #\C #\A #\T)))
|
|
||||||
(test '((#\G #\A #\C) (#\A #\G #\C #\A #\T) ((#\A 1 0) (#\C 2 2)))
|
|
||||||
(diff "GAC" "AGCAT" read-char))
|
|
||||||
(test '((#\A #\G #\C #\A #\T) (#\A #\G #\C #\A #\T)
|
|
||||||
((#\A 0 0) (#\G 1 1) (#\C 2 2) (#\A 3 3) (#\T 4 4)))
|
|
||||||
(diff "AGCAT" "AGCAT" read-char))
|
|
||||||
(test '((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\.
|
|
||||||
#\G #\A #\C #\. #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
||||||
(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\.
|
|
||||||
#\A #\G #\C #\A #\T #\. #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
||||||
((#\0 0 0) (#\1 1 1) (#\2 2 2) (#\3 3 3) (#\4 4 4) (#\5 5 5)
|
|
||||||
(#\6 6 6) (#\7 7 7) (#\8 8 8) (#\9 9 9) (#\. 10 10)
|
|
||||||
(#\A 12 11) (#\C 13 13)
|
|
||||||
(#\. 14 16) (#\0 15 17) (#\1 16 18) (#\2 17 19) (#\3 18 20)
|
|
||||||
(#\4 19 21) (#\5 20 22) (#\6 21 23) (#\7 22 24) (#\8 23 25)
|
|
||||||
(#\9 24 26)))
|
|
||||||
(diff "0123456789.GAC.0123456789"
|
|
||||||
"0123456789.AGCAT.0123456789"
|
|
||||||
read-char))
|
|
||||||
(let ((d (diff "GAC" "AGCAT" read-char)))
|
|
||||||
(test " »G« AC"
|
|
||||||
(edits->string (car d) (car (cddr d)) 1))
|
|
||||||
(test "A «G» C «AT» "
|
|
||||||
(edits->string (cadr d) (car (cddr d)) 2))
|
|
||||||
(test "\x1b;[31mG\x1b;[39mAC"
|
|
||||||
(edits->string/color (car d) (car (cddr d)) 1))
|
|
||||||
(test "A\x1b;[32mG\x1b;[39mC\x1b;[32mAT\x1b;[39m"
|
|
||||||
(edits->string/color (cadr d) (car (cddr d)) 2)))
|
|
||||||
(test-end))))
|
|
|
@ -1,279 +0,0 @@
|
||||||
|
|
||||||
;; utility for lcs-with-positions
|
|
||||||
(define (max-seq . o)
|
|
||||||
(if (null? o)
|
|
||||||
(list 0 '())
|
|
||||||
(let loop ((a (car o)) (ls (cdr o)))
|
|
||||||
(if (null? ls)
|
|
||||||
a
|
|
||||||
(let ((b (car ls)))
|
|
||||||
(if (>= (car a) (car b))
|
|
||||||
(loop a (cdr ls))
|
|
||||||
(loop b (cdr ls))))))))
|
|
||||||
|
|
||||||
;;> Finds the Longest Common Subsequence between \var{a-ls} and
|
|
||||||
;;> \var{b-ls}, comparing elements with \var{eq} (default
|
|
||||||
;;> \scheme{equal?}. Returns this sequence as a list, using the
|
|
||||||
;;> elements from \var{a-ls}. Uses quadratic time and space.
|
|
||||||
(define (lcs a-ls b-ls . o)
|
|
||||||
(let ((eq (if (pair? o) (car o) equal?)))
|
|
||||||
(map car (lcs-with-positions a-ls b-ls eq))))
|
|
||||||
|
|
||||||
;;> Variant of \scheme{lcs} which returns the annotated sequence. The
|
|
||||||
;;> result is a list of the common elements, each represented as a
|
|
||||||
;;> list of 3 values: the element, the zero-indexed position in
|
|
||||||
;;> \var{a-ls} where the element occurred, and the position in
|
|
||||||
;;> \var{b-ls}.
|
|
||||||
(define (lcs-with-positions a-ls b-ls . o)
|
|
||||||
(let* ((eq (if (pair? o) (car o) equal?))
|
|
||||||
(a-len (+ 1 (length a-ls)))
|
|
||||||
(b-len (+ 1 (length b-ls)))
|
|
||||||
(results (make-vector (* a-len b-len) #f)))
|
|
||||||
(let loop ((a a-ls) (a-pos 0) (b b-ls) (b-pos 0))
|
|
||||||
;; cache this step if not already done
|
|
||||||
(let ((i (+ (* a-pos b-len) b-pos)))
|
|
||||||
(or (vector-ref results i)
|
|
||||||
(let ((res
|
|
||||||
(if (or (null? a) (null? b))
|
|
||||||
(list 0 '()) ;; base case
|
|
||||||
(let ((a1 (car a))
|
|
||||||
(b1 (car b))
|
|
||||||
(a-tail (loop (cdr a) (+ a-pos 1) b b-pos))
|
|
||||||
(b-tail (loop a a-pos (cdr b) (+ b-pos 1))))
|
|
||||||
(cond
|
|
||||||
((eq a1 b1)
|
|
||||||
;; match found, we either use it or we don't
|
|
||||||
(let* ((a-b-tail (loop (cdr a) (+ a-pos 1)
|
|
||||||
(cdr b) (+ b-pos 1)))
|
|
||||||
(a-b-res (list (+ 1 (car a-b-tail))
|
|
||||||
(cons (list a1 a-pos b-pos)
|
|
||||||
(cadr a-b-tail)))))
|
|
||||||
(max-seq a-b-res a-tail b-tail)))
|
|
||||||
(else
|
|
||||||
;; not a match
|
|
||||||
(max-seq a-tail b-tail)))))))
|
|
||||||
(vector-set! results i res)
|
|
||||||
res))))
|
|
||||||
(cadr (vector-ref results 0))))
|
|
||||||
|
|
||||||
(define (source->list x reader)
|
|
||||||
(port->list
|
|
||||||
reader
|
|
||||||
(cond ((port? x) x)
|
|
||||||
((string? x) (open-input-string x))
|
|
||||||
(else (error "don't know how to diff from:" x)))))
|
|
||||||
|
|
||||||
;;> Utility to run lcs on text. \var{a} and \var{b} can be strings or
|
|
||||||
;;> ports, which are tokenized into a sequence by calling \var{reader}
|
|
||||||
;;> until \var{eof-object} is found. Returns a list of three values,
|
|
||||||
;;> the sequences read from \var{a} and \var{b}, and the \scheme{lcs}
|
|
||||||
;;> result. Unless \var{minimal?} is set, we trim common
|
|
||||||
;;> prefixes/suffixes before computing the lcs.
|
|
||||||
(define (diff a b . o)
|
|
||||||
(let-optionals o ((reader read-line)
|
|
||||||
(eq equal?)
|
|
||||||
(optimal? #f))
|
|
||||||
(let ((a-ls (source->list a reader))
|
|
||||||
(b-ls (source->list b reader)))
|
|
||||||
(if optimal?
|
|
||||||
(list a-ls b-ls (lcs-with-positions a-ls b-ls eq))
|
|
||||||
(let lp1 ((i 0) (a a-ls) (b b-ls))
|
|
||||||
(cond
|
|
||||||
((or (null? a) (null? b)) ;; prefix or equal
|
|
||||||
(if (and (null? a) (null? b))
|
|
||||||
(let ((n-ls (iota (length a-ls)))) ;; equal
|
|
||||||
(list a-ls b-ls (map list a-ls n-ls n-ls)))
|
|
||||||
(list a-ls b-ls (lcs-with-positions a-ls b-ls eq))))
|
|
||||||
((eq (car a) (car b))
|
|
||||||
(lp1 (+ i 1) (cdr a) (cdr b)))
|
|
||||||
(else
|
|
||||||
(let lp2 ((j 0) (ra (reverse a)) (rb (reverse b)))
|
|
||||||
(cond
|
|
||||||
((or (null? ra) (null? rb)) ;; can't happen
|
|
||||||
(list a-ls b-ls (lcs-with-positions a-ls b-ls eq)))
|
|
||||||
((eq (car ra) (car rb))
|
|
||||||
(lp2 (+ j 1) (cdr ra) (cdr rb)))
|
|
||||||
(else
|
|
||||||
(let* ((a-ls2 (reverse ra))
|
|
||||||
(b-ls2 (reverse rb))
|
|
||||||
(a-left-len (+ i (length a-ls2)))
|
|
||||||
(b-left-len (+ i (length b-ls2))))
|
|
||||||
(list a-ls
|
|
||||||
b-ls
|
|
||||||
(append
|
|
||||||
(map (lambda (x i) (list x i i))
|
|
||||||
(take a-ls i)
|
|
||||||
(iota i))
|
|
||||||
(map (lambda (x)
|
|
||||||
(list (car x)
|
|
||||||
(+ i (cadr x))
|
|
||||||
(+ i (car (cddr x)))))
|
|
||||||
(lcs-with-positions a-ls2 b-ls2 eq))
|
|
||||||
(map (lambda (x i)
|
|
||||||
(list x (+ i a-left-len) (+ i b-left-len)))
|
|
||||||
(take-right a j)
|
|
||||||
(iota j))))))
|
|
||||||
)))))))))
|
|
||||||
|
|
||||||
;;> Utility to format the result of a \var{diff} to output port
|
|
||||||
;;> \var{out} (default \scheme{(current-output-port)}). Applies
|
|
||||||
;;> \var{writer} to successive diff chunks. \var{writer} should be a
|
|
||||||
;;> procedure of three arguments: \scheme{(writer subsequence type
|
|
||||||
;;> out). \var{subsequence} is a subsequence from the original input,
|
|
||||||
;;> \var{type} is a symbol indicating the type of diff: \scheme{'same}
|
|
||||||
;;> if this is part of the lcs, \scheme{'add} if it is unique to the
|
|
||||||
;;> second input, or \scheme{'remove} if it is unique to the first
|
|
||||||
;;> input. \var{writer} defaults to \scheme{write-line-diffs},
|
|
||||||
;;> assuming the default line diffs.
|
|
||||||
(define (write-diff diff . o)
|
|
||||||
(let-optionals o ((writer write-line-diffs)
|
|
||||||
(out (current-output-port)))
|
|
||||||
(let* ((a-ls (car diff))
|
|
||||||
(b-ls (cadr diff))
|
|
||||||
(d-ls (car (cddr diff))))
|
|
||||||
;; context diff
|
|
||||||
(let lp ((d d-ls) (a a-ls) (a-pos 0) (b b-ls) (b-pos 0))
|
|
||||||
(unless (null? d)
|
|
||||||
(let* ((d1 (car d))
|
|
||||||
(a-off (cadr d1))
|
|
||||||
(a-skip (- a-off a-pos))
|
|
||||||
(b-off (car (cddr d1)))
|
|
||||||
(b-skip (- b-off b-pos)))
|
|
||||||
(let-values (((a-head a-tail) (split-at a a-skip))
|
|
||||||
((b-head b-tail) (split-at b b-skip)))
|
|
||||||
;; elements only in a have been removed
|
|
||||||
(if (pair? a-head)
|
|
||||||
(writer (cdr a-head) 'remove out))
|
|
||||||
;; elements only in b have been added
|
|
||||||
(if (pair? b-head)
|
|
||||||
(writer (cdr b-head) 'add out))
|
|
||||||
;; reprint this common element
|
|
||||||
(writer (list (car d1)) 'same out)
|
|
||||||
;; recurse
|
|
||||||
(lp (cdr d) a-tail a-off b-tail b-off))))))))
|
|
||||||
|
|
||||||
;;> Equivalent to \scheme{write-diff} but collects the output to a string.
|
|
||||||
(define (diff->string diff . o)
|
|
||||||
(let ((out (open-output-string)))
|
|
||||||
(write-diff diff (if (pair? o) (car o) write-line-diffs) out)
|
|
||||||
(get-output-string out)))
|
|
||||||
|
|
||||||
;;> The default writer for \scheme{write-diff}, annotates simple +/-
|
|
||||||
;;> prefixes for added/removed lines.
|
|
||||||
(define (write-line-diffs lines type out)
|
|
||||||
(for-each
|
|
||||||
(lambda (line)
|
|
||||||
(case type
|
|
||||||
((add)
|
|
||||||
(write-char #\+ out))
|
|
||||||
((remove)
|
|
||||||
(write-char #\- out))
|
|
||||||
((same)
|
|
||||||
(write-char #\space out))
|
|
||||||
(else (error "unknown diff type:" type)))
|
|
||||||
(write-string line out)
|
|
||||||
(newline out))
|
|
||||||
lines))
|
|
||||||
|
|
||||||
;;> A variant of \scheme{write-line-diffs} which adds red/green ANSI
|
|
||||||
;;> coloring to the +/- prefix.
|
|
||||||
(define (write-line-diffs/color lines type out)
|
|
||||||
(for-each
|
|
||||||
(lambda (line)
|
|
||||||
(case type
|
|
||||||
((add)
|
|
||||||
(write-string (green "+") out)
|
|
||||||
(write-string (green line) out))
|
|
||||||
((remove)
|
|
||||||
(write-string (red "-") out)
|
|
||||||
(write-string (red line) out))
|
|
||||||
((same)
|
|
||||||
(write-char #\space out)
|
|
||||||
(write-string line out))
|
|
||||||
(else (error "unknown diff type:" type)))
|
|
||||||
(newline out))
|
|
||||||
lines))
|
|
||||||
|
|
||||||
;;> A diff writer for sequences of characters (when a diff was
|
|
||||||
;;> generated with \scheme{read-char}), enclosing added characters in
|
|
||||||
;;> «...» brackets and removed characters in »...«.
|
|
||||||
(define (write-char-diffs chars type out)
|
|
||||||
(case type
|
|
||||||
((add)
|
|
||||||
(write-string " «" out)
|
|
||||||
(write-string (list->string chars) out)
|
|
||||||
(write-string "» " out))
|
|
||||||
((remove)
|
|
||||||
(write-string " »" out)
|
|
||||||
(write-string (list->string chars) out)
|
|
||||||
(write-string "« " out))
|
|
||||||
((same)
|
|
||||||
(write-string (list->string chars) out))
|
|
||||||
(else (error "unknown diff type:" type))))
|
|
||||||
|
|
||||||
;;> A diff writer for sequences of characters (when a diff was
|
|
||||||
;;> generated with \scheme{read-char}), formatting added characters in
|
|
||||||
;;> green and removed characters in red.
|
|
||||||
(define (write-char-diffs/color chars type out)
|
|
||||||
(case type
|
|
||||||
((add)
|
|
||||||
(write-string (green (list->string chars)) out))
|
|
||||||
((remove)
|
|
||||||
(write-string (red (list->string chars)) out))
|
|
||||||
((same)
|
|
||||||
(write-string (list->string chars) out))
|
|
||||||
(else (error "unknown diff type:" type))))
|
|
||||||
|
|
||||||
;;> Utility to format the result of a \scheme{diff} with respect to a
|
|
||||||
;;> single input sequence \var{ls}. \var{lcs} is the annotated common
|
|
||||||
;;> sequence from \scheme{diff} or \scheme{lcs-with-positions}, and
|
|
||||||
;;> \var{index} is the index (0 or 1, default 1) of \var{ls} in the
|
|
||||||
;;> original call. Since we have no information about the other
|
|
||||||
;;> input, we can only format what is the same and what is different,
|
|
||||||
;;> formatting the differences as either added (if \var{index} is 0)
|
|
||||||
;;> or removed (if \var{index} is 1).
|
|
||||||
(define (write-edits ls lcs . o)
|
|
||||||
(let-optionals o ((index 1)
|
|
||||||
(writer write-line-diffs)
|
|
||||||
(out (current-output-port)))
|
|
||||||
(let ((type (if (eq? index 1) 'remove 'add)))
|
|
||||||
(let lp ((ls ls) (lcs lcs) (buf '(#f)) (i 0))
|
|
||||||
(define (output ch type)
|
|
||||||
(cond
|
|
||||||
((eq? type (car buf))
|
|
||||||
(cons type (cons ch (cdr buf))))
|
|
||||||
(else
|
|
||||||
(if (car buf)
|
|
||||||
(writer (reverse (cdr buf)) (car buf) out))
|
|
||||||
(list type ch))))
|
|
||||||
(cond
|
|
||||||
((null? ls) (output #f 'done))
|
|
||||||
((null? lcs)
|
|
||||||
(lp (cdr ls) lcs (output (car ls) type) (+ i 1)))
|
|
||||||
((= i (list-ref (car lcs) index))
|
|
||||||
(lp (cdr ls) (cdr lcs) (output (car ls) 'same) (+ i 1)))
|
|
||||||
(else
|
|
||||||
(lp (cdr ls) lcs (output (car ls) type) (+ i 1))))))))
|
|
||||||
|
|
||||||
;;> Equivalent to \scheme{write-edits} but collects the output to a string.
|
|
||||||
(define (edits->string ls lcs . o)
|
|
||||||
(let-optionals o ((type 'add)
|
|
||||||
(writer (if (and (pair? ls) (char? (car ls)))
|
|
||||||
write-char-diffs
|
|
||||||
write-line-diffs)))
|
|
||||||
(let ((out (open-output-string)))
|
|
||||||
(write-edits ls lcs type writer out)
|
|
||||||
(get-output-string out))))
|
|
||||||
|
|
||||||
;;> Equivalent to \scheme{write-edits} but collects the output to a
|
|
||||||
;;> string and uses a color-aware writer by default. Note with a
|
|
||||||
;;> character diff this returns the original input string as-is, with
|
|
||||||
;;> only ANSI escapes indicating what changed.
|
|
||||||
(define (edits->string/color ls lcs . o)
|
|
||||||
(let-optionals o ((type 'add)
|
|
||||||
(writer (if (and (pair? ls) (char? (car ls)))
|
|
||||||
write-char-diffs/color
|
|
||||||
write-line-diffs/color)))
|
|
||||||
(let ((out (open-output-string)))
|
|
||||||
(write-edits ls lcs type writer out)
|
|
||||||
(get-output-string out))))
|
|
|
@ -1,21 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi diff)
|
|
||||||
(import (scheme base) (srfi 1) (chibi optional) (chibi term ansi))
|
|
||||||
(export lcs lcs-with-positions
|
|
||||||
diff write-diff diff->string
|
|
||||||
write-edits edits->string edits->string/color
|
|
||||||
write-line-diffs
|
|
||||||
write-line-diffs/color
|
|
||||||
write-char-diffs
|
|
||||||
write-char-diffs/color)
|
|
||||||
(cond-expand
|
|
||||||
(chibi (import (only (chibi io) port->list)))
|
|
||||||
(else
|
|
||||||
(begin
|
|
||||||
(define (port->list reader port)
|
|
||||||
(let lp ((res '()))
|
|
||||||
(let ((x (reader port)))
|
|
||||||
(if (eof-object? x)
|
|
||||||
(reverse res)
|
|
||||||
(lp (cons x res)))))))))
|
|
||||||
(include "diff.scm"))
|
|
|
@ -11,24 +11,20 @@
|
||||||
#define SEXP_DISASM_PAD_WIDTH 4
|
#define SEXP_DISASM_PAD_WIDTH 4
|
||||||
|
|
||||||
#if SEXP_64_BIT
|
#if SEXP_64_BIT
|
||||||
#ifdef _WIN32
|
|
||||||
#define SEXP_PRId "%I64d"
|
|
||||||
#else
|
|
||||||
#define SEXP_PRId "%ld"
|
#define SEXP_PRId "%ld"
|
||||||
#endif
|
|
||||||
#else
|
#else
|
||||||
#define SEXP_PRId "%d"
|
#define SEXP_PRId "%d"
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
static void sexp_write_pointer (sexp ctx, void *p, sexp out) {
|
static void sexp_write_pointer (sexp ctx, void *p, sexp out) {
|
||||||
char buf[32];
|
char buf[32];
|
||||||
snprintf(buf, sizeof(buf), "%p", p);
|
sprintf(buf, "%p", p);
|
||||||
sexp_write_string(ctx, buf, out);
|
sexp_write_string(ctx, buf, out);
|
||||||
}
|
}
|
||||||
|
|
||||||
static void sexp_write_integer (sexp ctx, sexp_sint_t n, sexp out) {
|
static void sexp_write_integer (sexp ctx, sexp_sint_t n, sexp out) {
|
||||||
char buf[32];
|
char buf[32];
|
||||||
snprintf(buf, sizeof(buf), SEXP_PRId, n);
|
sprintf(buf, SEXP_PRId, n);
|
||||||
sexp_write_string(ctx, buf, out);
|
sexp_write_string(ctx, buf, out);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -41,10 +37,6 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
|
||||||
sexp_sint_t src_off=0;
|
sexp_sint_t src_off=0;
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
if (sexp_idp(bc))
|
|
||||||
bc = sexp_env_ref(ctx, sexp_context_env(ctx), bc, SEXP_FALSE);
|
|
||||||
if (sexp_macrop(bc))
|
|
||||||
bc = sexp_macro_proc(bc);
|
|
||||||
if (sexp_procedurep(bc)) {
|
if (sexp_procedurep(bc)) {
|
||||||
bc = sexp_procedure_code(bc);
|
bc = sexp_procedure_code(bc);
|
||||||
} else if (sexp_opcodep(bc)) {
|
} else if (sexp_opcodep(bc)) {
|
||||||
|
@ -84,20 +76,14 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
|
||||||
/* build a table of labels that are jumped to */
|
/* build a table of labels that are jumped to */
|
||||||
labels = (sexp_sint_t*)calloc(sexp_bytecode_length(bc), sizeof(sexp_sint_t));
|
labels = (sexp_sint_t*)calloc(sexp_bytecode_length(bc), sizeof(sexp_sint_t));
|
||||||
ip = sexp_bytecode_data(bc);
|
ip = sexp_bytecode_data(bc);
|
||||||
while (ip - sexp_bytecode_data(bc) < (int)sexp_bytecode_length(bc)) {
|
while (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) {
|
||||||
switch (*ip++) {
|
switch (*ip++) {
|
||||||
case SEXP_OP_JUMP:
|
case SEXP_OP_JUMP:
|
||||||
case SEXP_OP_JUMP_UNLESS:
|
case SEXP_OP_JUMP_UNLESS:
|
||||||
off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
|
off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
|
||||||
if (off >= 0 && off < (int)sexp_bytecode_length(bc) && labels[off] == 0)
|
if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] == 0)
|
||||||
labels[off] = label++;
|
labels[off] = label++;
|
||||||
case SEXP_OP_CALL:
|
case SEXP_OP_CALL:
|
||||||
case SEXP_OP_FCALL0:
|
|
||||||
case SEXP_OP_FCALL1:
|
|
||||||
case SEXP_OP_FCALL2:
|
|
||||||
case SEXP_OP_FCALL3:
|
|
||||||
case SEXP_OP_FCALL4:
|
|
||||||
case SEXP_OP_FCALLN:
|
|
||||||
case SEXP_OP_CLOSURE_REF:
|
case SEXP_OP_CLOSURE_REF:
|
||||||
case SEXP_OP_GLOBAL_KNOWN_REF:
|
case SEXP_OP_GLOBAL_KNOWN_REF:
|
||||||
case SEXP_OP_GLOBAL_REF:
|
case SEXP_OP_GLOBAL_REF:
|
||||||
|
@ -144,7 +130,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
|
||||||
== sexp_unbox_fixnum(
|
== sexp_unbox_fixnum(
|
||||||
sexp_car(sexp_vector_ref(src, sexp_make_fixnum(src_off)))))) {
|
sexp_car(sexp_vector_ref(src, sexp_make_fixnum(src_off)))))) {
|
||||||
src_here = sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(src_off)));
|
src_here = sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(src_off)));
|
||||||
src_off = src_off < (sexp_sint_t)sexp_vector_length(src)-1 ? src_off + 1 : -1;
|
src_off = src_off < sexp_vector_length(src)-1 ? src_off + 1 : -1;
|
||||||
} else {
|
} else {
|
||||||
src_here = NULL;
|
src_here = NULL;
|
||||||
}
|
}
|
||||||
|
@ -173,7 +159,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
|
||||||
case SEXP_OP_JUMP_UNLESS:
|
case SEXP_OP_JUMP_UNLESS:
|
||||||
sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
|
sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
|
||||||
off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
|
off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
|
||||||
if (off >= 0 && off < (sexp_sint_t)sexp_bytecode_length(bc) && labels[off] > 0) {
|
if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] > 0) {
|
||||||
sexp_write_string(ctx, " L", out);
|
sexp_write_string(ctx, " L", out);
|
||||||
sexp_write_integer(ctx, labels[off], out);
|
sexp_write_integer(ctx, labels[off], out);
|
||||||
}
|
}
|
||||||
|
@ -184,7 +170,6 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
|
||||||
case SEXP_OP_FCALL2:
|
case SEXP_OP_FCALL2:
|
||||||
case SEXP_OP_FCALL3:
|
case SEXP_OP_FCALL3:
|
||||||
case SEXP_OP_FCALL4:
|
case SEXP_OP_FCALL4:
|
||||||
case SEXP_OP_FCALLN:
|
|
||||||
sexp_write_pointer(ctx, ((sexp*)ip)[0], out);
|
sexp_write_pointer(ctx, ((sexp*)ip)[0], out);
|
||||||
sexp_write_char(ctx, ' ', out);
|
sexp_write_char(ctx, ' ', out);
|
||||||
sexp_write(ctx, sexp_opcode_name(((sexp*)ip)[0]), out);
|
sexp_write(ctx, sexp_opcode_name(((sexp*)ip)[0]), out);
|
||||||
|
@ -235,7 +220,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
|
||||||
&& (depth < SEXP_DISASM_MAX_DEPTH)
|
&& (depth < SEXP_DISASM_MAX_DEPTH)
|
||||||
&& tmp && (sexp_bytecodep(tmp) || sexp_procedurep(tmp)))
|
&& tmp && (sexp_bytecodep(tmp) || sexp_procedurep(tmp)))
|
||||||
disasm(ctx, self, tmp, out, depth+1);
|
disasm(ctx, self, tmp, out, depth+1);
|
||||||
if (ip - sexp_bytecode_data(bc) < (int)sexp_bytecode_length(bc))
|
if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
|
||||||
goto loop;
|
goto loop;
|
||||||
|
|
||||||
free(labels);
|
free(labels);
|
||||||
|
|
|
@ -25,25 +25,4 @@
|
||||||
(index (if (pair? o) (car o) 0))
|
(index (if (pair? o) (car o) 0))
|
||||||
(acc knil))
|
(acc knil))
|
||||||
(f p index fk)))))
|
(f p index fk)))))
|
||||||
(test "hello" (ansi->sxml "hello"))
|
|
||||||
(test '(span "[ " (span (@ (style . "color:red")) "FAIL") "]")
|
|
||||||
(ansi->sxml "[ \x1B;[31mFAIL\x1B;[39m]"))
|
|
||||||
(test '(span (u "under " (span (@ (style . "color:red")) "red") " line"))
|
|
||||||
(ansi->sxml "\x1B;[4munder \x1B;[31mred\x1B;[39m line\x1B;[24m"))
|
|
||||||
(test '(span "plain "
|
|
||||||
(u "under "
|
|
||||||
(span (@ (style . "color:red")) "red")
|
|
||||||
" line"))
|
|
||||||
(ansi->sxml
|
|
||||||
"plain \x1B;[4munder \x1B;[31mred\x1B;[39m line\x1B;[24m"))
|
|
||||||
(test '(code "(" "string?" " "
|
|
||||||
(span (@ (class . "string")) "\"hello\"")
|
|
||||||
")")
|
|
||||||
(expand-docs '(scheme "(string? \"hello\")")
|
|
||||||
(make-default-doc-env)))
|
|
||||||
(test '(code "(" "string?" " "
|
|
||||||
(span (@ (class . "string")) "\"<hello>\"")
|
|
||||||
")")
|
|
||||||
(expand-docs '(scheme "(string? \"<hello>\")")
|
|
||||||
(make-default-doc-env)))
|
|
||||||
(test-end))))
|
(test-end))))
|
||||||
|
|
|
@ -79,95 +79,6 @@
|
||||||
(define (sxml->sexp-list x)
|
(define (sxml->sexp-list x)
|
||||||
(call-with-input-string (sxml-strip x) port->sexp-list))
|
(call-with-input-string (sxml-strip x) port->sexp-list))
|
||||||
|
|
||||||
;;> Replace ansi escape sequences in a \var{str} with the corresponding sxml.
|
|
||||||
(define (ansi->sxml str)
|
|
||||||
;; TODO: ick
|
|
||||||
(let ((start (string-cursor-start str))
|
|
||||||
(end (string-cursor-end str)))
|
|
||||||
(let lp1 ((from start)
|
|
||||||
(to start)
|
|
||||||
(res '()))
|
|
||||||
(define (lookup str)
|
|
||||||
(case (string->number str)
|
|
||||||
((0) '/) ((1) 'b) ((3) 'i) ((4) 'u) ((9) 's)
|
|
||||||
((22) '/b) ((23) '/i) ((24) '/u) ((29) '/s)
|
|
||||||
((30) 'black) ((31) 'red) ((32) 'green) ((33) 'yellow)
|
|
||||||
((34) 'blue) ((35) 'magenta) ((36) 'cyan) ((37) 'white)
|
|
||||||
((39) '/color)
|
|
||||||
(else #f)))
|
|
||||||
(define (collect from to res)
|
|
||||||
(if (string-cursor<? from to)
|
|
||||||
(cons (substring-cursor str from to) res)
|
|
||||||
res))
|
|
||||||
(define (finish)
|
|
||||||
(let ((ls (reverse (collect from to res))))
|
|
||||||
(if (and (= 1 (length ls)) (string? (car ls)))
|
|
||||||
(car ls)
|
|
||||||
(let lp1 ((ls ls) (cur '()) (res '()))
|
|
||||||
(define (close to)
|
|
||||||
(let lp2 ((ls cur) (tmp '()))
|
|
||||||
(cond
|
|
||||||
((null? ls)
|
|
||||||
(list '() `(,@(reverse tmp) ,@res)))
|
|
||||||
((eq? to (car ls))
|
|
||||||
(list (cdr ls) `((,to ,@tmp) ,@res)))
|
|
||||||
((and (eq? to 'color) (memq (car ls) '(b i u s)))
|
|
||||||
;; color close came to an open non-color
|
|
||||||
;; back off and leave this open
|
|
||||||
(let ((s `(,(car ls) ,@(take-while string? tmp)))
|
|
||||||
(tmp (drop-while string? tmp)))
|
|
||||||
(list `(,@(reverse tmp) ,@(reverse s)) res)))
|
|
||||||
((symbol? (car ls))
|
|
||||||
(lp2 (cdr ls) `((,(car ls) ,@(reverse tmp)))))
|
|
||||||
((and (pair? (car ls)) (eq? 'color to))
|
|
||||||
(lp2 (cdr ls) `((,@(car ls) ,@(reverse tmp)))))
|
|
||||||
((pair? (car ls))
|
|
||||||
(lp2 (cdr ls) `(,(car ls) ,@(reverse tmp))))
|
|
||||||
(else
|
|
||||||
(lp2 (cdr ls) `(,(car ls) ,@tmp))))))
|
|
||||||
(cond
|
|
||||||
((null? ls)
|
|
||||||
`(span ,@(reverse (cadr (close #f)))))
|
|
||||||
((and (string? (car ls)) (pair? cur))
|
|
||||||
(lp1 (cdr ls) (cons (car ls) cur) res))
|
|
||||||
((string? (car ls))
|
|
||||||
(lp1 (cdr ls) cur (cons (car ls) res)))
|
|
||||||
(else
|
|
||||||
(case (car ls)
|
|
||||||
((b i u s) (lp1 (cdr ls) (cons (car ls) cur) res))
|
|
||||||
((/b) (apply lp1 (cdr ls) (close 'b)))
|
|
||||||
((/i) (apply lp1 (cdr ls) (close 'i)))
|
|
||||||
((/u) (apply lp1 (cdr ls) (close 'u)))
|
|
||||||
((/s) (apply lp1 (cdr ls) (close 's)))
|
|
||||||
((/) (apply lp1 (cdr ls) (close 'all)))
|
|
||||||
((/color) (apply lp1 (cdr ls) (close 'color)))
|
|
||||||
(else
|
|
||||||
(let ((style (string-append "color:"
|
|
||||||
(symbol->string (car ls)))))
|
|
||||||
(lp1 (cdr ls)
|
|
||||||
(cons `(span (@ (style . ,style))) cur)
|
|
||||||
res))))))))))
|
|
||||||
(if (string-cursor>=? to end)
|
|
||||||
(finish)
|
|
||||||
(let ((c (string-cursor-ref str to))
|
|
||||||
(sc2 (string-cursor-next str to)))
|
|
||||||
(if (and (= 27 (char->integer c))
|
|
||||||
(string-cursor<? sc2 end)
|
|
||||||
(eqv? #\[ (string-cursor-ref str sc2)))
|
|
||||||
(let ((sc3 (string-cursor-next str sc2)))
|
|
||||||
(let lp2 ((sc4 sc3))
|
|
||||||
(if (string-cursor>=? sc4 end)
|
|
||||||
(finish)
|
|
||||||
(let ((c2 (string-cursor-ref str sc4))
|
|
||||||
(sc5 (string-cursor-next str sc4)))
|
|
||||||
(if (eqv? #\m c2)
|
|
||||||
(let ((code (lookup
|
|
||||||
(substring-cursor str sc3 sc4)))
|
|
||||||
(res (collect from to res)))
|
|
||||||
(lp1 sc5 sc5 (if code (cons code res) res)))
|
|
||||||
(lp2 sc5))))))
|
|
||||||
(lp1 from sc2 res)))))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;;> Extract the literate Scribble docs for module \var{mod-name} and
|
;;> Extract the literate Scribble docs for module \var{mod-name} and
|
||||||
|
@ -177,11 +88,9 @@
|
||||||
(define (print-module-docs mod-name . o)
|
(define (print-module-docs mod-name . o)
|
||||||
(let ((out (if (pair? o) (car o) (current-output-port)))
|
(let ((out (if (pair? o) (car o) (current-output-port)))
|
||||||
(render (or (and (pair? o) (pair? (cdr o)) (cadr o))
|
(render (or (and (pair? o) (pair? (cdr o)) (cadr o))
|
||||||
sxml-display-as-text))
|
sxml-display-as-text)))
|
||||||
(unexpanded?
|
|
||||||
(and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (car (cddr o)))))
|
|
||||||
(render
|
(render
|
||||||
((if unexpanded? (lambda (sxml env) (fixup-docs sxml)) generate-docs)
|
(generate-docs
|
||||||
`((title ,(write-to-string mod-name))
|
`((title ,(write-to-string mod-name))
|
||||||
,@(extract-module-docs mod-name #f))
|
,@(extract-module-docs mod-name #f))
|
||||||
(make-module-doc-env mod-name))
|
(make-module-doc-env mod-name))
|
||||||
|
@ -267,8 +176,6 @@
|
||||||
(url . ,expand-url)
|
(url . ,expand-url)
|
||||||
(hyperlink . ,expand-hyperlink)
|
(hyperlink . ,expand-hyperlink)
|
||||||
(rawcode . code)
|
(rawcode . code)
|
||||||
(pre . pre)
|
|
||||||
(bibitem . ,(lambda (x env) '())) ;; TODO: bibtex
|
|
||||||
(code . ,expand-code)
|
(code . ,expand-code)
|
||||||
(codeblock . ,expand-codeblock)
|
(codeblock . ,expand-codeblock)
|
||||||
(ccode
|
(ccode
|
||||||
|
@ -288,7 +195,6 @@
|
||||||
(margin-note . ,expand-note)
|
(margin-note . ,expand-note)
|
||||||
(example . ,expand-example)
|
(example . ,expand-example)
|
||||||
(example-import . ,expand-example-import)
|
(example-import . ,expand-example-import)
|
||||||
(example-import-only . ,expand-example-import-only)
|
|
||||||
)))
|
)))
|
||||||
|
|
||||||
;;> Return a new document environment as in
|
;;> Return a new document environment as in
|
||||||
|
@ -300,9 +206,9 @@
|
||||||
(define (make-module-doc-env mod-name)
|
(define (make-module-doc-env mod-name)
|
||||||
(env-extend (make-default-doc-env)
|
(env-extend (make-default-doc-env)
|
||||||
'(example-env)
|
'(example-env)
|
||||||
(list (delay (environment '(scheme small)
|
(list (environment '(scheme small)
|
||||||
'(only (chibi) import)
|
'(only (chibi) import)
|
||||||
mod-name)))))
|
mod-name))))
|
||||||
|
|
||||||
(define (section-name tag name)
|
(define (section-name tag name)
|
||||||
(string-strip
|
(string-strip
|
||||||
|
@ -363,41 +269,21 @@
|
||||||
|
|
||||||
(define (expand-example x env)
|
(define (expand-example x env)
|
||||||
(let ((expr `(begin ,@(sxml->sexp-list x)))
|
(let ((expr `(begin ,@(sxml->sexp-list x)))
|
||||||
(example-env
|
(example-env (or (env-ref env 'example-env) (current-environment))))
|
||||||
(force (or (env-ref env 'example-env) (current-environment)))))
|
|
||||||
`(div
|
`(div
|
||||||
,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
|
,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
|
||||||
,(let* ((res-out (open-output-string))
|
(code
|
||||||
(tmp-out (open-output-string))
|
(div (@ (class . "result"))
|
||||||
(tmp-err (open-output-string))
|
,(call-with-output-string
|
||||||
(res (parameterize ((current-output-port tmp-out)
|
(lambda (out)
|
||||||
(current-error-port tmp-err))
|
(protect (exn (#t (print-exception exn out)))
|
||||||
(protect (exn (#t (print-exception exn tmp-err)))
|
(let ((res (eval expr example-env)))
|
||||||
(eval expr example-env)))))
|
(display "=> " out)
|
||||||
(display "=> " res-out)
|
(write res out))))))))))
|
||||||
(write res res-out)
|
|
||||||
(let ((res-str (get-output-string res-out))
|
|
||||||
(out-str (get-output-string tmp-out))
|
|
||||||
(err-str (get-output-string tmp-err)))
|
|
||||||
`(,@(if (string-null? out-str)
|
|
||||||
'()
|
|
||||||
`((div (@ (class . "output")) (pre ,(ansi->sxml out-str)))))
|
|
||||||
,@(if (string-null? err-str)
|
|
||||||
'()
|
|
||||||
`((div (@ (class . "error")) (pre ,(ansi->sxml err-str)))))
|
|
||||||
,@(if (and (or (not (string-null? err-str))
|
|
||||||
(not (string-null? out-str)))
|
|
||||||
(eq? res (if #f #f)))
|
|
||||||
'()
|
|
||||||
`((div (@ (class . "result")) (code ,res-str))))))))))
|
|
||||||
|
|
||||||
(define (expand-example-import x env)
|
(define (expand-example-import x env)
|
||||||
(eval `(import ,@(cdr x))
|
(eval `(import ,@(cdr x))
|
||||||
(force (or (env-ref env 'example-env) (current-environment))))
|
(or (env-ref env 'example-env) (current-environment)))
|
||||||
"")
|
|
||||||
|
|
||||||
(define (expand-example-import-only x env)
|
|
||||||
(env-set! env 'example-env (apply environment (cdr x)))
|
|
||||||
"")
|
"")
|
||||||
|
|
||||||
(define (expand-command sxml env)
|
(define (expand-command sxml env)
|
||||||
|
@ -429,7 +315,7 @@
|
||||||
sxml)))
|
sxml)))
|
||||||
|
|
||||||
(define (expand-procedure sxml env)
|
(define (expand-procedure sxml env)
|
||||||
((expand-section 'h4) `(,(car sxml) (rawcode ,@(cdr sxml))) env))
|
((expand-section 'h3) `(,(car sxml) (rawcode ,@(cdr sxml))) env))
|
||||||
|
|
||||||
(define (expand-macro sxml env)
|
(define (expand-macro sxml env)
|
||||||
(expand-procedure sxml env))
|
(expand-procedure sxml env))
|
||||||
|
@ -468,45 +354,31 @@
|
||||||
(define (get-contents x)
|
(define (get-contents x)
|
||||||
(if (null? x)
|
(if (null? x)
|
||||||
'()
|
'()
|
||||||
(let lp ((ls (cdr x))
|
(let ((d (caar x)))
|
||||||
(depth (caar x))
|
(let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '()))
|
||||||
(parent (cadr (car x)))
|
|
||||||
(kids '())
|
|
||||||
(res '()))
|
|
||||||
(define (collect)
|
(define (collect)
|
||||||
(cons `(li ,parent ,(get-contents (reverse kids))) res))
|
(cons `(li ,parent ,(get-contents (reverse kids))) res))
|
||||||
;; take a span of all sub-headers, recurse and repeat on next span
|
;; take a span of all sub-headers, recurse and repeat on next span
|
||||||
(cond
|
(cond
|
||||||
((null? ls)
|
((null? ls)
|
||||||
`(ol ,@(reverse (collect))))
|
`(ol ,@(reverse (collect))))
|
||||||
((> (caar ls) depth)
|
((> (caar ls) d)
|
||||||
(lp (cdr ls) depth parent (cons (car ls) kids) res))
|
(lp (cdr ls) parent (cons (car ls) kids) res))
|
||||||
(else
|
(else
|
||||||
(lp (cdr ls) (caar ls) (cadr (car ls)) '() (collect)))))))
|
(lp (cdr ls) (car (cdar ls)) '() (collect))))))))
|
||||||
|
|
||||||
(define (fix-header x)
|
(define (fix-header x)
|
||||||
`((!DOCTYPE html)
|
`(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
|
||||||
(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
|
|
||||||
(else '()))
|
(else '()))
|
||||||
"\n"
|
"\n"
|
||||||
(meta (@ (charset . "UTF-8")))
|
|
||||||
(style (@ (type . "text/css"))
|
(style (@ (type . "text/css"))
|
||||||
"
|
"
|
||||||
body {color: #000; background-color: #FFFFF8;}
|
body {color: #000; background-color: #FFF}
|
||||||
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 250px; height: 100%}
|
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 190px; height: 100%}
|
||||||
div#menu a:link {text-decoration: none}
|
div#main {position: absolute; top: 0; left: 200px; width: 540px; height: 100%}
|
||||||
div#main {font-size: large; position: absolute; top: 0; left: 260px; max-width: 590px; height: 100%}
|
div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;}
|
||||||
div#notes {position: relative; top: 2em; left: 620px; width: 200px; height: 0px; font-size: smaller;}
|
|
||||||
div#footer {padding-bottom: 50px}
|
div#footer {padding-bottom: 50px}
|
||||||
div#menu ol {list-style-position:inside; padding-left: 5px; margin-left: 5px}
|
|
||||||
div#menu ol ol {list-style: lower-alpha; padding-left: 15px; margin-left: 15px}
|
|
||||||
div#menu ol ol ol {list-style: decimal; padding-left: 5px; margin-left: 5px}
|
|
||||||
h2 { color: #888888; border-top: 3px solid #4588ba; }
|
|
||||||
h3 { color: #666666; border-top: 2px solid #4588ba; }
|
|
||||||
h4 { color: #222288; border-top: 1px solid #4588ba; }
|
|
||||||
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
|
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
|
||||||
.output { color: #000; background-color: beige; width: 100%; padding: 3px}
|
|
||||||
.error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px}
|
|
||||||
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
|
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
|
||||||
"
|
"
|
||||||
,(highlight-style))
|
,(highlight-style))
|
||||||
|
@ -525,7 +397,7 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(cons 'h1 (cdr x))
|
(cons 'h1 (cdr x))
|
||||||
x))
|
x))
|
||||||
x)
|
x)
|
||||||
(div (@ (id . "footer"))))))))
|
(div (@ (id . "footer")))))))
|
||||||
|
|
||||||
(define (fix-paragraphs x)
|
(define (fix-paragraphs x)
|
||||||
(let lp ((ls x) (p '()) (res '()))
|
(let lp ((ls x) (p '()) (res '()))
|
||||||
|
@ -641,14 +513,10 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
((v ('if ('and ('pair? (? o?)) ('pair? ('cdr (? o?))))
|
((v ('if ('and ('pair? (? o?)) ('pair? ('cdr (? o?))))
|
||||||
('cadr (? o?))
|
('cadr (? o?))
|
||||||
default))
|
default))
|
||||||
(lp (cdr ls)
|
(lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
|
||||||
(cons (cons v (+ 1 (if ordered? j i))) vars)
|
|
||||||
j))
|
|
||||||
((v ('and ('pair? (? o?)) ('pair? ('cdr (? o?)))
|
((v ('and ('pair? (? o?)) ('pair? ('cdr (? o?)))
|
||||||
('cadr (? o?))))
|
('cadr (? o?))))
|
||||||
(lp (cdr ls)
|
(lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
|
||||||
(cons (cons v (+ 1 (if ordered? j i))) vars)
|
|
||||||
j))
|
|
||||||
(else
|
(else
|
||||||
(lp (cdr ls) vars j))))
|
(lp (cdr ls) vars j))))
|
||||||
(else
|
(else
|
||||||
|
@ -660,13 +528,14 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(let lp ((ls var) (vars vars) (i i))
|
(let lp ((ls var) (vars vars) (i i))
|
||||||
(cond
|
(cond
|
||||||
((pair? ls)
|
((pair? ls)
|
||||||
(lp (cdr ls) (cons (cons (car ls) i) vars) (+ i 1)))
|
(lp (cdr ls) (cons (cons (caar ls) i) vars) (+ i 1)))
|
||||||
(else
|
(else
|
||||||
(extract body vars i)))))
|
(extract body vars i)))))
|
||||||
(_
|
(else
|
||||||
(let* ((opts (map car (sort vars < cdr)))
|
(let ((opts (map car (sort vars < cdr)))
|
||||||
(rest-var? (contains? x o))
|
(rest-var? (contains? x o)))
|
||||||
(tail (cond
|
(append (reverse pre)
|
||||||
|
(cond
|
||||||
((and (pair? opts) rest-var?)
|
((and (pair? opts) rest-var?)
|
||||||
(list (append opts o)))
|
(list (append opts o)))
|
||||||
(rest-var?
|
(rest-var?
|
||||||
|
@ -674,19 +543,17 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
((pair? opts)
|
((pair? opts)
|
||||||
(list opts))
|
(list opts))
|
||||||
(else
|
(else
|
||||||
o))))
|
'()))))))))))))
|
||||||
(append (reverse pre) tail))))))))))
|
|
||||||
|
|
||||||
(define (get-procedure-signature mod id proc)
|
(define (get-procedure-signature mod id proc)
|
||||||
(protect (exn (else '()))
|
|
||||||
(cond ((and mod (procedure? proc) (procedure-signature id mod))
|
(cond ((and mod (procedure? proc) (procedure-signature id mod))
|
||||||
=> (lambda (sig)
|
=> (lambda (sig)
|
||||||
(list (cons (or id (procedure-name proc)) (cdr sig)))))
|
(list (cons (or id (procedure-name proc)) (cdr sig)))))
|
||||||
(else '()))))
|
(else '())))
|
||||||
|
|
||||||
(define (get-value-signature mod id proc name value)
|
(define (get-value-signature mod id proc name value)
|
||||||
(match value
|
(match value
|
||||||
(((or 'let 'let* 'letrec 'letrec*) vars body0 ... body)
|
(('(or let let* letrec letrec*) vars body0 ... body)
|
||||||
(get-value-signature mod id proc name body))
|
(get-value-signature mod id proc name body))
|
||||||
(('lambda args . body)
|
(('lambda args . body)
|
||||||
(list (cons name (get-optionals-signature args body))))
|
(list (cons name (get-optionals-signature args body))))
|
||||||
|
@ -695,6 +562,8 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(('begin body0 ... body) (get-value-signature mod id proc name body))
|
(('begin body0 ... body) (get-value-signature mod id proc name body))
|
||||||
(else (get-procedure-signature mod id proc))))
|
(else (get-procedure-signature mod id proc))))
|
||||||
|
|
||||||
|
;; TODO: analyze and match on AST instead of making assumptions about
|
||||||
|
;; bindings
|
||||||
(define (get-signature mod id proc source form)
|
(define (get-signature mod id proc source form)
|
||||||
(match form
|
(match form
|
||||||
(('define (name args ...) . body)
|
(('define (name args ...) . body)
|
||||||
|
@ -708,11 +577,7 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(map (lambda (x) (cons name (cdr x)))
|
(map (lambda (x) (cons name (cdr x)))
|
||||||
(filter external-clause? clause)))
|
(filter external-clause? clause)))
|
||||||
(else
|
(else
|
||||||
(cond
|
(get-procedure-signature mod id proc))))
|
||||||
((procedure-analysis proc mod)
|
|
||||||
=> (lambda (lam) (list (cons (lambda-name lam) (lambda-params lam)))))
|
|
||||||
(else
|
|
||||||
(get-procedure-signature mod id proc))))))
|
|
||||||
|
|
||||||
(define (get-ffi-signatures form)
|
(define (get-ffi-signatures form)
|
||||||
(match form
|
(match form
|
||||||
|
@ -725,8 +590,6 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
args)))))
|
args)))))
|
||||||
(('define-c-const type (or (name _) name))
|
(('define-c-const type (or (name _) name))
|
||||||
(list (list 'const: type name)))
|
(list (list 'const: type name)))
|
||||||
(('cond-expand (test . clauses) . rest)
|
|
||||||
(append-map get-ffi-signatures clauses))
|
|
||||||
(((or 'define-c-struct 'define-c-class 'define-c-type) name . rest)
|
(((or 'define-c-struct 'define-c-class 'define-c-type) name . rest)
|
||||||
(let lp ((ls rest) (res '()))
|
(let lp ((ls rest) (res '()))
|
||||||
(cond
|
(cond
|
||||||
|
@ -755,7 +618,7 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(let ((sections '(section subsection subsubsection subsubsubsection)))
|
(let ((sections '(section subsection subsubsection subsubsubsection)))
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(cond ((memq x sections) => length)
|
(cond ((memq x sections) => length)
|
||||||
((memq x '(procedure macro)) (section-number 'subsubsection))
|
((memq x '(procedure macro)) (section-number 'subsection))
|
||||||
(else 0)))))
|
(else 0)))))
|
||||||
|
|
||||||
(define (section>=? x n)
|
(define (section>=? x n)
|
||||||
|
@ -813,10 +676,9 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(write-to-string sig)))
|
(write-to-string sig)))
|
||||||
|
|
||||||
(define (insert-signature orig-ls name sig)
|
(define (insert-signature orig-ls name sig)
|
||||||
(let ((sig (if (pair? sig) sig (and name (list name)))))
|
|
||||||
(cond
|
(cond
|
||||||
((not (pair? sig))
|
((not (pair? sig))
|
||||||
'())
|
orig-ls)
|
||||||
(else
|
(else
|
||||||
(let ((name
|
(let ((name
|
||||||
(cond
|
(cond
|
||||||
|
@ -827,16 +689,15 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(let lp ((ls orig-ls) (rev-pre '()))
|
(let lp ((ls orig-ls) (rev-pre '()))
|
||||||
(cond
|
(cond
|
||||||
((or (null? ls)
|
((or (null? ls)
|
||||||
(section>=? (car ls) (section-number 'subsubsection)))
|
(section>=? (car ls) (section-number 'subsection)))
|
||||||
`(,@(reverse rev-pre)
|
`(,@(reverse rev-pre)
|
||||||
,@(if (and (pair? ls)
|
,@(if (and (pair? ls)
|
||||||
(section-describes?
|
(section-describes?
|
||||||
(extract-sxml
|
(extract-sxml '(subsection procedure macro)
|
||||||
'(subsubsection procedure macro)
|
|
||||||
(car ls))
|
(car ls))
|
||||||
name))
|
name))
|
||||||
'()
|
'()
|
||||||
`((subsubsection
|
`((subsection
|
||||||
tag: ,(write-to-string name)
|
tag: ,(write-to-string name)
|
||||||
(rawcode
|
(rawcode
|
||||||
,@(if (and (pair? (car sig)) (eq? 'const: (caar sig)))
|
,@(if (and (pair? (car sig)) (eq? 'const: (caar sig)))
|
||||||
|
@ -845,7 +706,7 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(intersperse (map write-signature sig) '(br)))))))
|
(intersperse (map write-signature sig) '(br)))))))
|
||||||
,@ls))
|
,@ls))
|
||||||
(else
|
(else
|
||||||
(lp (cdr ls) (cons (car ls) rev-pre))))))))))
|
(lp (cdr ls) (cons (car ls) rev-pre)))))))))
|
||||||
|
|
||||||
;;> Extract inline Scribble documentation (with the ;;> prefix) from
|
;;> Extract inline Scribble documentation (with the ;;> prefix) from
|
||||||
;;> the source file \var{file}, associating any signatures from the
|
;;> the source file \var{file}, associating any signatures from the
|
||||||
|
@ -853,22 +714,17 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
|
|
||||||
(define (extract-file-docs mod file all-defs strict? . o)
|
(define (extract-file-docs mod file all-defs strict? . o)
|
||||||
;; extract (<file> . <line>) macro source or
|
;; extract (<file> . <line>) macro source or
|
||||||
;; (<offset> <file . <line>) procedure source or
|
;; (<offset> <file . <line>>) procedure source
|
||||||
;; ((<offset> <file . <line>) ...) bytecode sources
|
|
||||||
(define (source-line source)
|
(define (source-line source)
|
||||||
(and (pair? source)
|
(and (pair? source)
|
||||||
(cond
|
(if (string? (car source))
|
||||||
((string? (car source))
|
|
||||||
(and (equal? file (car source))
|
(and (equal? file (car source))
|
||||||
(number? (cdr source))
|
(number? (cdr source))
|
||||||
(cdr source)))
|
(cdr source))
|
||||||
((pair? (car source))
|
|
||||||
(source-line (car source)))
|
|
||||||
(else
|
|
||||||
(and (number? (car source))
|
(and (number? (car source))
|
||||||
(pair? (cdr source))
|
(pair? (cdr source))
|
||||||
(equal? file (cadr source))
|
(equal? file (cadr source))
|
||||||
(cddr source))))))
|
(cddr source)))))
|
||||||
(define (read-to-paren in)
|
(define (read-to-paren in)
|
||||||
(let lp1 ((res '()))
|
(let lp1 ((res '()))
|
||||||
(let ((ch (peek-char in)))
|
(let ((ch (peek-char in)))
|
||||||
|
@ -1038,28 +894,21 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(else #f)))
|
(else #f)))
|
||||||
|
|
||||||
;; helper for below functions
|
;; helper for below functions
|
||||||
(define (extract-module-docs-from-files mod srcs includes stubs strict? exports . o)
|
(define (extract-module-docs-from-files mod srcs includes stubs strict? exports)
|
||||||
(let ((dir (or (and (pair? o) (car o)) (module-dir mod)))
|
(let ((defs (map (lambda (x)
|
||||||
(defs (map (lambda (x)
|
(let ((val (and mod (module-ref mod x))))
|
||||||
(let ((val (and mod (protect (exn (else #f))
|
|
||||||
(module-ref mod x)))))
|
|
||||||
`(,x ,val ,(object-source val))))
|
`(,x ,val ,(object-source val))))
|
||||||
exports)))
|
exports)))
|
||||||
(define (resolve-file file)
|
|
||||||
(let ((res (make-path dir file)))
|
|
||||||
(if (file-exists? res)
|
|
||||||
res
|
|
||||||
file)))
|
|
||||||
(append
|
(append
|
||||||
(reverse
|
(reverse
|
||||||
(append-map (lambda (x)
|
(append-map (lambda (x)
|
||||||
(extract-file-docs mod (resolve-file x) defs strict? 'module))
|
(extract-file-docs mod x defs strict? 'module))
|
||||||
srcs))
|
srcs))
|
||||||
(reverse
|
(reverse
|
||||||
(append-map (lambda (x) (extract-file-docs mod (resolve-file x) defs strict?))
|
(append-map (lambda (x) (extract-file-docs mod x defs strict?))
|
||||||
includes))
|
includes))
|
||||||
(reverse
|
(reverse
|
||||||
(append-map (lambda (x) (extract-file-docs mod (resolve-file x) defs strict? 'ffi))
|
(append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
|
||||||
stubs)))))
|
stubs)))))
|
||||||
|
|
||||||
;;> Extract the literate Scribble docs from module \var{mod-name} and
|
;;> Extract the literate Scribble docs from module \var{mod-name} and
|
||||||
|
@ -1090,55 +939,30 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
|
||||||
(memq (caar forms) '(define-library library))))
|
(memq (caar forms) '(define-library library))))
|
||||||
(error "file doesn't define a library" file))
|
(error "file doesn't define a library" file))
|
||||||
(let* ((mod-form (car forms))
|
(let* ((mod-form (car forms))
|
||||||
(mod-name (cadr mod-form))
|
(mod-name (cadr mod-form)))
|
||||||
(lib-dir (module-lib-dir file mod-name))
|
(load file (vector-ref (find-module '(meta)) 1))
|
||||||
(orig-mod-path (current-module-path))
|
(let* ((mod (protect (exn (else #f)) (load-module mod-name)))
|
||||||
(new-mod-path (cons lib-dir orig-mod-path))
|
(dir (path-directory file))
|
||||||
(mod (protect (exn (else #f))
|
(resolve (lambda (f) (make-path dir f))))
|
||||||
(dynamic-wind
|
(define (get-forms name)
|
||||||
(lambda () (current-module-path new-mod-path))
|
|
||||||
(lambda ()
|
|
||||||
(let ((mod (load-module mod-name)))
|
|
||||||
(protect (exn (else #f)) (analyze-module mod-name))
|
|
||||||
mod))
|
|
||||||
(lambda () (current-module-path orig-mod-path)))))
|
|
||||||
(dir (path-directory file)))
|
|
||||||
(define (get-forms ls names dir . o)
|
|
||||||
(let ((resolve? (and (pair? o) (car o))))
|
|
||||||
(let lp ((ls ls) (res '()))
|
|
||||||
(if (null? ls)
|
|
||||||
(reverse res)
|
|
||||||
(let ((x (car ls)))
|
|
||||||
(lp (cdr ls)
|
|
||||||
(append
|
|
||||||
(if (and (pair? x) (memq (car x) names))
|
|
||||||
(map (lambda (y)
|
|
||||||
(if (and resolve? (string? y))
|
|
||||||
(make-path dir y)
|
|
||||||
y))
|
|
||||||
(reverse (cdr x)))
|
|
||||||
'())
|
|
||||||
(if (and (pair? x)
|
|
||||||
(eq? 'include-library-declarations (car x)))
|
|
||||||
(append-map
|
(append-map
|
||||||
(lambda (inc)
|
(lambda (x) (if (and (pair? x) (eq? name (car x))) (cdr x) '()))
|
||||||
(let* ((file (make-path dir inc))
|
(cddr mod-form)))
|
||||||
(sexps (file->sexp-list file))
|
|
||||||
(dir (path-directory file)))
|
|
||||||
(get-forms sexps names dir resolve?)))
|
|
||||||
(cdr x))
|
|
||||||
'())
|
|
||||||
res)))))))
|
|
||||||
(define (get-exports)
|
(define (get-exports)
|
||||||
(if mod (module-exports mod) (get-forms (cddr mod-form) '(exports) dir)))
|
(if mod (module-exports mod) (get-forms 'exports)))
|
||||||
(define (get-decls)
|
(define (get-decls)
|
||||||
(get-forms (cddr mod-form) '(include-library-declarations) dir #t))
|
(if mod
|
||||||
|
(module-include-library-declarations mod)
|
||||||
|
(map resolve (get-forms 'include-library-declarations))))
|
||||||
(define (get-includes)
|
(define (get-includes)
|
||||||
(get-forms (cddr mod-form) '(include include-ci) dir #t))
|
(if mod
|
||||||
|
(module-includes mod)
|
||||||
|
(map resolve (get-forms 'include))))
|
||||||
(define (get-shared-includes)
|
(define (get-shared-includes)
|
||||||
(map (lambda (f) (string-append f ".stub"))
|
(if mod
|
||||||
(get-forms (cddr mod-form) '(include-shared) dir #t)))
|
(module-shared-includes mod)
|
||||||
|
(map resolve (get-forms 'shared-include))))
|
||||||
(let* ((exports (if (pair? o) (car o) (get-exports)))
|
(let* ((exports (if (pair? o) (car o) (get-exports)))
|
||||||
(srcs (cons file (get-decls))))
|
(srcs (cons file (get-decls))))
|
||||||
(extract-module-docs-from-files
|
(extract-module-docs-from-files
|
||||||
mod srcs (get-includes) (get-shared-includes) strict? exports)))))
|
mod srcs (get-includes) (get-shared-includes) strict? exports))))))
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
|
|
||||||
(define-library (chibi doc)
|
(define-library (chibi doc)
|
||||||
(import
|
(import
|
||||||
(except (chibi) eval) (scheme eval) (srfi 1) (srfi 39) (srfi 95)
|
(except (chibi) eval) (scheme eval) (srfi 1) (srfi 95)
|
||||||
(chibi modules) (chibi ast) (chibi io) (chibi match)
|
(chibi modules) (chibi ast) (chibi io) (chibi match)
|
||||||
(chibi time) (chibi filesystem) (chibi process) (chibi pathname)
|
(chibi time) (chibi filesystem) (chibi process) (chibi pathname)
|
||||||
(chibi string) (chibi scribble) (chibi sxml) (chibi highlight)
|
(chibi string) (chibi scribble) (chibi sxml) (chibi highlight)
|
||||||
|
@ -11,6 +11,5 @@
|
||||||
generate-docs expand-docs fixup-docs
|
generate-docs expand-docs fixup-docs
|
||||||
extract-module-docs extract-module-file-docs extract-file-docs
|
extract-module-docs extract-module-file-docs extract-file-docs
|
||||||
make-default-doc-env make-module-doc-env
|
make-default-doc-env make-module-doc-env
|
||||||
get-optionals-signature
|
get-optionals-signature)
|
||||||
ansi->sxml)
|
|
||||||
(include "doc.scm"))
|
(include "doc.scm"))
|
||||||
|
|
|
@ -1,14 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi edit-distance-test)
|
|
||||||
(export run-tests)
|
|
||||||
(import (scheme base) (chibi edit-distance) (chibi test))
|
|
||||||
(begin
|
|
||||||
(define (run-tests)
|
|
||||||
(test-begin "(chibi edit-distance)")
|
|
||||||
(test 0 (edit-distance "" ""))
|
|
||||||
(test 0 (edit-distance "same" "same"))
|
|
||||||
(test 1 (edit-distance "same" "game"))
|
|
||||||
(test 2 (edit-distance "same" "sand"))
|
|
||||||
(test 3 (edit-distance "kitten" "sitting"))
|
|
||||||
(test 3 (edit-distance "Saturday" "Sunday"))
|
|
||||||
(test-end))))
|
|
|
@ -1,52 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi edit-distance)
|
|
||||||
(export edit-distance find-nearest-edits)
|
|
||||||
(import (scheme base) (srfi 130))
|
|
||||||
(begin
|
|
||||||
;;> Returns the levenshtein distance between s1 and s2 - a cost of
|
|
||||||
;;> 1 per character insertion, deletion or update. Runs in
|
|
||||||
;;> quadratic time and linear memory.
|
|
||||||
;;>
|
|
||||||
;;> \example{(edit-distance "same" "same")}
|
|
||||||
;;> \example{(edit-distance "same" "sand")}
|
|
||||||
;;> \example{(edit-distance "Saturday" "Sunday")}
|
|
||||||
(define (edit-distance s1 s2)
|
|
||||||
(let* ((len1 (string-length s1))
|
|
||||||
(len2 (string-length s2))
|
|
||||||
(vec (make-vector (+ len1 1) 0)))
|
|
||||||
(do ((i 0 (+ i 1)))
|
|
||||||
((> i len1))
|
|
||||||
(vector-set! vec i i))
|
|
||||||
(do ((i 1 (+ i 1))
|
|
||||||
(sc2 (string-cursor-start s2) (string-cursor-next s2 sc2)))
|
|
||||||
((> i len2)
|
|
||||||
(vector-ref vec len1))
|
|
||||||
(vector-set! vec 0 i)
|
|
||||||
(let ((ch2 (string-ref/cursor s2 sc2)))
|
|
||||||
(let lp ((j 1)
|
|
||||||
(sc1 (string-cursor-start s1))
|
|
||||||
(last-diag (- i 1)))
|
|
||||||
(when (<= j len1)
|
|
||||||
(let ((old-diag (vector-ref vec j))
|
|
||||||
(ch1 (string-ref/cursor s1 sc1)))
|
|
||||||
(vector-set! vec j (min (+ (vector-ref vec j) 1)
|
|
||||||
(+ (vector-ref vec (- j 1)) 1)
|
|
||||||
(+ last-diag
|
|
||||||
(if (eqv? ch1 ch2) 0 1))))
|
|
||||||
(lp (+ j 1)
|
|
||||||
(string-cursor-next s1 sc1)
|
|
||||||
old-diag))))))))
|
|
||||||
;;> Returns a list of strings in \var{str-ls} with the smallest
|
|
||||||
;;> edit distance to \var{str}, preserving order. If
|
|
||||||
;;> \var{max-distance} is provided and positive, only return if
|
|
||||||
;;> the edits are less or equal to that distance.
|
|
||||||
(define (find-nearest-edits str str-ls . o)
|
|
||||||
(let ((max-distance (if (pair? o) (car o) 1e100)))
|
|
||||||
(let lp ((ls str-ls) (dist (+ max-distance 1)) (res '()))
|
|
||||||
(if (null? ls)
|
|
||||||
(reverse res)
|
|
||||||
(let ((ed (edit-distance str (car ls))))
|
|
||||||
(cond
|
|
||||||
((= ed dist) (lp (cdr ls) dist (cons (car ls) res)))
|
|
||||||
((< ed dist) (lp (cdr ls) ed (list (car ls))))
|
|
||||||
(else (lp (cdr ls) dist res))))))))))
|
|
|
@ -45,5 +45,5 @@
|
||||||
(lp (- i 1))))))))))
|
(lp (- i 1))))))))))
|
||||||
(else
|
(else
|
||||||
(equal? a b))))
|
(equal? a b))))
|
||||||
(let ((res (equal?/bounded a b 10000 10000)))
|
(let ((res (equal?/bounded a b 100000 100000)))
|
||||||
(and res (or (> res 0) (equiv? a b)) #t))))
|
(and res (or (> res 0) (equiv? a b)) #t))))
|
||||||
|
|
|
@ -1,14 +1,7 @@
|
||||||
(define-library (chibi filesystem-test)
|
(define-library (chibi filesystem-test)
|
||||||
(export run-tests)
|
(export run-tests)
|
||||||
(import (scheme base) (scheme file) (scheme write)
|
(import (chibi) (chibi io) (chibi filesystem) (chibi test) (srfi 33))
|
||||||
(chibi filesystem) (chibi test))
|
|
||||||
(cond-expand
|
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
|
||||||
(else (import (srfi 60))))
|
|
||||||
(begin
|
(begin
|
||||||
(define (port->string in)
|
|
||||||
(read-string 1024 in))
|
|
||||||
(define (run-tests)
|
(define (run-tests)
|
||||||
(define tmp-file "/tmp/chibi-fs-test-0123456789")
|
(define tmp-file "/tmp/chibi-fs-test-0123456789")
|
||||||
(define tmp-file2 "/tmp/chibi-fs-test-0123456789-2")
|
(define tmp-file2 "/tmp/chibi-fs-test-0123456789-2")
|
||||||
|
|
|
@ -10,11 +10,10 @@
|
||||||
(let ((mode (if (pair? o) (car o) #o755)))
|
(let ((mode (if (pair? o) (car o) #o755)))
|
||||||
(or (file-directory? dir)
|
(or (file-directory? dir)
|
||||||
(create-directory dir mode)
|
(create-directory dir mode)
|
||||||
(let* ((start (string-cursor-start dir))
|
(let ((slash
|
||||||
(slash
|
(string-find-right dir #\/ 0 (string-skip-right dir #\/))))
|
||||||
(string-find-right dir #\/ start (string-skip-right dir #\/))))
|
(and (> slash 0)
|
||||||
(and (string-cursor>? slash start)
|
(let ((parent (substring-cursor dir 0 slash)))
|
||||||
(let ((parent (substring-cursor dir start slash)))
|
|
||||||
(and (not (equal? parent dir))
|
(and (not (equal? parent dir))
|
||||||
(not (file-exists? parent))
|
(not (file-exists? parent))
|
||||||
(create-directory* parent mode)
|
(create-directory* parent mode)
|
||||||
|
@ -78,7 +77,7 @@
|
||||||
(define (delete-file file)
|
(define (delete-file file)
|
||||||
(if (not (%delete-file file))
|
(if (not (%delete-file file))
|
||||||
(raise-continuable
|
(raise-continuable
|
||||||
(make-exception 'file "couldn't delete file" (list file) delete-file #f))))
|
(make-exception 'file "couldn't delete file" file delete-file #f))))
|
||||||
|
|
||||||
;;> Recursively delete all files and directories under \var{dir}.
|
;;> Recursively delete all files and directories under \var{dir}.
|
||||||
;;> Unless optional arg \var{ignore-errors?} is true, raises an error
|
;;> Unless optional arg \var{ignore-errors?} is true, raises an error
|
||||||
|
@ -104,9 +103,7 @@
|
||||||
(define (with-directory dir thunk)
|
(define (with-directory dir thunk)
|
||||||
(let ((pwd (current-directory)))
|
(let ((pwd (current-directory)))
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(lambda ()
|
(lambda () (change-directory dir))
|
||||||
(if (not (change-directory dir))
|
|
||||||
(error "couldn't change directory" dir)))
|
|
||||||
thunk
|
thunk
|
||||||
(lambda () (change-directory pwd)))))
|
(lambda () (change-directory pwd)))))
|
||||||
|
|
||||||
|
@ -125,18 +122,10 @@
|
||||||
(define (file-group x) (stat-gid (if (stat? x) x (file-status x))))
|
(define (file-group x) (stat-gid (if (stat? x) x (file-status x))))
|
||||||
(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x))))
|
(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x))))
|
||||||
(define (file-size x) (stat-size (if (stat? x) x (file-status x))))
|
(define (file-size x) (stat-size (if (stat? x) x (file-status x))))
|
||||||
(cond-expand
|
|
||||||
(windows
|
|
||||||
(define (file-block-size x) 1)
|
|
||||||
(define (file-num-blocks x) (file-size x)))
|
|
||||||
(else
|
|
||||||
(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
|
(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
|
||||||
(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))))
|
(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))
|
||||||
(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
|
(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
|
||||||
(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
|
(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
|
||||||
(define (file-modification-time/safe x)
|
|
||||||
(let ((status (if (stat? x) x (file-status x))))
|
|
||||||
(and status (stat-mtime status))))
|
|
||||||
(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
|
(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
|
||||||
|
|
||||||
;;> File status accessors. \var{x} should be a string indicating
|
;;> File status accessors. \var{x} should be a string indicating
|
||||||
|
@ -156,13 +145,9 @@
|
||||||
(define (file-character? x) (file-test-mode S_ISCHR x))
|
(define (file-character? x) (file-test-mode S_ISCHR x))
|
||||||
(define (file-block? x) (file-test-mode S_ISBLK x))
|
(define (file-block? x) (file-test-mode S_ISBLK x))
|
||||||
(define (file-fifo? x) (file-test-mode S_ISFIFO x))
|
(define (file-fifo? x) (file-test-mode S_ISFIFO x))
|
||||||
(cond-expand
|
|
||||||
(windows
|
|
||||||
(define (file-link? x) #f))
|
|
||||||
(else
|
|
||||||
(define (file-link? x)
|
(define (file-link? x)
|
||||||
(let ((st (if (stat? x) x (file-link-status x))))
|
(let ((st (if (stat? x) x (file-link-status x))))
|
||||||
(and st (S_ISLNK (stat-mode st)))))))
|
(and st (S_ISLNK (stat-mode st)))))
|
||||||
(define (file-socket? x) (file-test-mode S_ISSOCK x))
|
(define (file-socket? x) (file-test-mode S_ISSOCK x))
|
||||||
(define (file-exists? x) (and (if (stat? x) #t (file-status x)) #t))
|
(define (file-exists? x) (and (if (stat? x) #t (file-status x)) #t))
|
||||||
|
|
||||||
|
@ -191,12 +176,8 @@
|
||||||
;;> Returns the path the symbolic link \var{file} points to, or
|
;;> Returns the path the symbolic link \var{file} points to, or
|
||||||
;;> \scheme{#f} on error.
|
;;> \scheme{#f} on error.
|
||||||
|
|
||||||
(cond-expand
|
|
||||||
(windows
|
|
||||||
(define (read-link file) #f))
|
|
||||||
(else
|
|
||||||
(define (read-link file)
|
(define (read-link file)
|
||||||
(let* ((buf (make-string 512))
|
(let* ((buf (make-string 512))
|
||||||
(res (readlink file buf 512)))
|
(res (readlink file buf 512)))
|
||||||
(and (positive? res)
|
(and (positive? res)
|
||||||
(substring buf 0 res))))))
|
(substring buf 0 res))))
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Reference in a new issue