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" have entirely different histories.
721 changed files with 12201 additions and 77955 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
|
|
86
.gitignore
vendored
86
.gitignore
vendored
|
@ -1,86 +0,0 @@
|
||||||
# Object files
|
|
||||||
*.o
|
|
||||||
*.bc
|
|
||||||
*.ko
|
|
||||||
*.obj
|
|
||||||
*.elf
|
|
||||||
|
|
||||||
# Precompiled Headers
|
|
||||||
*.gch
|
|
||||||
*.pch
|
|
||||||
|
|
||||||
# Libraries
|
|
||||||
*.lib
|
|
||||||
*.a
|
|
||||||
*.la
|
|
||||||
*.lo
|
|
||||||
|
|
||||||
# Shared objects (inc. Windows DLLs)
|
|
||||||
*.dll
|
|
||||||
*.dll.*
|
|
||||||
*.so
|
|
||||||
*.so.*
|
|
||||||
*.dylib
|
|
||||||
|
|
||||||
# Executables
|
|
||||||
*.exe
|
|
||||||
*.out
|
|
||||||
*.app
|
|
||||||
*.i*86
|
|
||||||
*.x86_64
|
|
||||||
*.hex
|
|
||||||
|
|
||||||
# Debug files
|
|
||||||
*.dSYM/
|
|
||||||
|
|
||||||
# Snow Meta files
|
|
||||||
lib/.*.meta
|
|
||||||
|
|
||||||
# Generated files
|
|
||||||
chibi-scheme
|
|
||||||
chibi-scheme-emscripten
|
|
||||||
chibi-scheme.pc
|
|
||||||
include/chibi/install.h
|
|
||||||
lib/chibi/emscripten.c
|
|
||||||
lib/chibi/filesystem.c
|
|
||||||
lib/chibi/io/io.c
|
|
||||||
lib/chibi/net.c
|
|
||||||
lib/chibi/process.c
|
|
||||||
lib/chibi/pty.c
|
|
||||||
lib/chibi/snow/install.sld
|
|
||||||
lib/chibi/stty.c
|
|
||||||
lib/chibi/system.c
|
|
||||||
lib/chibi/time.c
|
|
||||||
lib/chibi/win32/process-win32.c
|
|
||||||
lib/scheme/bytevector.c
|
|
||||||
lib/srfi/144/math.c
|
|
||||||
lib/srfi/160/uvprims.c
|
|
||||||
*.tgz
|
|
||||||
*.bz2
|
|
||||||
*.xz
|
|
||||||
*.html
|
|
||||||
*.img
|
|
||||||
*.err
|
|
||||||
*.fasl
|
|
||||||
*.txt
|
|
||||||
!CMakeLists.txt
|
|
||||||
*.test
|
|
||||||
*.train
|
|
||||||
*.h5
|
|
||||||
!index.html
|
|
||||||
|
|
||||||
benchmarks/gabriel/times.tsv
|
|
||||||
examples/snow-fort
|
|
||||||
examples/synthcode
|
|
||||||
tests/snow/repo-cache
|
|
||||||
tests/snow/repo*/repo.scm
|
|
||||||
tests/snow/tmp-root
|
|
||||||
tmp
|
|
||||||
/lib/chibi/crypto/crypto.c
|
|
||||||
/chibi-scheme-ulimit
|
|
||||||
/clibs.c
|
|
||||||
|
|
||||||
js/chibi.*
|
|
||||||
|
|
||||||
build-lib/chibi/char-set/derived.scm
|
|
||||||
build-lib/chibi/char-set/width.scm
|
|
|
@ -37,7 +37,6 @@ lib/chibi/process.c
|
||||||
lib/chibi/system.c
|
lib/chibi/system.c
|
||||||
lib/chibi/time.c
|
lib/chibi/time.c
|
||||||
lib/chibi/stty.c
|
lib/chibi/stty.c
|
||||||
lib/chibi/emscripten.c
|
|
||||||
doc/*.html
|
doc/*.html
|
||||||
doc/lib/chibi/*.html
|
doc/lib/chibi/*.html
|
||||||
misc/*
|
misc/*
|
||||||
|
|
|
@ -1,4 +0,0 @@
|
||||||
language: c
|
|
||||||
compiler:
|
|
||||||
- clang
|
|
||||||
- gcc
|
|
42
AUTHORS
42
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,34 @@ 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
|
|
||||||
* 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
|
|
||||||
* 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-2012 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
|
||||||
|
|
449
Makefile
449
Makefile
|
@ -1,112 +1,88 @@
|
||||||
# -*- 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
|
||||||
.DEFAULT_GOAL := all
|
.DEFAULT_GOAL := all
|
||||||
|
|
||||||
CHIBI_VERSION ?= $(shell cat VERSION)
|
SOVERSION ?= $(shell cat VERSION)
|
||||||
SOVERSION ?= $(CHIBI_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
|
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
|
|
||||||
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/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_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 ?=
|
|
||||||
|
|
||||||
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) lib/srfi/18/threads$(SO) \
|
||||||
$(EXTRA_COMPILED_LIBS) \
|
lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) lib/srfi/39/param$(SO) \
|
||||||
lib/srfi/27/rand$(SO) lib/srfi/151/bit$(SO) \
|
lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
|
||||||
lib/srfi/39/param$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
|
lib/scheme/time$(SO)
|
||||||
lib/srfi/98/env$(SO) lib/srfi/144/math$(SO) lib/srfi/160/uvprims$(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 := 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 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
|
||||||
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 "'`cat 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,40 +95,36 @@ 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)
|
||||||
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) -o $@ $^ $(XLDFLAGS)
|
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) -o $@ $^ $(XLDFLAGS)
|
||||||
|
|
||||||
libchibi-scheme$(SO_VERSIONED_SUFFIX): $(SEXP_OBJS) $(EVAL_OBJS)
|
libchibi-scheme$(SO).$(SOVERSION): $(SEXP_OBJS) $(EVAL_OBJS)
|
||||||
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(LIBCHIBI_FLAGS) -o $@ $^ $(XLDFLAGS)
|
$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(LIBCHIBI_FLAGS) -o $@ $^ $(XLDFLAGS)
|
||||||
|
|
||||||
libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX): libchibi-scheme$(SO_VERSIONED_SUFFIX)
|
libchibi-scheme$(SO).$(SOVERSION_MAJOR): libchibi-scheme$(SO).$(SOVERSION)
|
||||||
$(LN) $< $@
|
$(LN) -sf $< $@
|
||||||
|
|
||||||
libchibi-scheme$(SO): libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
libchibi-scheme$(SO): libchibi-scheme$(SO).$(SOVERSION_MAJOR)
|
||||||
$(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-scheme$(EXE)
|
||||||
if [ -d .git ]; then \
|
$(FIND) lib -name \*.sld | $(CHIBI) $(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 +132,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 `cat VERSION` > $@
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
# Dist builds - rules to build generated files included in distribution
|
# Dist builds - rules to build generated files included in distribution
|
||||||
|
@ -205,25 +161,14 @@ data/%.txt:
|
||||||
build-lib/chibi/char-set/derived.scm: data/UnicodeData.txt data/DerivedCoreProperties.txt chibi-scheme$(EXE)
|
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,24 +196,53 @@ 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-threads: chibi-scheme$(EXE) lib/srfi/18/threads$(SO) lib/srfi/39/param$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/time$(SO)
|
||||||
$(CHIBI) tests/snow/snow-tests.scm
|
$(CHIBI) -xchibi tests/thread-tests.scm
|
||||||
|
|
||||||
|
test-numbers: chibi-scheme$(EXE)
|
||||||
|
$(CHIBI) -xchibi tests/numeric-tests.scm
|
||||||
|
|
||||||
|
test-flonums: chibi-scheme$(EXE)
|
||||||
|
$(CHIBI) -xchibi tests/flonum-tests.scm
|
||||||
|
|
||||||
|
test-hash: chibi-scheme$(EXE) lib/srfi/69/hash$(SO)
|
||||||
|
$(CHIBI) -xchibi tests/hash-tests.scm
|
||||||
|
|
||||||
|
test-io: chibi-scheme$(EXE) lib/chibi/io/io$(SO)
|
||||||
|
$(CHIBI) -xchibi tests/io-tests.scm
|
||||||
|
|
||||||
|
test-match: chibi-scheme$(EXE)
|
||||||
|
$(CHIBI) -xchibi tests/match-tests.scm
|
||||||
|
|
||||||
|
test-loop: chibi-scheme$(EXE)
|
||||||
|
$(CHIBI) -xchibi tests/loop-tests.scm
|
||||||
|
|
||||||
|
test-sort: chibi-scheme$(EXE) lib/srfi/33/bit$(SO)
|
||||||
|
$(CHIBI) -xchibi tests/sort-tests.scm
|
||||||
|
|
||||||
|
test-srfi-1: chibi-scheme$(EXE)
|
||||||
|
$(CHIBI) -xchibi tests/srfi-1-tests.scm
|
||||||
|
|
||||||
|
test-records: chibi-scheme$(EXE)
|
||||||
|
$(CHIBI) -xchibi tests/record-tests.scm
|
||||||
|
|
||||||
|
test-weak: chibi-scheme$(EXE) lib/chibi/weak$(SO)
|
||||||
|
$(CHIBI) -xchibi tests/weak-tests.scm
|
||||||
|
|
||||||
test-unicode: chibi-scheme$(EXE)
|
test-unicode: chibi-scheme$(EXE)
|
||||||
$(CHIBI) -xchibi tests/unicode-tests.scm
|
$(CHIBI) -xchibi tests/unicode-tests.scm
|
||||||
|
|
||||||
test-division: chibi-scheme$(EXE)
|
test-process: chibi-scheme$(EXE) lib/chibi/process$(SO)
|
||||||
$(CHIBI) tests/division-tests.scm
|
$(CHIBI) -xchibi tests/process-tests.scm
|
||||||
|
|
||||||
|
test-system: chibi-scheme$(EXE) lib/chibi/system$(SO)
|
||||||
|
$(CHIBI) -xchibi tests/system-tests.scm
|
||||||
|
|
||||||
test-libs: chibi-scheme$(EXE)
|
test-libs: chibi-scheme$(EXE)
|
||||||
@echo "\e[1mloading tests first, it may take a while to see output...\e[0m"
|
$(CHIBI) -xchibi tests/lib-tests.scm
|
||||||
$(CHIBI) tests/lib-tests.scm
|
|
||||||
|
|
||||||
test-r5rs: chibi-scheme$(EXE)
|
test-r5rs: chibi-scheme$(EXE)
|
||||||
$(CHIBI) -xchibi tests/r5rs-tests.scm
|
$(CHIBI) -xchibi tests/r5rs-tests.scm
|
||||||
|
@ -276,16 +250,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 +263,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/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/
|
||||||
|
@ -337,91 +296,52 @@ install-base: all
|
||||||
$(INSTALL) -m0644 lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
|
$(INSTALL) -m0644 lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
|
||||||
$(INSTALL) -m0644 lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
|
$(INSTALL) -m0644 lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
|
||||||
$(INSTALL) -m0644 lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/
|
$(INSTALL) -m0644 lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/
|
||||||
$(INSTALL) -m0644 lib/chibi/regexp/*.sld lib/chibi/regexp/*.scm $(DESTDIR)$(MODDIR)/chibi/regexp/
|
|
||||||
$(INSTALL) -m0644 lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
|
$(INSTALL) -m0644 lib/chibi/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/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) -m0644 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
|
||||||
$(INSTALL_EXE) -m0755 $(CHIBI_CRYPTO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
|
$(INSTALL) -m0644 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
|
||||||
$(INSTALL_EXE) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
|
$(INSTALL) -m0644 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
|
||||||
$(INSTALL_EXE) -m0755 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
|
$(INSTALL) -m0644 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
|
||||||
$(INSTALL_EXE) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
|
$(INSTALL) -m0644 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
|
||||||
$(INSTALL_EXE) -m0755 lib/scheme/bytevector$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
|
$(INSTALL) -m0644 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
|
$(INSTALL) -m0644 lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
|
$(INSTALL) -m0644 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
|
$(INSTALL) -m0644 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
|
$(INSTALL) -m0644 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
|
$(INSTALL) -m0644 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
|
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/144/math$(SO) $(DESTDIR)$(BINMODDIR)/srfi/144
|
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/151/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/151
|
|
||||||
$(INSTALL_EXE) -m0755 lib/srfi/160/uvprims$(SO) $(DESTDIR)$(BINMODDIR)/srfi/160
|
|
||||||
$(MKDIR) $(DESTDIR)$(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) -m0644 libchibi-scheme$(SO).$(SOVERSION) $(DESTDIR)$(SOLIBDIR)/
|
||||||
$(LN) libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
$(LN) -s -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO).$(SOVERSION) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO).$(SOVERSION_MAJOR)
|
||||||
$(LN) libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
|
$(LN) -s -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO).$(SOVERSION) $(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 +349,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).$(SOVERSION)
|
||||||
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
|
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO).$(SOVERSION_MAJOR)
|
||||||
-$(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
|
||||||
|
@ -456,11 +371,9 @@ uninstall:
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(BINMODDIR)/chibi/regexp
|
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/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,92 +381,28 @@ 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-`cat VERSION`.tgz
|
||||||
$(MKDIR) chibi-scheme-$(CHIBI_VERSION)
|
$(MKDIR) chibi-scheme-`cat 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 `hg manifest | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`cat VERSION`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done
|
||||||
$(TAR) cphzvf chibi-scheme-$(CHIBI_VERSION).tgz chibi-scheme-$(CHIBI_VERSION)
|
$(TAR) cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION`
|
||||||
$(RM) -r chibi-scheme-$(CHIBI_VERSION)
|
$(RM) -r chibi-scheme-`cat 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`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz
|
||||||
$(MKDIR) chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`
|
$(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
|
||||||
@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 `hg manifest | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done
|
||||||
$(TAR) cphzvf chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`.tgz chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`
|
$(TAR) cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
|
||||||
$(RM) -r chibi-scheme-`date +%Y%m%d`-`git log HEAD^..HEAD | head -1 | cut -c8-`
|
$(RM) -r chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
|
||||||
|
|
||||||
debian:
|
|
||||||
sudo checkinstall -D --pkgname chibi-scheme --pkgversion $(CHIBI_VERSION) --maintainer "http://groups.google.com/group/chibi-scheme" -y make PREFIX=/usr install
|
|
||||||
|
|
||||||
# Libraries in the standard distribution we want to make available to
|
|
||||||
# other Scheme implementations. Note this is run with my own
|
|
||||||
# ~/.snow/config.scm, which specifies my own settings regarding
|
|
||||||
# author, license, extracting docs from scribble, etc.
|
|
||||||
snowballs:
|
|
||||||
$(SNOW_CHIBI) package --license public-domain lib/chibi/char-set/boundary.sld
|
|
||||||
$(SNOW_CHIBI) package --license public-domain lib/chibi/match.sld
|
|
||||||
$(SNOW_CHIBI) package -r lib/chibi/char-set.sld
|
|
||||||
$(SNOW_CHIBI) package -r lib/chibi/iset.sld lib/chibi/iset/optimize.sld
|
|
||||||
$(SNOW_CHIBI) package --doc https://srfi.schemers.org/srfi-115/srfi-115.html --test-library lib/srfi/115.sld
|
|
||||||
$(SNOW_CHIBI) package -r --doc https://srfi.schemers.org/srfi-166/srfi-166.html --test-library lib/srfi/166/test.sld lib/srfi/166.sld lib/chibi/show/shared.sld
|
|
||||||
$(SNOW_CHIBI) package -r --doc https://srfi.schemers.org/srfi-179/srfi-179.html --test-library lib/srfi/179/test.sld lib/srfi/179.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/app.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/assert.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/base64.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/binary-record.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/bytevector.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/config.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/crypto/md5.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/crypto/rsa.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/crypto/sha2.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/diff.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/edit-distance.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/filesystem.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/math/prime.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/mime.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/monad/environment.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/optional.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/parse.sld lib/chibi/parse/common.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/pathname.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/quoted-printable.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/regexp.sld lib/chibi/regexp/pcre.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/scribble.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/string.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/sxml.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/tar.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/temp-file.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/term/ansi.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/term/edit-line.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/test.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/uri.sld
|
|
||||||
$(SNOW_CHIBI) package lib/chibi/zlib.sld
|
|
||||||
|
|
132
Makefile.detect
132
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,31 +41,19 @@ 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.
|
||||||
|
|
||||||
LIBDL = -ldl
|
LIBDL = -ldl
|
||||||
SO_VERSIONED_SUFFIX = $(SO).$(SOVERSION)
|
|
||||||
SO_MAJOR_VERSIONED_SUFFIX = $(SO).$(SOVERSION_MAJOR)
|
|
||||||
STATIC_LDFLAGS = -lm -ldl -lutil
|
|
||||||
|
|
||||||
ifeq ($(PLATFORM),macosx)
|
ifeq ($(PLATFORM),macosx)
|
||||||
SO = .dylib
|
SO = .dylib
|
||||||
SO_VERSIONED_SUFFIX = .$(SOVERSION)$(SO)
|
|
||||||
SO_MAJOR_VERSIONED_SUFFIX = .$(SOVERSION_MAJOR)$(SO)
|
|
||||||
EXE =
|
EXE =
|
||||||
CLIBFLAGS =
|
CLIBFLAGS =
|
||||||
CLINKFLAGS = -dynamiclib
|
CLINKFLAGS = -dynamiclib
|
||||||
STATICFLAGS = -DSEXP_USE_DL=0 # -static-libgcc
|
STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0
|
||||||
LIBCHIBI_FLAGS = -install_name $(DESTDIR)$(SOLIBDIR)/libchibi-scheme.$(SOVERSION).dylib
|
LIBCHIBI_FLAGS = -install_name $(DESTDIR)$(SOLIBDIR)/libchibi-scheme.dylib.$(SOVERSION)
|
||||||
else
|
else
|
||||||
ifeq ($(PLATFORM),bsd)
|
ifeq ($(PLATFORM),bsd)
|
||||||
SO = .so
|
SO = .so
|
||||||
|
@ -80,37 +61,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 +81,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 +88,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 +98,18 @@ 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
|
endif
|
||||||
|
|
||||||
########################################################################
|
########################################################################
|
||||||
# Library config.
|
# Check for NTP (who needs autoconf?)
|
||||||
#
|
|
||||||
# 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)
|
ifndef $(SEXP_USE_NTP_GETTIME)
|
||||||
GCLDFLAGS := -lgc
|
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)
|
||||||
XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
|
|
||||||
else
|
|
||||||
GCLDFLAGS :=
|
|
||||||
XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
|
|
||||||
endif
|
|
||||||
|
|
||||||
ifeq ($(SEXP_USE_DL),0)
|
|
||||||
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
|
|
||||||
XCFLAGS := -Wall -DSEXP_USE_DL=0 -g -g3 -O3 $(CFLAGS)
|
|
||||||
else
|
|
||||||
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
|
|
||||||
XCFLAGS := -Wall -g -g3 -O3 $(CFLAGS)
|
|
||||||
endif
|
|
||||||
|
|
||||||
ifeq ($(PLATFORM),solaris)
|
|
||||||
XLDFLAGS += -lsocket
|
|
||||||
XCPPFLAGS += -D_POSIX_PTHREAD_SEMANTICS
|
|
||||||
endif
|
|
||||||
|
|
||||||
# Choose compiled library on MSYS
|
|
||||||
ifeq ($(OS), Windows_NT)
|
|
||||||
ifeq ($(PLATFORM),msys)
|
|
||||||
EXCLUDE_WIN32_LIBS=1
|
|
||||||
else
|
|
||||||
ifeq ($(shell uname -o),Cygwin)
|
|
||||||
EXCLUDE_WIN32_LIBS=1
|
|
||||||
else
|
|
||||||
EXCLUDE_POSIX_LIBS=1
|
|
||||||
endif
|
|
||||||
endif
|
|
||||||
endif
|
|
||||||
|
|
||||||
CHIBI_POSIX_COMPILED_LIBS = lib/chibi/process$(SO) lib/chibi/time$(SO) \
|
|
||||||
lib/chibi/system$(SO) lib/chibi/stty$(SO) lib/chibi/pty$(SO) \
|
|
||||||
lib/chibi/net$(SO) lib/srfi/18/threads$(SO)
|
|
||||||
CHIBI_WIN32_COMPILED_LIBS = lib/chibi/win32/process-win32$(SO)
|
|
||||||
|
|
||||||
ifndef EXCLUDE_POSIX_LIBS
|
|
||||||
CHIBI_COMPILED_LIBS += $(CHIBI_POSIX_COMPILED_LIBS)
|
|
||||||
else
|
|
||||||
CHIBI_COMPILED_LIBS += $(CHIBI_WIN32_COMPILED_LIBS)
|
|
||||||
endif
|
|
||||||
|
|
||||||
########################################################################
|
|
||||||
# Check for headers (who needs autoconf?)
|
|
||||||
|
|
||||||
ifndef SEXP_USE_NTP_GETTIME
|
|
||||||
SEXP_USE_NTP_GETTIME := $(shell echo "int main(){struct ntptimeval n; ntp_gettime(&n);}" | $(CC) -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
ifeq ($(SEXP_USE_NTP_GETTIME),1)
|
ifeq ($(SEXP_USE_NTP_GETTIME),1)
|
||||||
XCPPFLAGS += -DSEXP_USE_NTPGETTIME
|
CPPFLAGS += -DSEXP_USE_NTPGETTIME
|
||||||
endif
|
|
||||||
|
|
||||||
ifndef SEXP_USE_INTTYPES
|
|
||||||
SEXP_USE_INTTYPES := $(shell echo "int main(){int_least8_t x;}" | $(CC) -fsyntax-only -include inttypes.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
|
|
||||||
endif
|
|
||||||
|
|
||||||
ifeq ($(SEXP_USE_INTTYPES),1)
|
|
||||||
XCPPFLAGS += -DSEXP_USE_INTTYPES
|
|
||||||
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)
|
||||||
|
|
||||||
|
|
39
README
Normal file
39
README
Normal file
|
@ -0,0 +1,39 @@
|
||||||
|
|
||||||
|
Chibi-Scheme
|
||||||
|
--------------
|
||||||
|
|
||||||
|
Minimal Scheme Implementation for use as an Extension Language
|
||||||
|
|
||||||
|
http://synthcode.com/wiki/chibi-scheme/
|
||||||
|
|
||||||
|
Chibi-Scheme is a very small library intended for use as an extension
|
||||||
|
and scripting language in C programs. In addition to support for
|
||||||
|
lightweight VM-based threads, each VM itself runs in an isolated heap
|
||||||
|
allowing multiple VMs to run simultaneously in different OS threads.
|
||||||
|
|
||||||
|
The default language is the R7RS (scheme base) library.
|
||||||
|
|
||||||
|
Support for additional languages such as JavaScript, Go, Lua and Bash
|
||||||
|
are planned for future releases. Scheme is chosen as a substrate
|
||||||
|
because its first class continuations and guaranteed tail-call
|
||||||
|
optimization makes implementing other languages easy.
|
||||||
|
|
||||||
|
To build on most platforms just run "make && make test". This will
|
||||||
|
provide a shared library "libchibi-scheme", as well as a sample
|
||||||
|
"chibi-scheme" command-line repl. You can then run
|
||||||
|
|
||||||
|
sudo make install
|
||||||
|
|
||||||
|
to install the binaries and libraries. You can optionally specify a
|
||||||
|
PREFIX for the installation directory:
|
||||||
|
|
||||||
|
make PREFIX=/path/to/install/
|
||||||
|
sudo make PREFIX=/path/to/install/ install
|
||||||
|
|
||||||
|
By default files are installed in /usr/local.
|
||||||
|
|
||||||
|
If you want to try out chibi-scheme without installing, be sure to set
|
||||||
|
LD_LIBRARY_PATH so it can find the shared libraries.
|
||||||
|
|
||||||
|
For more detailed documentation, run "make doc" and see the generated
|
||||||
|
"doc/chibi.html".
|
|
@ -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
|
||||||
|
|
32
TODO
32
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]
|
||||||
|
|
||||||
|
@ -158,15 +157,11 @@
|
||||||
- State "DONE" [2009-12-16 Wed 18:58]
|
- State "DONE" [2009-12-16 Wed 18:58]
|
||||||
** DONE uri library
|
** DONE uri library
|
||||||
- State "DONE" [2009-12-16 Wed 18:58]
|
- State "DONE" [2009-12-16 Wed 18:58]
|
||||||
** DONE http library
|
** TODO http library
|
||||||
- State "DONE" from "TODO" [2015-04-09 Thu 01:22]
|
** TODO show (formatting) library
|
||||||
** DONE show (formatting) library
|
|
||||||
- State "DONE" from "TODO" [2015-04-09 Thu 01:22]
|
|
||||||
** TODO zip library
|
** TODO zip library
|
||||||
** DONE tar library
|
** TODO tar library
|
||||||
- State "DONE" from "TODO" [2015-04-09 Thu 01:22]
|
** TODO md5sum library
|
||||||
** DONE md5sum library
|
|
||||||
- State "DONE" from "TODO" [2015-04-09 Thu 01:22]
|
|
||||||
|
|
||||||
* ports
|
* ports
|
||||||
** DONE basic mingw support
|
** DONE basic mingw support
|
||||||
|
@ -182,14 +177,11 @@
|
||||||
* 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
|
||||||
** DONE packaging format (Snow2)
|
** TODO packaging format (Snow2)
|
||||||
- State "DONE" from "TODO" [2015-04-09 Thu 01:22]
|
** TODO code repository with fetch+install tool
|
||||||
** DONE code repository with fetch+install tool
|
|
||||||
- State "DONE" from "TODO" [2015-04-09 Thu 01:22]
|
|
||||||
** TODO translator to/from other implementations
|
** TODO translator to/from other implementations
|
||||||
|
|
||||||
|
|
2
VERSION
2
VERSION
|
@ -1 +1 @@
|
||||||
0.11.0
|
0.7
|
||||||
|
|
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 +0,0 @@
|
||||||
1
|
|
|
@ -1,201 +0,0 @@
|
||||||
;;; RAY -- Ray-trace a simple scene with spheres, generating a ".pgm" file.
|
|
||||||
;;; Translated to Scheme from Paul Graham's book ANSI Common Lisp, Example 9.8
|
|
||||||
|
|
||||||
(import (scheme base)
|
|
||||||
(scheme inexact)
|
|
||||||
(scheme file)
|
|
||||||
(scheme read)
|
|
||||||
(scheme write)
|
|
||||||
(scheme time))
|
|
||||||
|
|
||||||
(define (make-point x y z)
|
|
||||||
(vector x y z))
|
|
||||||
|
|
||||||
(define (point-x p) (vector-ref p 0))
|
|
||||||
(define (point-y p) (vector-ref p 1))
|
|
||||||
(define (point-z p) (vector-ref p 2))
|
|
||||||
|
|
||||||
(define (sq x) (* x x))
|
|
||||||
|
|
||||||
(define (mag x y z)
|
|
||||||
(sqrt (+ (sq x) (sq y) (sq z))))
|
|
||||||
|
|
||||||
(define (unit-vector x y z)
|
|
||||||
(let ((d (mag x y z)))
|
|
||||||
(make-point (/ x d) (/ y d) (/ z d))))
|
|
||||||
|
|
||||||
(define (distance p1 p2)
|
|
||||||
(mag (- (point-x p1) (point-x p2))
|
|
||||||
(- (point-y p1) (point-y p2))
|
|
||||||
(- (point-z p1) (point-z p2))))
|
|
||||||
|
|
||||||
(define (minroot a b c)
|
|
||||||
(if (zero? a)
|
|
||||||
(/ (- c) b)
|
|
||||||
(let ((disc (- (sq b) (* 4.0 a c))))
|
|
||||||
(if (negative? disc)
|
|
||||||
#f
|
|
||||||
(let ((discrt (sqrt disc))
|
|
||||||
(minus-b (- b))
|
|
||||||
(two-a (* 2.0 a)))
|
|
||||||
(min (/ (+ minus-b discrt) two-a)
|
|
||||||
(/ (- minus-b discrt) two-a)))))))
|
|
||||||
|
|
||||||
(define *world* '())
|
|
||||||
|
|
||||||
(define eye (make-point 0.0 0.0 200.0))
|
|
||||||
|
|
||||||
(define (tracer pathname res)
|
|
||||||
(if (file-exists? pathname)
|
|
||||||
(delete-file pathname))
|
|
||||||
(call-with-output-file
|
|
||||||
pathname
|
|
||||||
(lambda (p)
|
|
||||||
(let ((extent (* res 100)))
|
|
||||||
(display "P2 " p)
|
|
||||||
(write extent p)
|
|
||||||
(display " " p)
|
|
||||||
(write extent p)
|
|
||||||
(display " 255" p)
|
|
||||||
(newline p)
|
|
||||||
(do ((y 0 (+ y 1)))
|
|
||||||
((= y extent))
|
|
||||||
(do ((x 0 (+ x 1)))
|
|
||||||
((= x extent))
|
|
||||||
(write (color-at
|
|
||||||
(+ -50.0
|
|
||||||
(/ (inexact x) (inexact res)))
|
|
||||||
(+ -50.0
|
|
||||||
(/ (inexact y) (inexact res))))
|
|
||||||
p)
|
|
||||||
(newline p)))))))
|
|
||||||
|
|
||||||
(define (color-at x y)
|
|
||||||
(let ((ray (unit-vector (- x (point-x eye))
|
|
||||||
(- y (point-y eye))
|
|
||||||
(- (point-z eye)))))
|
|
||||||
(exact (round (* (sendray eye ray) 255.0)))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define (sendray pt ray)
|
|
||||||
(let* ((x (first-hit pt ray))
|
|
||||||
(s (vector-ref x 0))
|
|
||||||
(int (vector-ref x 1)))
|
|
||||||
(if s
|
|
||||||
(* (lambert s int ray)
|
|
||||||
(surface-color s))
|
|
||||||
0.0)))
|
|
||||||
|
|
||||||
(define (first-hit pt ray)
|
|
||||||
(let loop ((lst *world*) (surface #f) (hit #f) (dist 1e308))
|
|
||||||
(if (null? lst)
|
|
||||||
(vector surface hit)
|
|
||||||
(let ((s (car lst)))
|
|
||||||
(let ((h (intersect s pt ray)))
|
|
||||||
(if h
|
|
||||||
(let ((d (distance h pt)))
|
|
||||||
(if (< d dist)
|
|
||||||
(loop (cdr lst) s h d)
|
|
||||||
(loop (cdr lst) surface hit dist)))
|
|
||||||
(loop (cdr lst) surface hit dist)))))))
|
|
||||||
|
|
||||||
(define (lambert s int ray)
|
|
||||||
(let ((n (normal s int)))
|
|
||||||
(max 0.0
|
|
||||||
(+ (* (point-x ray) (point-x n))
|
|
||||||
(* (point-y ray) (point-y n))
|
|
||||||
(* (point-z ray) (point-z n))))))
|
|
||||||
|
|
||||||
(define (make-sphere color radius center)
|
|
||||||
(vector color radius center))
|
|
||||||
|
|
||||||
(define (sphere-color s) (vector-ref s 0))
|
|
||||||
(define (sphere-radius s) (vector-ref s 1))
|
|
||||||
(define (sphere-center s) (vector-ref s 2))
|
|
||||||
|
|
||||||
(define (defsphere x y z r c)
|
|
||||||
(let ((s (make-sphere c r (make-point x y z))))
|
|
||||||
(set! *world* (cons s *world*))
|
|
||||||
s))
|
|
||||||
|
|
||||||
(define (surface-color s)
|
|
||||||
(sphere-color s))
|
|
||||||
|
|
||||||
(define (intersect s pt ray)
|
|
||||||
(sphere-intersect s pt ray))
|
|
||||||
|
|
||||||
(define (sphere-intersect s pt ray)
|
|
||||||
(let* ((xr (point-x ray))
|
|
||||||
(yr (point-y ray))
|
|
||||||
(zr (point-z ray))
|
|
||||||
(c (sphere-center s))
|
|
||||||
(n (minroot
|
|
||||||
(+ (sq xr) (sq yr) (sq zr))
|
|
||||||
(* 2.0
|
|
||||||
(+ (* (- (point-x pt) (point-x c)) xr)
|
|
||||||
(* (- (point-y pt) (point-y c)) yr)
|
|
||||||
(* (- (point-z pt) (point-z c)) zr)))
|
|
||||||
(+ (sq (- (point-x pt) (point-x c)))
|
|
||||||
(sq (- (point-y pt) (point-y c)))
|
|
||||||
(sq (- (point-z pt) (point-z c)))
|
|
||||||
(- (sq (sphere-radius s)))))))
|
|
||||||
(if n
|
|
||||||
(make-point (+ (point-x pt) (* n xr))
|
|
||||||
(+ (point-y pt) (* n yr))
|
|
||||||
(+ (point-z pt) (* n zr)))
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (normal s pt)
|
|
||||||
(sphere-normal s pt))
|
|
||||||
|
|
||||||
(define (sphere-normal s pt)
|
|
||||||
(let ((c (sphere-center s)))
|
|
||||||
(unit-vector (- (point-x c) (point-x pt))
|
|
||||||
(- (point-y c) (point-y pt))
|
|
||||||
(- (point-z c) (point-z pt)))))
|
|
||||||
|
|
||||||
(define (ray-test res output-file)
|
|
||||||
(set! *world* '())
|
|
||||||
(defsphere 0.0 -300.0 -1200.0 200.0 0.8)
|
|
||||||
(defsphere -80.0 -150.0 -1200.0 200.0 0.7)
|
|
||||||
(defsphere 70.0 -100.0 -1200.0 200.0 0.9)
|
|
||||||
(do ((x -2 (+ x 1)))
|
|
||||||
((> x 2))
|
|
||||||
(do ((z 2 (+ z 1)))
|
|
||||||
((> z 7))
|
|
||||||
(defsphere
|
|
||||||
(* (inexact x) 200.0)
|
|
||||||
300.0
|
|
||||||
(* (inexact z) -400.0)
|
|
||||||
40.0
|
|
||||||
0.75)))
|
|
||||||
(tracer output-file res))
|
|
||||||
|
|
||||||
(define (run input output)
|
|
||||||
(ray-test input output)
|
|
||||||
'ok)
|
|
||||||
|
|
||||||
(define (hide count input)
|
|
||||||
input)
|
|
||||||
|
|
||||||
(define (run-r7rs-benchmark name count thunk verify?)
|
|
||||||
(do ((i 0 (+ i 1))
|
|
||||||
(res #f (thunk)))
|
|
||||||
((= i count)
|
|
||||||
(if (not (verify? res))
|
|
||||||
(error "bad output" res)))))
|
|
||||||
|
|
||||||
(define (main)
|
|
||||||
(let* ((count (read))
|
|
||||||
(input1 (read))
|
|
||||||
(input2 (read))
|
|
||||||
(output (read))
|
|
||||||
(s2 (number->string count))
|
|
||||||
(s1 (number->string input1))
|
|
||||||
(name "ray"))
|
|
||||||
(run-r7rs-benchmark
|
|
||||||
(string-append name ":" s2)
|
|
||||||
count
|
|
||||||
(lambda () (run (hide count input1) (hide count input2)))
|
|
||||||
(lambda (result) (equal? result output)))))
|
|
|
@ -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" -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"
|
|
||||||
|
|
506
bignum.c
506
bignum.c
|
@ -1,5 +1,5 @@
|
||||||
/* bignum.c -- bignum support */
|
/* bignum.c -- bignum support */
|
||||||
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
/* Copyright (c) 2009-2013 Alex Shinn. All rights reserved. */
|
||||||
/* BSD-style license: http://synthcode.com/license.txt */
|
/* BSD-style license: http://synthcode.com/license.txt */
|
||||||
|
|
||||||
#include "chibi/sexp.h"
|
#include "chibi/sexp.h"
|
||||||
|
@ -19,107 +19,50 @@ static int hex_digit (int n) {
|
||||||
sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) {
|
sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) {
|
||||||
sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t);
|
sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t);
|
||||||
sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM);
|
sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM);
|
||||||
if (!sexp_exceptionp(res)) {
|
|
||||||
sexp_bignum_length(res) = len;
|
sexp_bignum_length(res) = len;
|
||||||
sexp_bignum_sign(res) = 1;
|
sexp_bignum_sign(res) = 1;
|
||||||
}
|
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) {
|
sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) {
|
||||||
sexp res = sexp_make_bignum(ctx, 1);
|
sexp res = sexp_make_bignum(ctx, 1);
|
||||||
if (!sexp_exceptionp(res)) {
|
sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a));
|
||||||
sexp_bignum_data(res)[0] = sexp_unbox_fx_abs(a);
|
|
||||||
sexp_bignum_sign(res) = sexp_fx_sign(a);
|
sexp_bignum_sign(res) = sexp_fx_sign(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 +70,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 +131,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 +194,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 +210,13 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
|
||||||
sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
|
sexp_uint_t 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 +224,32 @@ sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
|
||||||
sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) {
|
sexp 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,38 +257,15 @@ 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=='/') {
|
||||||
res = sexp_bignum_normalize(res);
|
res = sexp_bignum_normalize(res);
|
||||||
res = sexp_make_ratio(ctx, res, SEXP_ONE);
|
res = sexp_make_ratio(ctx, res, SEXP_ONE);
|
||||||
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10, 0);
|
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10);
|
||||||
res = sexp_ratio_normalize(ctx, res, in);
|
res = sexp_ratio_normalize(ctx, res, in);
|
||||||
#endif
|
#endif
|
||||||
#if SEXP_USE_COMPLEX
|
#if SEXP_USE_COMPLEX
|
||||||
|
@ -364,7 +280,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 +299,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),
|
||||||
|
@ -409,9 +322,9 @@ sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) {
|
||||||
sexp_gc_preserve1(ctx, c);
|
sexp_gc_preserve1(ctx, c);
|
||||||
c = sexp_copy_bignum(ctx, NULL, a, 0);
|
c = sexp_copy_bignum(ctx, NULL, a, 0);
|
||||||
if (sexp_bignum_sign(c) == sexp_fx_sign(b))
|
if (sexp_bignum_sign(c) == sexp_fx_sign(b))
|
||||||
c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fx_abs(b));
|
c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
|
||||||
else
|
else
|
||||||
c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fx_abs(b));
|
c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release1(ctx);
|
||||||
return c;
|
return c;
|
||||||
}
|
}
|
||||||
|
@ -450,7 +363,7 @@ sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) {
|
||||||
|
|
||||||
sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
|
sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
|
||||||
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
|
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
|
||||||
carry=0, i, old_a, p_sum, *adata, *bdata, *cdata;
|
carry=0, i, n, *adata, *bdata, *cdata;
|
||||||
sexp_gc_var1(c);
|
sexp_gc_var1(c);
|
||||||
if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a);
|
if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a);
|
||||||
sexp_gc_preserve1(ctx, c);
|
sexp_gc_preserve1(ctx, c);
|
||||||
|
@ -460,11 +373,9 @@ sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
|
||||||
bdata = sexp_bignum_data(b);
|
bdata = sexp_bignum_data(b);
|
||||||
cdata = sexp_bignum_data(c);
|
cdata = sexp_bignum_data(c);
|
||||||
for (i=0; i<blen; i++) {
|
for (i=0; i<blen; i++) {
|
||||||
old_a = adata[i]; /* adata may alias cdata */
|
n = adata[i];
|
||||||
p_sum = adata[i] + bdata[i];
|
cdata[i] = n + bdata[i] + carry;
|
||||||
cdata[i] = p_sum + carry;
|
carry = (n > (SEXP_UINT_T_MAX - bdata[i] - carry) ? 1 : 0);
|
||||||
carry = (old_a > (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0)
|
|
||||||
+ (p_sum > (SEXP_UINT_T_MAX - carry) ? 1 : 0);
|
|
||||||
}
|
}
|
||||||
for ( ; carry && (i<alen); i++) {
|
for ( ; carry && (i<alen); i++) {
|
||||||
carry = (cdata[i] == SEXP_UINT_T_MAX ? 1 : 0);
|
carry = (cdata[i] == SEXP_UINT_T_MAX ? 1 : 0);
|
||||||
|
@ -595,44 +506,44 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
|
||||||
sexp_bignum_sign(b1) = 1;
|
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 +557,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 +595,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_fixnum(sexp_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 +638,7 @@ sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) {
|
||||||
if (! sexp_bignump(a)) return sexp_type_exception(ctx, NULL, SEXP_BIGNUM, a);
|
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 +682,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 +703,7 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
|
||||||
for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) {
|
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 +717,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 +767,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 +787,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 +797,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 +805,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 +839,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 +886,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 +911,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 +921,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 +933,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 +958,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 +983,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 +1006,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 +1185,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 +1201,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 +1261,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 +1290,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 +1311,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 +1347,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,17 +1376,17 @@ 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)));
|
||||||
break;
|
break;
|
||||||
case SEXP_NUM_FIX_BIG:
|
case SEXP_NUM_FIX_BIG:
|
||||||
r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fx_abs(a), 0);
|
r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0);
|
||||||
sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b);
|
sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b);
|
||||||
r = sexp_bignum_normalize(r);
|
r = sexp_bignum_normalize(r);
|
||||||
break;
|
break;
|
||||||
|
@ -1539,7 +1401,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 +1508,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 +1529,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 +1540,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 +1624,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 +1657,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 +1681,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 +1722,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 +1740,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 +1754,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 +1779,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 +1791,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,5 +1,3 @@
|
||||||
;; This code is written by Alex Shinn and placed in the
|
|
||||||
;; Public Domain. All warranties are disclaimed.
|
|
||||||
|
|
||||||
(define char-set:letter+digit
|
(define char-set:letter+digit
|
||||||
(immutable-char-set (char-set-union char-set:letter char-set:digit)))
|
(immutable-char-set (char-set-union char-set:letter char-set:digit)))
|
||||||
|
|
|
@ -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'."
|
|
|
@ -26,9 +26,6 @@ _chibi-scheme() {
|
||||||
-x*)
|
-x*)
|
||||||
COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-x!')" -- "$cur") )
|
COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-x!')" -- "$cur") )
|
||||||
return 0;;
|
return 0;;
|
||||||
-R*)
|
|
||||||
COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-R!')" -- "$cur") )
|
|
||||||
return 0;;
|
|
||||||
-l*)
|
-l*)
|
||||||
compopt -o nospace
|
compopt -o nospace
|
||||||
_filedir
|
_filedir
|
||||||
|
@ -45,7 +42,7 @@ _chibi-scheme() {
|
||||||
COMPREPLY=( $( compgen -W "$(echo $sizes | tr ' ' '\n' | sed 's!^!-h!')" -- "${cur}" ) )
|
COMPREPLY=( $( compgen -W "$(echo $sizes | tr ' ' '\n' | sed 's!^!-h!')" -- "${cur}" ) )
|
||||||
return 0;;
|
return 0;;
|
||||||
-)
|
-)
|
||||||
COMPREPLY=( $( compgen -W '-d -e -f -h -i -l -m -p -q -x -A -I -R -V' \
|
COMPREPLY=( $( compgen -W '-d -e -f -h -i -l -m -p -q -x -A -I -V' \
|
||||||
-- "$cur") )
|
-- "$cur") )
|
||||||
return 0;;
|
return 0;;
|
||||||
-*)
|
-*)
|
||||||
|
|
|
@ -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)
|
|
2
data/.gitignore
vendored
2
data/.gitignore
vendored
|
@ -1,2 +0,0 @@
|
||||||
# downloaded unicode standard files
|
|
||||||
*.txt
|
|
|
@ -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
|
||||||
]
|
]
|
||||||
|
@ -75,42 +72,21 @@ program. Signals aren't caught either - to enable handling keyboard
|
||||||
interrupts you can use the (chibi process) module. For a more
|
interrupts you can use the (chibi process) module. For a more
|
||||||
sophisticated REPL with readline support, signal handling, module
|
sophisticated REPL with readline support, signal handling, module
|
||||||
management and smarter read/write you may want to use the (chibi repl)
|
management and smarter read/write you may want to use the (chibi repl)
|
||||||
module. This can be launched automatically with:
|
module. For example,
|
||||||
.I chibi-scheme -R
|
.I chibi-scheme -mchibi.repl -e'(repl)'
|
||||||
\[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
|
||||||
or its shortcut
|
or its shortcut
|
||||||
.I chibi-scheme -q
|
.I chibi-scheme -q
|
||||||
\[char46]
|
|
||||||
|
|
||||||
.SH OPTIONS
|
.SH OPTIONS
|
||||||
|
|
||||||
Space is optional between options and their arguments. Options
|
Space is optional between options and their arguments.
|
||||||
without arguments may not be chained together.
|
Options without arguments may not be chained together.
|
||||||
|
|
||||||
To reduce the need for shell escapes, options with module arguments
|
|
||||||
(
|
|
||||||
.I -m
|
|
||||||
,
|
|
||||||
.I -x
|
|
||||||
and
|
|
||||||
.I -R
|
|
||||||
) are written in a dot notation, so that the module
|
|
||||||
.I (foo bar)
|
|
||||||
is written as
|
|
||||||
.I foo.bar
|
|
||||||
\[char46]
|
|
||||||
|
|
||||||
.TP 5
|
.TP 5
|
||||||
.BI -V
|
.BI -V
|
||||||
|
@ -138,10 +114,6 @@ Loads the given module and runs the "main" procedure it defines (which
|
||||||
need not be exported) with a single argument of the list of command-line
|
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]
|
|
||||||
may be omitted, in which case it defaults to chibi.repl. Thus
|
|
||||||
.I chibi-scheme -R
|
|
||||||
is the recommended means to obtain the advanced REPL.
|
|
||||||
.TP
|
.TP
|
||||||
.BI -s
|
.BI -s
|
||||||
Strict mode, escalating warnings to fatal errors.
|
Strict mode, escalating warnings to fatal errors.
|
||||||
|
@ -149,11 +121,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 +142,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
|
||||||
|
@ -188,7 +149,11 @@ Imports
|
||||||
.I module
|
.I module
|
||||||
as though "(import
|
as though "(import
|
||||||
.I module
|
.I module
|
||||||
)" were evaluated.
|
)" were evaluated. However, to reduce the need for shell
|
||||||
|
escapes, modules are written in a dot notation, so that the module
|
||||||
|
.I (foo bar)
|
||||||
|
is written as
|
||||||
|
.I foo.bar
|
||||||
If the
|
If the
|
||||||
.BI -x
|
.BI -x
|
||||||
version is used, then
|
version is used, then
|
||||||
|
@ -225,17 +190,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 +207,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 +216,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/
|
||||||
|
|
467
doc/chibi.scrbl
467
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,16 +79,7 @@ or edited manually. Be sure to run this with a non-static
|
||||||
chibi-scheme. Then you can make the static executable with:
|
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
|
|
||||||
specify a PREFIX for the installation directory:
|
|
||||||
|
|
||||||
\command{
|
|
||||||
make PREFIX=/path/to/install/
|
|
||||||
sudo make PREFIX=/path/to/install/ install
|
|
||||||
}
|
}
|
||||||
|
|
||||||
\subsection{Compile-Time Options}
|
\subsection{Compile-Time Options}
|
||||||
|
@ -120,7 +104,6 @@ are listed below.
|
||||||
\item{\ccode{SEXP_USE_RATIOS} - use exact ratios (enabled by default)}
|
\item{\ccode{SEXP_USE_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 +119,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 +129,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 +145,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 +171,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 +193,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 +202,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 +217,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 +256,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 +270,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 +326,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 +362,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 +389,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 +430,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 +461,7 @@ the default context environment is used. Any of the \ctype{FILE*} may
|
||||||
be \cvar{NULL}, in which case the corresponding port is not set. If
|
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 +505,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 +609,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 +643,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 +704,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 +722,7 @@ compiled with:
|
||||||
\item{\ccode{sexp sexp_substring_cursor(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between raw offsets \var{i} and \var{j}}
|
\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 +738,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 +768,6 @@ Any of these may fail and return the OOM exception object.
|
||||||
\item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}}
|
\item{\ccode{sexp_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 +783,7 @@ Any of these may fail and return the OOM exception object.
|
||||||
\item{\ccode{sexp_read(sexp ctx, sexp in)} - read a single datum from port \var{in}}
|
\item{\ccode{sexp_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 +794,7 @@ Any of these may fail and return the OOM exception object.
|
||||||
\item{\ccode{sexp_write_to_string(sexp ctx, sexp obj)} - return a Scheme string representation of \var{obj}}
|
\item{\ccode{sexp_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 +807,7 @@ Any of these may fail and return the OOM exception object.
|
||||||
\item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}}
|
\item{\ccode{sexp_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 +887,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 +1149,7 @@ A number of SRFIs are provided in the default installation. Note that
|
||||||
SRFIs 0, 6, 23, 46 and 62 are built into the default environment so
|
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 +1160,6 @@ snow-fort):
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-8/srfi-8.html"]{(srfi 8) - receive}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-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 +1169,13 @@ snow-fort):
|
||||||
\item{\hyperlink["http://srfi.schemers.org/srfi-33/srfi-33.html"]{(srfi 33) - bitwise operators}}
|
\item{\hyperlink["http://srfi.schemers.org/srfi-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}}
|
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -1325,34 +1184,12 @@ namespace.
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/app.html"]{(chibi app) - Unified option parsing and config}}
|
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}}
|
\item{\hyperlink["lib/chibi/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,60 +1200,32 @@ 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/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}}
|
\item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/process.html"]{(chibi process) - Interface to spawn processes and handle signals}}
|
\item{\hyperlink["lib/chibi/process.html"]{(chibi process) - Interface to spawn processes and handle signals}}
|
||||||
|
|
||||||
\item{\hyperlink["lib/chibi/repl.html"]{(chibi repl) - A full-featured Read/Eval/Print Loop}}
|
\item{\hyperlink["lib/chibi/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,199 +1243,67 @@ 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}
|
||||||
|
|
||||||
By default \scheme{snow-chibi} looks for packages in the public
|
|
||||||
repository \hyperlink["http://snow-fort.org/"]{http://snow-fort.org/},
|
|
||||||
though you can customize this with the \scheme{--repository-uri} or
|
|
||||||
\scheme{--repo} option (e.g. "http://snow-fort.org/s/repo.scm").
|
|
||||||
|
|
||||||
Packages can be browsed on the site, but you can also search and query
|
|
||||||
from the command-line tool.
|
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
|
|
||||||
\item{search terms ... - search for packages
|
\item{search terms ... - search for packages
|
||||||
\p{Print a list of available packages matching the given keywords.}}
|
\p{Prints a list of available packages matching the given keywords.}}
|
||||||
|
|
||||||
\item{show names ... - show package descriptions
|
\item{show names ... - show package descriptions
|
||||||
\p{Show detailed information for the listed packages, which can
|
\p{Show detailed information for the listed packages, which can
|
||||||
be sexp library names or the dotted shorthand used by chibi. For example,
|
be sexp library names or the dotted shorthand used by chibi.}}
|
||||||
\scheme{snow-chibi show "(chibi match)"} can be shortened as
|
|
||||||
\scheme{snow-chibi show chibi.match}.}}
|
|
||||||
|
|
||||||
\item{status names ... - print package status
|
\item{status names ... - print package status
|
||||||
\p{Print the installed version of the given packages. Uninstalled
|
\p{Print the installed version of the given packages.}}
|
||||||
packages will not be shown. If no names are given, prints all
|
|
||||||
currently installed packages.}}
|
|
||||||
|
|
||||||
\item{implementations - print list of available implementations
|
|
||||||
\p{Print the currently installed Scheme implementations supported
|
|
||||||
by \scheme{snow-chibi}. If an implementation is found but has an
|
|
||||||
older version, a warning is printed.}}
|
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
\subsubsection{Managing Packages}
|
\subsubsection{Managing Packages}
|
||||||
|
|
||||||
The basic package management functionality, installing upgrading and
|
|
||||||
removing packages.
|
|
||||||
|
|
||||||
By default the packages will be managed for Chibi. You can specify
|
|
||||||
what Scheme implementation to install, upgrade... with
|
|
||||||
\scheme{--implementations} or \scheme{--impls} option. Specify "all"
|
|
||||||
to manage all supported implementations.
|
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
|
|
||||||
\item{install names ... - install packages
|
\item{install names ... - install packages
|
||||||
\p{Install the given packages. Package names can be sexp lists or
|
\p{Install the given packages.}}
|
||||||
use the dotted shorthand. Explicit names for packages are optional,
|
|
||||||
as a package can always be referred to by the name of any library it
|
|
||||||
contains. If multiple packages provide libraries with the same name,
|
|
||||||
you will be asked to confirm which implementation to install.}
|
|
||||||
|
|
||||||
\p{You can also bypass the repository and install a manually downloaded
|
|
||||||
snowball by giving a path to that file instead of a name. No package
|
|
||||||
dependencies will be checked for install in this case}}
|
|
||||||
|
|
||||||
\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.
|
||||||
If no names are given, upgrades all eligible packages.}}
|
If no names are given, upgrades all eligible packages.}}
|
||||||
|
|
||||||
\item{remove names ... - remove packages
|
\item{remove names ... - remove packages
|
||||||
\p{Uninstalls the given packages. If the packages were not installed
|
\p{Uninstalls the given packages.}}
|
||||||
with \scheme{snow-chibi} they cannot be removed.}}
|
|
||||||
|
|
||||||
\item{update - update local cache of remote repository
|
|
||||||
\p{\scheme{snow-chibi} keeps a local cache of the remote repository
|
|
||||||
and updates only periodically for performance, but you can force an
|
|
||||||
update with this command.}}
|
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
\subsubsection{Authoring Packages}
|
\subsubsection{Creating Packages}
|
||||||
|
|
||||||
Creating packages can be done with the \scheme{package} command,
|
|
||||||
though other commands allow for uploading to public repositories.
|
|
||||||
|
|
||||||
By default the public repository is
|
|
||||||
\hyperlink["http://snow-fort.org/"]{http://snow-fort.org/} but you can
|
|
||||||
customize this with the \scheme{--host} option.
|
|
||||||
|
|
||||||
\itemlist[
|
\itemlist[
|
||||||
|
|
||||||
\item{package files ... - create a package
|
\item{package files ... - create a package
|
||||||
\p{Create a package snowball from the given files, which should
|
\p{Create a package snowball from the given files, which should
|
||||||
be R7RS library files containing \scheme{define-library} forms.
|
be R7RS library files containing \scheme{define-library} forms.
|
||||||
Include files are inferred and packaged automatically. You can
|
Include files are inferred and packaged automatically.}}
|
||||||
share packages directly, or upload them to a snow repository for
|
|
||||||
easy automated install.}}
|
|
||||||
|
|
||||||
\item{upload files ... - upload packages
|
\item{gen-key - create an RSA key pair
|
||||||
\p{Sign and upload to the default snow host. The files may either
|
\p{Create a new private key pair.}}
|
||||||
be .tgz package files, or files containing define-library forms as
|
|
||||||
in the \scheme{package} command, from which packages are generated
|
|
||||||
automatically. Before you can upload to the default host a key
|
|
||||||
must be generated and registered first with the \scheme{gen-key}
|
|
||||||
and \scheme{reg-key} commands.}}
|
|
||||||
|
|
||||||
\item{gen-key - create a new key
|
|
||||||
\p{Create a new key, with your name, email address, and optionally
|
|
||||||
an RSA public key pair (disabled by default in the current implementation).
|
|
||||||
This is saved locally to ~/.snow/priv-key.scm - you need to register it
|
|
||||||
with reg-key before it can be used for uploads.}}
|
|
||||||
|
|
||||||
\item{reg-key - register a key
|
|
||||||
\p{Register your key on the default snow host.}}
|
|
||||||
|
|
||||||
\item{sign file - sign a package
|
\item{sign file - sign a package
|
||||||
\p{Sign a file with your key and write it to the .sig file.
|
\p{Sign a file with your private key and write it to the .sig file.}}
|
||||||
This can be used with the verify command for testing, but otherwise
|
|
||||||
is not needed as the upload command generates the signature automatically.}}
|
|
||||||
|
|
||||||
\item{verify sig-file - verify a signature
|
\item{verify file - verify a signature
|
||||||
\p{Print a message verifying if a signature is valid.}}
|
\p{Print a message verifying if a signature is valid.}}
|
||||||
|
|
||||||
]
|
\item{reg-key - register an RSA key pair
|
||||||
|
\p{Register your key on the default snow host.}}
|
||||||
\subsubsection{Easy Packaging}
|
|
||||||
|
\item{upload files ... - upload a package
|
||||||
To encourage sharing code it's important to make it as easy as
|
\p{Sign and upload to the default snow host.
|
||||||
possible to create packages, while encouraging documentation and
|
A private key must be generated first.}}
|
||||||
tests. In particular, you should never need to duplicate information
|
|
||||||
anywhere. Thus the \scheme{package} command automatically locates
|
|
||||||
and packages include files (and data and ffi files) and determines
|
|
||||||
dependencies for you. In addition, it can automatically handle
|
|
||||||
versions, docs and tests:
|
|
||||||
|
|
||||||
\itemlist[
|
|
||||||
\item{version - can come explicitly from the \scheme{--version} option, or the \scheme{--version-file=<file>} option}
|
|
||||||
\item{docs - can come explicitly from the \scheme{--doc=<file>} option, or be extracted automatically from literate documentation with \scheme{doc-for-scribble}}
|
|
||||||
\item{tests - can come explicitly from the \scheme{--test=<prog-file>} option, or the \scheme{--test-library=<lib-name>} which will generate a program to run just the \scheme{run-tests} thunk in that library}
|
|
||||||
]
|
|
||||||
|
|
||||||
Other useful meta-info options include:
|
|
||||||
|
|
||||||
\itemlist[
|
|
||||||
\item{\scheme{--authors} - specify the package authors (comma-delimited)}
|
|
||||||
\item{\scheme{--maintainers} - specify the package maintainers (comma-delimited)}
|
|
||||||
\item{\scheme{--license} - specify the package licence}
|
|
||||||
]
|
|
||||||
|
|
||||||
These three are typically always the same, so it's useful to save them
|
|
||||||
in your ~/.snow/config.scm file. This file contains a single sexp and
|
|
||||||
can specify any option, for example:
|
|
||||||
|
|
||||||
\schemeblock{
|
|
||||||
((repository-uri "http://alopeke.gr/repo.scm")
|
|
||||||
(command
|
|
||||||
(package
|
|
||||||
(authors "Socrates <hemlock@aol.com>")
|
|
||||||
(doc-from-scribble #t)
|
|
||||||
(version-file "VERSION")
|
|
||||||
(test-library (append-to-last -test))
|
|
||||||
(license gpl))))
|
|
||||||
}
|
|
||||||
|
|
||||||
Top-level snow options are represented as a flat alist. Options
|
|
||||||
specific to a command are nested under \scheme{(command (name ...))},
|
|
||||||
with most options here being for \scheme{package}. Here unless
|
|
||||||
overridden on the command-line, all packages will use the given author
|
|
||||||
and license, try to extract literate docs from the code, look for a
|
|
||||||
version in the file "VERSION", and try to find a test with the same
|
|
||||||
library name appended with \scheme{-test}, e.g. for the library
|
|
||||||
\scheme{(socratic method)}, the test library would be
|
|
||||||
\scheme{(socratic method-test)}. This form is an alternate to using
|
|
||||||
an explicit test-library name, and encourages you to keep your tests
|
|
||||||
close to the code they test. In the typical case, if using these
|
|
||||||
conventions, you can thus simply run \scheme{snow-chibi package
|
|
||||||
<lib-file>} without any other options.
|
|
||||||
|
|
||||||
\subsubsection{Other Implementations}
|
|
||||||
|
|
||||||
Although the command is called \scheme{snow-chibi}, it supports
|
|
||||||
several other R7RS implementations. The \scheme{implementations}
|
|
||||||
command tells you which you currently have installed. The following
|
|
||||||
are currently supported:
|
|
||||||
|
|
||||||
\itemlist[
|
|
||||||
\item{chibi - version >= 0.7.3}
|
|
||||||
\item{chicken - version >= 4.9.0 with the \scheme{r7rs} egg}
|
|
||||||
\item{cyclone - version >= 0.5.3}
|
|
||||||
\item{foment - version >= 0.4}
|
|
||||||
\item{gauche - version >= 0.9.4}
|
|
||||||
\item{kawa - version >= 2.0; you need to add the install dir to the search path, e.g. \scheme{-Dkawa.import.path=/usr/local/share/kawa}}
|
|
||||||
\item{larceny - version 0.98; you need to add "lib/Snow" to the paths in startup.sch}
|
|
||||||
\item{sagittarius - version >= 0.98}
|
|
||||||
]
|
]
|
||||||
|
|
|
@ -1,29 +0,0 @@
|
||||||
#!/usr/bin/env chibi-scheme
|
|
||||||
|
|
||||||
(import (scheme base) (scheme write) (chibi net) (chibi net server))
|
|
||||||
|
|
||||||
;; Copy each input line to output.
|
|
||||||
(define (echo-handler in out sock addr)
|
|
||||||
(let ((line (read-line in)))
|
|
||||||
(cond
|
|
||||||
((not (or (eof-object? line) (equal? line "")))
|
|
||||||
;; log the request to stdout
|
|
||||||
(display "read: ") (write line)
|
|
||||||
(display " from ")
|
|
||||||
(display (sockaddr-name (address-info-address addr)))
|
|
||||||
(display " port ") (write (sockaddr-port (address-info-address addr)))
|
|
||||||
(newline)
|
|
||||||
;; write and flush the response
|
|
||||||
(display line out)
|
|
||||||
(newline out)
|
|
||||||
(flush-output-port out)
|
|
||||||
(echo-handler in out sock addr)))))
|
|
||||||
|
|
||||||
(define (get-inet6-address-info host service)
|
|
||||||
(let ((hints (make-address-info address-family/inet6
|
|
||||||
socket-type/stream
|
|
||||||
ip-proto/tcp)))
|
|
||||||
(get-address-info host service hints)))
|
|
||||||
|
|
||||||
;; Start the server on local ipv6 addresses on port 5556.
|
|
||||||
(run-net-server (get-inet6-address-info #f 5556) echo-handler)
|
|
|
@ -1,22 +0,0 @@
|
||||||
#!/usr/bin/env chibi-scheme
|
|
||||||
|
|
||||||
(import (scheme base) (chibi net))
|
|
||||||
|
|
||||||
(define (get-udp-address-info host service)
|
|
||||||
(let ((hints (make-address-info address-family/inet
|
|
||||||
socket-type/datagram
|
|
||||||
ip-proto/udp)))
|
|
||||||
(get-address-info host service hints)))
|
|
||||||
|
|
||||||
;; create and bind a udp socket
|
|
||||||
(let* ((addr (get-udp-address-info #f 5556))
|
|
||||||
(sock (socket (address-info-family addr)
|
|
||||||
(address-info-socket-type addr)
|
|
||||||
(address-info-protocol addr))))
|
|
||||||
(bind sock (address-info-address addr) (address-info-address-length addr))
|
|
||||||
;; for every packet we receive, just send it back
|
|
||||||
(let lp ()
|
|
||||||
(cond
|
|
||||||
((receive sock 512 0 addr)
|
|
||||||
=> (lambda (bv) (send sock bv 0 addr))))
|
|
||||||
(lp)))
|
|
|
@ -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))))))))
|
|
435
gc.c
435
gc.c
|
@ -1,19 +1,21 @@
|
||||||
/* gc.c -- simple mark&sweep garbage collector */
|
/* gc.c -- simple mark&sweep garbage collector */
|
||||||
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */
|
||||||
/* BSD-style license: http://synthcode.com/license.txt */
|
/* BSD-style license: http://synthcode.com/license.txt */
|
||||||
|
|
||||||
#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC
|
#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC
|
||||||
|
|
||||||
#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,46 +453,32 @@ 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;
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp_heap sexp_make_heap (size_t size, size_t max_size, size_t chunk_size) {
|
sexp_heap sexp_make_heap (size_t size, size_t max_size) {
|
||||||
sexp_free_list free, next;
|
sexp_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->data = (char*) sexp_heap_align(sizeof(h->data)+(sexp_uint_t)&(h->data));
|
h->data = (char*) sexp_heap_align(sizeof(h->data)+(sexp_uint_t)&(h->data));
|
||||||
free = h->free_list = (sexp_free_list) h->data;
|
free = h->free_list = (sexp_free_list) h->data;
|
||||||
h->next = NULL;
|
h->next = NULL;
|
||||||
|
@ -611,48 +498,22 @@ sexp_heap sexp_make_heap (size_t size, size_t max_size, size_t chunk_size) {
|
||||||
return h;
|
return h;
|
||||||
}
|
}
|
||||||
|
|
||||||
int sexp_grow_heap (sexp ctx, size_t size, size_t chunk_size) {
|
int sexp_grow_heap (sexp ctx, size_t size) {
|
||||||
size_t cur_size, new_size;
|
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);
|
||||||
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
|
for (h=sexp_context_heap(ctx); h; h=h->next)
|
||||||
int found_fixed = 0;
|
for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next)
|
||||||
#endif
|
|
||||||
for (h=sexp_context_heap(ctx); h; h=h->next) {
|
|
||||||
#if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
|
|
||||||
if (h->chunk_size) {
|
|
||||||
if (h->chunk_size != size)
|
|
||||||
continue;
|
|
||||||
found_fixed = 1;
|
|
||||||
} else if (found_fixed) { /* don't use a non-fixed heap */
|
|
||||||
return NULL;
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) {
|
|
||||||
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"
|
||||||
|
@ -670,87 +531,207 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
|
||||||
memset((void*)ls2, 0, size);
|
memset((void*)ls2, 0, size);
|
||||||
return ls2;
|
return ls2;
|
||||||
}
|
}
|
||||||
}
|
|
||||||
}
|
|
||||||
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)))
|
||||||
&& ((!h->max_size) || (total_size < h->max_size)))
|
&& ((!h->max_size) || (total_size < h->max_size)))
|
||||||
sexp_grow_heap(ctx, size, 0);
|
sexp_grow_heap(ctx, size);
|
||||||
res = sexp_try_alloc(ctx, size);
|
res = sexp_try_alloc(ctx, size);
|
||||||
if (! res) {
|
if (! res) {
|
||||||
res = sexp_global(ctx, SEXP_G_OOM_ERROR);
|
res = sexp_global(ctx, SEXP_G_OOM_ERROR);
|
||||||
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);
|
||||||
|
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
|
||||||
sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
|
sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
|
||||||
#endif
|
#endif
|
||||||
#if SEXP_USE_GLOBAL_HEAP
|
#if SEXP_USE_GLOBAL_HEAP
|
||||||
sexp_global_heap = sexp_make_heap(size, SEXP_MAXIMUM_HEAP_SIZE, 0);
|
sexp_global_heap = sexp_make_heap(size, SEXP_MAXIMUM_HEAP_SIZE);
|
||||||
#endif
|
#endif
|
||||||
#if SEXP_USE_CONSERVATIVE_GC
|
#if SEXP_USE_CONSERVATIVE_GC
|
||||||
/* the +32 is a hack, but this is just for debugging anyway */
|
/* the +32 is a hack, but this is just for debugging anyway */
|
||||||
|
@ -758,4 +739,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-2012 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);
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
/* eval.h -- headers for eval library */
|
/* eval.h -- headers for eval library */
|
||||||
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
/* Copyright (c) 2009-2011 Alex Shinn. All rights reserved. */
|
||||||
/* BSD-style license: http://synthcode.com/license.txt */
|
/* BSD-style license: http://synthcode.com/license.txt */
|
||||||
|
|
||||||
#ifndef SEXP_EVAL_H
|
#ifndef SEXP_EVAL_H
|
||||||
|
@ -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-2012 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,21 +64,9 @@
|
||||||
/* 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 */
|
||||||
|
|
||||||
/* uncomment this to enable heap regions for fixed-size chunks */
|
|
||||||
/* #define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 1 */
|
|
||||||
|
|
||||||
/* uncomment this to just malloc manually instead of any GC */
|
/* uncomment this to just malloc manually instead of any GC */
|
||||||
/* Mostly for debugging purposes, this is the no GC option. */
|
/* Mostly for debugging purposes, this is the no GC option. */
|
||||||
/* You can use just the read/write API and */
|
/* You can use just the read/write API and */
|
||||||
|
@ -104,11 +81,6 @@
|
||||||
/* go away and you're not working on your own C extension. */
|
/* 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 +97,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 */
|
||||||
|
@ -143,10 +112,6 @@
|
||||||
/* may be very slow and using CFLAGS=-O0 is recommended. */
|
/* may be very slow and using CFLAGS=-O0 is recommended. */
|
||||||
/* #define SEXP_USE_SAFE_ACCESSORS 1 */
|
/* #define SEXP_USE_SAFE_ACCESSORS 1 */
|
||||||
|
|
||||||
/* uncomment to install a default signal handler in main() for segfaults */
|
|
||||||
/* This will print a helpful backtrace. */
|
|
||||||
/* #define SEXP_USE_PRINT_BACKTRACE_ON_SEGFAULT 1 */
|
|
||||||
|
|
||||||
/* uncomment this to make the heap common to all contexts */
|
/* uncomment this to make the heap common to all contexts */
|
||||||
/* By default separate contexts can have separate heaps, */
|
/* By default separate contexts can have separate heaps, */
|
||||||
/* and are thus thread-safe and independant. */
|
/* and are thus thread-safe and independant. */
|
||||||
|
@ -188,27 +153,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 +180,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 +190,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 */
|
||||||
|
@ -279,10 +201,11 @@
|
||||||
/* apply to stdin/stdout/stderr. */
|
/* apply to stdin/stdout/stderr. */
|
||||||
/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */
|
/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */
|
||||||
|
|
||||||
/* uncomment this to use a 2010/01/01 epoch */
|
/* uncomment this to use the normal 1970 unix epoch */
|
||||||
/* By default chibi uses the normal 1970 unix epoch in accordance */
|
/* By default chibi uses an datetime epoch starting at */
|
||||||
/* with R7RS, but this can represent more times as fixnums. */
|
/* 2010/01/01 00:00:00 in order to be able to represent */
|
||||||
/* #define SEXP_USE_2010_EPOCH 1 */
|
/* more common times as fixnums. */
|
||||||
|
/* #define SEXP_USE_2010_EPOCH 0 */
|
||||||
|
|
||||||
/* uncomment this to disable stack overflow checks */
|
/* uncomment this to disable stack overflow checks */
|
||||||
/* By default stacks are fairly small, so it's good to leave */
|
/* By default stacks are fairly small, so it's good to leave */
|
||||||
|
@ -301,7 +224,7 @@
|
||||||
|
|
||||||
/* uncomment this to make the VM adhere to alignment rules */
|
/* 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 +250,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 +259,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 +280,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 +288,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 +321,15 @@
|
||||||
#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
|
|
||||||
|
|
||||||
/* don't include clibs.c - include separately or link */
|
|
||||||
#ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
|
|
||||||
#if defined(PLAN9) || SEXP_USE_STATIC_LIBS_EMPTY
|
|
||||||
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 0
|
|
||||||
#else
|
|
||||||
#define SEXP_USE_STATIC_LIBS_NO_INCLUDE 1
|
|
||||||
#endif
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_FULL_SOURCE_INFO
|
#ifndef SEXP_USE_FULL_SOURCE_INFO
|
||||||
|
@ -507,21 +344,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
|
|
||||||
#define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 0
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef SEXP_USE_MALLOC
|
#ifndef SEXP_USE_MALLOC
|
||||||
#define SEXP_USE_MALLOC 0
|
#define SEXP_USE_MALLOC 0
|
||||||
|
@ -539,14 +364,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 +372,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 +380,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 +417,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 +491,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 +507,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 +568,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 +583,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 +592,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
|
||||||
|
@ -843,7 +608,7 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_USE_2010_EPOCH
|
#ifndef SEXP_USE_2010_EPOCH
|
||||||
#define SEXP_USE_2010_EPOCH 0
|
#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifndef SEXP_EPOCH_OFFSET
|
#ifndef SEXP_EPOCH_OFFSET
|
||||||
|
@ -880,10 +645,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 +653,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 +692,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 +708,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 +716,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 +731,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,92 +0,0 @@
|
||||||
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
|
|
||||||
|
|
||||||
char _huff_tab21[] = {
|
|
||||||
'\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab19[] = {
|
|
||||||
'\x01', 'j', '\x01', '\x00',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab20[] = {
|
|
||||||
'\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab18[] = {
|
|
||||||
'2', ':', '6', 'B', '4', '@', '8', 'D',
|
|
||||||
'3', ';', '7', 'C', '5', 'A', '9', 'E',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab17[] = {
|
|
||||||
'\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',',
|
|
||||||
'\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0',
|
|
||||||
'\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.',
|
|
||||||
'\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab16[] = {
|
|
||||||
'V', '^', 'Z', '|', 'X', '`', '\\', '~',
|
|
||||||
'W', '_', '[', '}', 'Y', '{', ']', '\x7f',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab15[] = {
|
|
||||||
'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T',
|
|
||||||
'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab13[] = {
|
|
||||||
'\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab14[] = {
|
|
||||||
'*', 'z',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab11[] = {
|
|
||||||
'\x00', 'b', '\x00', 'x',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab12[] = {
|
|
||||||
'!', 'k',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab9[] = {
|
|
||||||
'\x00', 's', '\x00', 'l',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab10[] = {
|
|
||||||
'y', 'w', '<', 'q',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab8[] = {
|
|
||||||
'p', '?', 'g', 'u',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab7[] = {
|
|
||||||
'f', '>', '=', 'v',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab5[] = {
|
|
||||||
'\x00', 'o', '\x00', 'd',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab6[] = {
|
|
||||||
'h', 'm',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab4[] = {
|
|
||||||
'c', 'i',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab3[] = {
|
|
||||||
'n', '-',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab1[] = {
|
|
||||||
'\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a',
|
|
||||||
};
|
|
||||||
|
|
||||||
char _huff_tab2[] = {
|
|
||||||
'e', 't',
|
|
||||||
};
|
|
||||||
|
|
839
include/chibi/sexp.h
Normal file → Executable file
839
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');
|
|
||||||
|
|
|
@ -13,8 +13,8 @@ sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_
|
||||||
#if SEXP_USE_GREEN_THREADS
|
#if SEXP_USE_GREEN_THREADS
|
||||||
if (res < 0 && errno == EWOULDBLOCK) {
|
if (res < 0 && errno == EWOULDBLOCK) {
|
||||||
f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
|
f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
|
||||||
if (sexp_applicablep(f)) {
|
if (sexp_opcodep(f)) {
|
||||||
sexp_apply2(ctx, f, sexp_make_fixnum(sock), SEXP_FALSE);
|
((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, sexp_make_fixnum(sock));
|
||||||
return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
|
return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -24,57 +24,8 @@ sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_
|
||||||
return sexp_make_fileno(ctx, sexp_make_fixnum(res), SEXP_FALSE);
|
return sexp_make_fileno(ctx, sexp_make_fixnum(res), SEXP_FALSE);
|
||||||
}
|
}
|
||||||
|
|
||||||
/* likewise sendto and recvfrom should suspend the thread gracefully */
|
/* If we're listening on a socket from Scheme, we most likely want it */
|
||||||
|
/* to be non-blocking. */
|
||||||
#define sexp_zerop(x) ((x) == SEXP_ZERO || (sexp_flonump(x) && sexp_flonum_value(x) == 0.0))
|
|
||||||
|
|
||||||
sexp sexp_sendto (sexp ctx, sexp self, int sock, const void* buffer, size_t len, int flags, struct sockaddr* addr, socklen_t addr_len, sexp timeout) {
|
|
||||||
#if SEXP_USE_GREEN_THREADS
|
|
||||||
sexp f;
|
|
||||||
#endif
|
|
||||||
ssize_t res;
|
|
||||||
res = sendto(sock, buffer, len, flags, addr, addr_len);
|
|
||||||
#if SEXP_USE_GREEN_THREADS
|
|
||||||
if (res < 0 && errno == EWOULDBLOCK && !sexp_zerop(timeout)) {
|
|
||||||
f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
|
|
||||||
if (sexp_applicablep(f)) {
|
|
||||||
sexp_apply2(ctx, f, sexp_make_fixnum(sock), timeout);
|
|
||||||
return sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
return sexp_make_fixnum(res);
|
|
||||||
}
|
|
||||||
|
|
||||||
sexp sexp_recvfrom (sexp ctx, sexp self, int sock, void* buffer, size_t len, int flags, struct sockaddr* addr, socklen_t addr_len, sexp timeout) {
|
|
||||||
#if SEXP_USE_GREEN_THREADS
|
|
||||||
sexp f;
|
|
||||||
#endif
|
|
||||||
ssize_t res;
|
|
||||||
res = recvfrom(sock, buffer, len, flags, addr, &addr_len);
|
|
||||||
#if SEXP_USE_GREEN_THREADS
|
|
||||||
if (res < 0 && errno == EWOULDBLOCK && !sexp_zerop(timeout)) {
|
|
||||||
f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
|
|
||||||
if (sexp_applicablep(f)) {
|
|
||||||
sexp_apply2(ctx, f, sexp_make_fixnum(sock), timeout);
|
|
||||||
return sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
return sexp_make_fixnum(res);
|
|
||||||
}
|
|
||||||
|
|
||||||
/* If we're binding or listening on a socket from Scheme, we most */
|
|
||||||
/* likely want it to be non-blocking. */
|
|
||||||
|
|
||||||
sexp sexp_bind (sexp ctx, sexp self, int fd, struct sockaddr* addr, socklen_t addr_len) {
|
|
||||||
int res = bind(fd, addr, addr_len);
|
|
||||||
#if SEXP_USE_GREEN_THREADS
|
|
||||||
if (res >= 0)
|
|
||||||
fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK);
|
|
||||||
#endif
|
|
||||||
return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
|
|
||||||
}
|
|
||||||
|
|
||||||
sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
|
sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
|
||||||
int fd, res;
|
int fd, res;
|
||||||
|
@ -92,19 +43,14 @@ 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[20];
|
||||||
/* 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,
|
|
||||||
(addr->sa_family == AF_INET6 ?
|
|
||||||
(void*)(&(((struct sockaddr_in6 *)addr)->sin6_addr)) :
|
|
||||||
(void*)(&(((struct sockaddr_in *)addr)->sin_addr))),
|
|
||||||
buf, INET6_ADDRSTRLEN);
|
|
||||||
return sexp_c_string(ctx, buf, -1);
|
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,240 +1,24 @@
|
||||||
;; 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-2013 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
|
;;> Parses command-line options into a config object.
|
||||||
;;> and/or positional arguments, with arbitrarily nested subcommands
|
|
||||||
;;> (optionally having their own arguments), and calls the
|
|
||||||
;;> corresponding main procedure on the parsed config.
|
|
||||||
;;>
|
|
||||||
;;> Given an application spec \var{spec}, parses the given
|
|
||||||
;;> command-line arguments \var{args} into a config object (from
|
|
||||||
;;> \scheme{(chibi config)}), prepended to the existing object
|
|
||||||
;;> \var{config} if given. Then runs the corresponding command (or
|
|
||||||
;;> sub-command) procedure from \var{spec} on the following arguments:
|
|
||||||
;;>
|
|
||||||
;;> \scheme{(<proc> <config> <spec> <positional args> ...)}
|
|
||||||
;;>
|
|
||||||
;;> The app spec should be a list of the form:
|
|
||||||
;;>
|
|
||||||
;;> \scheme{(<command> [<doc-string>] <clauses> ...)}
|
|
||||||
;;>
|
|
||||||
;;> where clauses can be any of:
|
|
||||||
;;>
|
|
||||||
;;> \itemlist[
|
|
||||||
;;> \item{\scheme{(@ <opt-spec>)} - option spec, described below}
|
|
||||||
;;> \item{\scheme{(begin: <begin-proc>)} - procedure to run before main}
|
|
||||||
;;> \item{\scheme{(end: <end-proc>)} - procedure to run after main}
|
|
||||||
;;> \item{\scheme{(types: (<type-name> <parser>) ...)} - additional types that can be used in argument parsing}
|
|
||||||
;;> \item{\scheme{(<proc> args ...)} - main procedure (args only for documentation)}
|
|
||||||
;;> \item{\scheme{<app-spec>} - a subcommand described by the nested spec}
|
|
||||||
;;> \item{\scheme{(or <app-spec> ...)} - an alternate list of subcommands}
|
|
||||||
;;> ]
|
|
||||||
;;>
|
|
||||||
;;> For subcommands the symbolic command name must match, though it is
|
|
||||||
;;> ignored for the initial spec (i.e. the application name is not
|
|
||||||
;;> checked). The \scheme{begin} and \scheme{end} procedures can be
|
|
||||||
;;> useful for loading and saving state common to all subcommands.
|
|
||||||
;;>
|
|
||||||
;;> The \scheme{opt-spec} describes command-line options, and is a
|
|
||||||
;;> simple list with each opt of the form:
|
|
||||||
;;>
|
|
||||||
;;> \scheme{(<name> <type> [(<aliases> ...)] [<doc-string>])}
|
|
||||||
;;>
|
|
||||||
;;> where \scheme{<name>} is a symbol name, \scheme{<aliases>} is an
|
|
||||||
;;> optional list of strings (for long options) or characters (for
|
|
||||||
;;> short options) to serve as aliases in addition to the exact name.
|
|
||||||
;;> \scheme{type} can be any of:
|
|
||||||
;;>
|
|
||||||
;;> \itemlist[
|
|
||||||
;;> \item{\scheme{boolean} - boolean, associated value optional, allowing \scheme{--noname} to indicate \scheme{#false}}
|
|
||||||
;;> \item{\scheme{char} - a single character}
|
|
||||||
;;> \item{\scheme{integer} - an exact integer}
|
|
||||||
;;> \item{\scheme{real} - any real number}
|
|
||||||
;;> \item{\scheme{number} - any real or complex number}
|
|
||||||
;;> \item{\scheme{symbol} - a symbol}
|
|
||||||
;;> \item{\scheme{string} - a string}
|
|
||||||
;;> \item{\scheme{sexp} - a sexp parsed with \scheme{read}}
|
|
||||||
;;> \item{\scheme{(list <type>)} - a comma-delimited list of types}
|
|
||||||
;;> ]
|
|
||||||
;;>
|
|
||||||
;;> Note that the options specs are composed entirely of objects that
|
|
||||||
;;> can be read and written, thus for example optionally loaded from
|
|
||||||
;;> files, whereas the app specs include embedded procedure objects so
|
|
||||||
;;> are typically written with \scheme{quasiquote}.
|
|
||||||
;;>
|
|
||||||
;;> Complete Example - stripped down ls(1):
|
|
||||||
;;>
|
|
||||||
;;> \schemeblock{
|
|
||||||
;;> (import (scheme base)
|
|
||||||
;;> (scheme process-context)
|
|
||||||
;;> (scheme write)
|
|
||||||
;;> (srfi 130)
|
|
||||||
;;> (chibi app)
|
|
||||||
;;> (chibi config)
|
|
||||||
;;> (chibi filesystem))
|
|
||||||
;;>
|
|
||||||
;;> (define (ls cfg spec . files)
|
|
||||||
;;> (for-each
|
|
||||||
;;> (lambda (x)
|
|
||||||
;;> (for-each
|
|
||||||
;;> (lambda (file)
|
|
||||||
;;> (unless (and (string-prefix? "." file)
|
|
||||||
;;> (not (conf-get cfg 'all)))
|
|
||||||
;;> (write-string file)
|
|
||||||
;;> (when (conf-get cfg 'long)
|
|
||||||
;;> (write-string " ")
|
|
||||||
;;> (write (file-modification-time file)))
|
|
||||||
;;> (newline)))
|
|
||||||
;;> (if (file-directory? x) (directory-files x) (list x))))
|
|
||||||
;;> files))
|
|
||||||
;;>
|
|
||||||
;;> (run-application
|
|
||||||
;;> `(ls
|
|
||||||
;;> "list directory contents"
|
|
||||||
;;> (@
|
|
||||||
;;> (long boolean (#\\l) "use a long listing format")
|
|
||||||
;;> (all boolean (#\\a) "do not ignore entries starting with ."))
|
|
||||||
;;> (,ls files ...))
|
|
||||||
;;> (command-line))
|
|
||||||
;;> }
|
|
||||||
;;>
|
|
||||||
;;> Subcommand Skeleton Example:
|
|
||||||
;;>
|
|
||||||
;;> \schemeblock{
|
|
||||||
;;> (run-application
|
|
||||||
;;> `(zoo
|
|
||||||
;;> "Zookeeper Application"
|
|
||||||
;;> (@
|
|
||||||
;;> (animals (list symbol) "list of animals to act on (default all)")
|
|
||||||
;;> (lions boolean (#\\l) "also apply the action to lions"))
|
|
||||||
;;> (or
|
|
||||||
;;> (feed "feed the animals" () (,feed animals ...))
|
|
||||||
;;> (wash "wash the animals" (@ (soap boolean)) (,wash animals ...))
|
|
||||||
;;> (help "print help" (,app-help-command))))
|
|
||||||
;;> (command-line)
|
|
||||||
;;> (conf-load (string-append (get-environment-variable "HOME") "/.zoo")))
|
|
||||||
;;> }
|
|
||||||
;;>
|
|
||||||
;;> The second and third arguments here are optional, provided to show
|
|
||||||
;;> the common pattern of allowing the same options to be specified
|
|
||||||
;;> either in a file and/or on the command-line. The above app can be
|
|
||||||
;;> run as:
|
|
||||||
;;>
|
|
||||||
;;> Feed all animals, including lions:
|
|
||||||
;;> \command{zoo -l feed}
|
|
||||||
;;>
|
|
||||||
;;> Wash the elephants with soap:
|
|
||||||
;;> \command{zoo --animals=elephant wash --soap}
|
|
||||||
;;>
|
|
||||||
;;> Print help:
|
|
||||||
;;> \command{zoo help}
|
|
||||||
;;>
|
|
||||||
;;> The application procedures themselves are of the form:
|
|
||||||
;;>
|
|
||||||
;;> \scheme{(proc cfg spec args ...)}
|
|
||||||
;;>
|
|
||||||
;;> where \var{cfg} is a config object from \scheme{(chibi config)}
|
|
||||||
;;> holding the parsed option info, \var{spec} is the original app
|
|
||||||
;;> spec, and \var{args} are the remaining non-option command-line
|
|
||||||
;;> arguments.
|
|
||||||
;;>
|
|
||||||
;;> To retrieve the options for the above example you can use:
|
|
||||||
;;>
|
|
||||||
;;> \itemlist[
|
|
||||||
;;> \item{\scheme{(conf-get cfg 'animals)}}
|
|
||||||
;;> \item{\scheme{(conf-get cfg 'lions)}}
|
|
||||||
;;> \item{\scheme{(conf-get cfg '(command wash soap))}}
|
|
||||||
;;> ]
|
|
||||||
;;>
|
|
||||||
;;> Notice that options for subcommands are nested under the
|
|
||||||
;;> \scheme{(command <name>)} prefix, so that you can use the same
|
|
||||||
;;> name for different subcommands without conflict. This also means
|
|
||||||
;;> the subcommand options are distinct from the top-level options, so
|
|
||||||
;;> when using subcommands users must always write the command line
|
|
||||||
;;> as:
|
|
||||||
;;>
|
|
||||||
;;> \command{app [<general options>] <subcommand> [<sub options>]}
|
|
||||||
;;>
|
|
||||||
;;> The ~/.zoo file could then hold an sexp of the form:
|
|
||||||
;;>
|
|
||||||
;;> \schemeblock{
|
|
||||||
;;> ((animals (camel elephant rhinocerous))
|
|
||||||
;;> (command
|
|
||||||
;;> (wash
|
|
||||||
;;> (soap #t))))
|
|
||||||
;;> }
|
|
||||||
|
|
||||||
(define (run-application spec . o)
|
(define (parse-option prefix conf-spec args fail)
|
||||||
(let ((args (or (and (pair? o) (car o)) (command-line)))
|
|
||||||
(config (and (pair? o) (pair? (cdr o)) (cadr o))))
|
|
||||||
(cond
|
|
||||||
((parse-app '() (cdr spec) '() (cdr args) config #f #f '())
|
|
||||||
=> (lambda (v)
|
|
||||||
(let ((proc (vector-ref v 0))
|
|
||||||
(cfg (vector-ref v 1))
|
|
||||||
(args (vector-ref v 2))
|
|
||||||
(init (vector-ref v 3))
|
|
||||||
(end (vector-ref v 4)))
|
|
||||||
(if init (init cfg))
|
|
||||||
(let ((res (apply proc cfg spec args)))
|
|
||||||
(if end (end cfg))
|
|
||||||
res))))
|
|
||||||
((null? (cdr args))
|
|
||||||
(app-help spec args)
|
|
||||||
(error "Expected a command"))
|
|
||||||
(else
|
|
||||||
(error "Unknown command" args)))))
|
|
||||||
|
|
||||||
;;> Parse a single command-line argument from \var{args} according to
|
|
||||||
;;> \var{conf-spec}, and returns a list of two values: the
|
|
||||||
;;> \scheme{(name value)} for the option, and a list of remaining
|
|
||||||
;;> unparsed args. \scheme{name} will have the current \var{prefix}
|
|
||||||
;;> prepended. If a parse error or unknown option is found, calls
|
|
||||||
;;> \var{fail} with a single string argument describing the error,
|
|
||||||
;;> returning that result.
|
|
||||||
|
|
||||||
(define (parse-option prefix conf-spec args types fail)
|
|
||||||
(define (parse-value type str)
|
(define (parse-value type str)
|
||||||
(cond
|
(cond
|
||||||
((not (string? str))
|
((not (string? str))
|
||||||
(list str #f))
|
str)
|
||||||
((and (pair? type) (eq? 'list (car type)))
|
((and (pair? type) (eq? 'list (car type)))
|
||||||
(let ((res (map (lambda (x) (parse-value (cadr type) x))
|
(map (lambda (x) (parse-value (cadr type) x))
|
||||||
(string-split str #\,))))
|
(string-split str #\,)))
|
||||||
(list (map car res) (any string? (map cdr res)))))
|
|
||||||
(else
|
(else
|
||||||
(case type
|
(case type
|
||||||
((boolean)
|
((boolean) (not (member str '("#f" "#false" "#F" "#FALSE"))))
|
||||||
(list (not (member str '("#f" "#false" "#F" "#FALSE" "false" "FALSE")))
|
((number) (string->number str))
|
||||||
#f))
|
((symbol) (string->symbol str))
|
||||||
((number integer real)
|
((char) (string-ref str 0))
|
||||||
(let ((n (string->number str)))
|
(else str)))))
|
||||||
(cond
|
|
||||||
((and (eq? type 'integer) (not (integer? n)))
|
|
||||||
(list n "expected an integer"))
|
|
||||||
((and (eq? type 'real) (not (real? n)))
|
|
||||||
(list n "expected a real number"))
|
|
||||||
(else
|
|
||||||
(list n #f)))))
|
|
||||||
((symbol)
|
|
||||||
(list (string->symbol str) #f))
|
|
||||||
((char)
|
|
||||||
(if (not (= 1 (string-length str)))
|
|
||||||
(list #f "expected a single character")
|
|
||||||
(list (string-ref str 0) #f)))
|
|
||||||
((sexp)
|
|
||||||
(list (guard (exn (else str))
|
|
||||||
(let* ((in (open-input-string str))
|
|
||||||
(res (read in)))
|
|
||||||
(close-input-port in)
|
|
||||||
res))
|
|
||||||
#f))
|
|
||||||
(else
|
|
||||||
(cond
|
|
||||||
((assq type types)
|
|
||||||
=> (lambda (cell) (list ((cadr cell) str) #f)))
|
|
||||||
(else (list str #f))))))))
|
|
||||||
(define (lookup-conf-spec conf-spec syms strs)
|
(define (lookup-conf-spec conf-spec syms strs)
|
||||||
(let ((sym (car syms))
|
(let ((sym (car syms))
|
||||||
(str (car strs)))
|
(str (car strs)))
|
||||||
|
@ -245,11 +29,8 @@
|
||||||
(let ((x (car ls)))
|
(let ((x (car ls)))
|
||||||
(cond
|
(cond
|
||||||
((eq? sym (car x)) x)
|
((eq? sym (car x)) x)
|
||||||
((and (pair? (cddr x)) (pair? (third x))
|
((and (pair? (cddr x)) (member str (car (cddr x)))) x)
|
||||||
(member str (third x)))
|
((and (pair? (cddr x)) (member `(not ,str) (car (cddr x))))
|
||||||
x)
|
|
||||||
((and (pair? (cddr x)) (pair? (third x))
|
|
||||||
(member `(not ,str) (third x)))
|
|
||||||
`(not ,x))
|
`(not ,x))
|
||||||
(else (lp (cdr ls))))))))
|
(else (lp (cdr ls))))))))
|
||||||
(else
|
(else
|
||||||
|
@ -258,8 +39,7 @@
|
||||||
(let ((x (car ls)))
|
(let ((x (car ls)))
|
||||||
(cond
|
(cond
|
||||||
((or (eq? sym (car x))
|
((or (eq? sym (car x))
|
||||||
(and (pair? (cddr x)) (pair? (third x))
|
(and (pair? (cddr x)) (member str (car (cddr x)))))
|
||||||
(member str (third x))))
|
|
||||||
(let ((type (cadr x)))
|
(let ((type (cadr x)))
|
||||||
(if (not (and (pair? type) (eq? 'conf (car type))))
|
(if (not (and (pair? type) (eq? 'conf (car type))))
|
||||||
(error "option prefix not a subconf" sym)
|
(error "option prefix not a subconf" sym)
|
||||||
|
@ -270,55 +50,48 @@
|
||||||
(and (pair? ls)
|
(and (pair? ls)
|
||||||
(let ((x (car ls)))
|
(let ((x (car ls)))
|
||||||
(cond
|
(cond
|
||||||
((and (pair? (cddr x)) (pair? (third x)) (memv ch (third x)))
|
((and (pair? (cddr x)) (memv ch (car (cddr x))))
|
||||||
x)
|
x)
|
||||||
((and (pair? (cddr x)) (pair? (third x))
|
((and (pair? (cddr x)) (member `(not ,ch) (car (cddr x))))
|
||||||
(member `(not ,ch) (third x)))
|
|
||||||
`(not ,x))
|
`(not ,x))
|
||||||
(else (lp (cdr ls))))))))
|
(else (lp (cdr ls))))))))
|
||||||
(define (parse-long-option str args fail)
|
(define (parse-conf-spec str args)
|
||||||
(let* ((fail-args (cons (string-append "--" str) args))
|
(let* ((strs (string-split str #\.))
|
||||||
(str+val (string-split str #\= 2))
|
|
||||||
(str (car str+val))
|
|
||||||
(args (if (pair? (cdr str+val)) (cons (cadr str+val) args) args))
|
|
||||||
(strs (string-split str #\.))
|
|
||||||
(syms (map string->symbol strs))
|
(syms (map string->symbol strs))
|
||||||
(spec (lookup-conf-spec conf-spec syms strs)))
|
(spec (lookup-conf-spec conf-spec syms strs)))
|
||||||
(cond
|
(cond
|
||||||
((not spec)
|
((not spec)
|
||||||
;; check for 'no' prefix on boolean
|
#f)
|
||||||
(if (not (string-prefix? "no" str))
|
|
||||||
(fail prefix conf-spec (car fail-args) fail-args "unknown option")
|
|
||||||
(let ((res (parse-long-option (substring str 2) args (lambda args #f))))
|
|
||||||
(cond
|
|
||||||
((not res)
|
|
||||||
(fail prefix conf-spec (car fail-args) fail-args
|
|
||||||
"unknown option"))
|
|
||||||
((not (boolean? (cdar res)))
|
|
||||||
(error "'no' prefix only valid on boolean options"))
|
|
||||||
(else
|
|
||||||
`((,(caar res) . #f) ,@(cdr res)))))))
|
|
||||||
((and (pair? spec) (eq? 'not (car spec)))
|
((and (pair? spec) (eq? 'not (car spec)))
|
||||||
(cons (cons (append prefix (list (car spec))) #f) args))
|
(cons (cons (append prefix (list (car spec))) #f) args))
|
||||||
((and (eq? 'boolean (cadr spec)) (null? (cdr str+val)))
|
((eq? 'boolean (cadr spec))
|
||||||
(cons (cons (append prefix (list (car spec))) #t) args))
|
(cons (cons (append prefix (list (car spec))) #t) args))
|
||||||
((null? args)
|
((null? args)
|
||||||
(fail prefix conf-spec (car fail-args) fail-args
|
(error "missing argument to option " str))
|
||||||
"missing argument to option"))
|
|
||||||
(else
|
(else
|
||||||
(let ((val+err (parse-value (cadr spec) (car args))))
|
(cons (cons (append prefix syms) (parse-value (cadr spec) (car args)))
|
||||||
(if (cadr val+err)
|
(cdr args))))))
|
||||||
(fail prefix conf-spec (car fail-args) fail-args (cadr val+err))
|
(define (parse-long-option str args)
|
||||||
(cons (cons (append prefix (drop-right syms 1) (list (car spec)))
|
(let* ((str+val (string-split str #\= 2))
|
||||||
(car val+err))
|
(str (car str+val))
|
||||||
(cdr args))))))))
|
(args2 (if (pair? (cdr str+val)) (cons (cadr str+val) args) args)))
|
||||||
(define (parse-short-option str args fail)
|
(or (parse-conf-spec str args2)
|
||||||
|
(and (string-prefix? "no-" str)
|
||||||
|
(let ((res (parse-long-option (substring str 3) args)))
|
||||||
|
(cond
|
||||||
|
((not res)
|
||||||
|
#f)
|
||||||
|
((not (boolean? (cdar res)))
|
||||||
|
(error "'no-' prefix only valid on boolean options"))
|
||||||
|
(else
|
||||||
|
`(((,@prefix ,(caar res)) . ,(not (cdar res)))
|
||||||
|
,@(cdr res)))))))))
|
||||||
|
(define (parse-short-option str args)
|
||||||
(let* ((ch (string-ref str 0))
|
(let* ((ch (string-ref str 0))
|
||||||
(x (lookup-short-option ch conf-spec))
|
(x (lookup-short-option ch conf-spec)))
|
||||||
(fail-args (cons (string-append "-" str) args)))
|
|
||||||
(cond
|
(cond
|
||||||
((not x)
|
((not x)
|
||||||
(fail prefix conf-spec (car fail-args) fail-args "unknown option"))
|
#f)
|
||||||
((and (pair? x) (eq? 'not (car x)))
|
((and (pair? x) (eq? 'not (car x)))
|
||||||
(cons (cons (append prefix (list (car (cadr x)))) #f)
|
(cons (cons (append prefix (list (car (cadr x)))) #f)
|
||||||
(if (= 1 (string-length str))
|
(if (= 1 (string-length str))
|
||||||
|
@ -330,26 +103,19 @@
|
||||||
args
|
args
|
||||||
(cons (string-append "-" (substring str 1)) args))))
|
(cons (string-append "-" (substring str 1)) args))))
|
||||||
((> (string-length str) 1)
|
((> (string-length str) 1)
|
||||||
(let ((val+err (parse-value (cadr x) (substring str 1))))
|
(cons (cons (append prefix (list (car x)))
|
||||||
(if (cadr val+err)
|
(parse-value (cadr x) (substring str 1)))
|
||||||
(fail prefix conf-spec (car args) args (cadr val+err))
|
args))
|
||||||
(cons (cons (append prefix (list (car x))) (car val+err))
|
|
||||||
args))))
|
|
||||||
((null? args)
|
((null? args)
|
||||||
(fail prefix conf-spec (car fail-args) fail-args
|
(error "missing argument to option " x))
|
||||||
"missing argument to option"))
|
|
||||||
(else
|
(else
|
||||||
(cons (cons (append prefix (list (car x))) (car args)) (cdr args))))))
|
(cons (cons (append prefix (list (car x))) (car args)) (cdr args))))))
|
||||||
(if (eqv? #\- (string-ref (car args) 1))
|
(or (if (eqv? #\- (string-ref (car args) 1))
|
||||||
(parse-long-option (substring (car args) 2) (cdr args) fail)
|
(parse-long-option (substring (car args) 2) (cdr args))
|
||||||
(parse-short-option (substring (car args) 1) (cdr args) fail)))
|
(parse-short-option (substring (car args) 1) (cdr args)))
|
||||||
|
(fail prefix conf-spec (car args) args)))
|
||||||
|
|
||||||
;;> Parse a list of command-line arguments into a config object.
|
(define (parse-options prefix conf-spec orig-args fail)
|
||||||
;;> Returns a list whose head is the resulting config object, and tail
|
|
||||||
;;> is the list of remaining non-option arguments. Calls fail on
|
|
||||||
;;> error and tries to continue processing from the result.
|
|
||||||
|
|
||||||
(define (parse-options prefix conf-spec orig-args types fail)
|
|
||||||
(let lp ((args orig-args)
|
(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,112 +125,58 @@
|
||||||
(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))))))))
|
||||||
|
|
||||||
;;> Parses a list of command-line arguments \var{args} according to
|
(define (parse-app prefix spec opt-spec args config init end . o)
|
||||||
;;> the application spec \var{opt-spec}. Returns a vector of five
|
|
||||||
;;> elements:
|
|
||||||
;;>
|
|
||||||
;;> \itemlist[
|
|
||||||
;;> \item{\scheme{proc} - procedure to run the application}
|
|
||||||
;;> \item{\scheme{config} - a config object containing all parsed options}
|
|
||||||
;;> \item{\scheme{args} - a list of remaining unparsed command-line arguments}
|
|
||||||
;;> \item{\scheme{init} - an optional procedure to call before \scheme{proc}}
|
|
||||||
;;> \item{\scheme{end} - an optional procedure to call after \scheme{proc}}
|
|
||||||
;;> ]
|
|
||||||
;;>
|
|
||||||
;;> The config object is prepended to \var{config}, with option names
|
|
||||||
;;> all prefixed by \var{prefix}. The original \var{spec} is used for
|
|
||||||
;;> \scheme{app-help}.
|
|
||||||
|
|
||||||
(define (parse-app prefix spec opt-spec args config init end types . o)
|
|
||||||
(define (next-prefix prefix name)
|
(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)
|
||||||
(cond
|
;; TODO: search for closest option
|
||||||
((and (string=? reason "unknown option")
|
(error "unknown option: " 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 opt args)
|
||||||
(parse-option (prev-prefix prefix) opt-spec new-args types fail)))
|
(parse-option (prev-prefix prefix) opt-spec 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 new-fail)))
|
||||||
init end types 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 fail))
|
||||||
(cadr (car spec)) end types 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)) fail))
|
||||||
init (cadr (car spec)) types 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 fail)))))
|
||||||
init end types 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 fail))))
|
||||||
init end types 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
|
||||||
|
@ -523,8 +235,6 @@
|
||||||
(if (pair? options) (display "Options:\n" out))
|
(if (pair? options) (display "Options:\n" out))
|
||||||
(for-each (lambda (o) (print-option-help o out)) options)))
|
(for-each (lambda (o) (print-option-help o out)) options)))
|
||||||
|
|
||||||
;;> Print a help summary for the given application spec \var{spec}.
|
|
||||||
|
|
||||||
(define (app-help spec args . o)
|
(define (app-help spec args . o)
|
||||||
(let ((out (if (pair? o) (car o) (current-output-port))))
|
(let ((out (if (pair? o) (car o) (current-output-port))))
|
||||||
(let lp ((ls (cdr spec))
|
(let lp ((ls (cdr spec))
|
||||||
|
@ -538,7 +248,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)
|
||||||
|
@ -549,9 +259,22 @@
|
||||||
(else
|
(else
|
||||||
(lp (cdr ls) docs commands options))))))
|
(lp (cdr ls) docs commands options))))))
|
||||||
|
|
||||||
;;> The subcommand form of \scheme{app-help}. You can use this as a
|
|
||||||
;;> subcommand in an application spec, for example as:
|
|
||||||
;;> \schemeblock{(help "print help" (,app-help-command args ...))}
|
|
||||||
|
|
||||||
(define (app-help-command config spec . args)
|
(define (app-help-command config spec . args)
|
||||||
(app-help spec args (current-output-port)))
|
(app-help spec args (current-output-port)))
|
||||||
|
|
||||||
|
(define (run-application spec . o)
|
||||||
|
(let ((args (or (and (pair? o) (car o)) (command-line)))
|
||||||
|
(config (and (pair? o) (pair? (cdr o)) (cadr o))))
|
||||||
|
(cond
|
||||||
|
((parse-app '() (cdr spec) '() (cdr args) config #f #f)
|
||||||
|
=> (lambda (v)
|
||||||
|
(let ((proc (vector-ref v 0))
|
||||||
|
(cfg (vector-ref v 1))
|
||||||
|
(args (vector-ref v 2))
|
||||||
|
(init (vector-ref v 3))
|
||||||
|
(end (vector-ref v 4)))
|
||||||
|
(if init (init cfg))
|
||||||
|
(apply proc cfg spec args)
|
||||||
|
(if end (end cfg)))))
|
||||||
|
(else
|
||||||
|
(error "Unknown command: " args)))))
|
||||||
|
|
|
@ -1,14 +1,11 @@
|
||||||
;;> Unified command-line option parsing and config management.
|
|
||||||
|
|
||||||
(define-library (chibi app)
|
(define-library (chibi app)
|
||||||
(export parse-option parse-options parse-app run-application
|
(export parse-option parse-options parse-app run-application
|
||||||
app-help app-help-command)
|
app-help app-help-command)
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme read)
|
|
||||||
(scheme write)
|
(scheme write)
|
||||||
(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)))))
|
|
298
lib/chibi/ast.c
298
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) {
|
||||||
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;
|
||||||
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,49 +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_errno (sexp ctx, sexp self, sexp_sint_t n) {
|
||||||
unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
|
|
||||||
sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
|
|
||||||
start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
|
|
||||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dst);
|
|
||||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, src);
|
|
||||||
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sfrom);
|
|
||||||
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sstart);
|
|
||||||
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
|
|
||||||
if (from < 0 || from > to)
|
|
||||||
return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
|
|
||||||
if (start < 0 || start > (sexp_sint_t)sexp_string_size(src))
|
|
||||||
return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
|
|
||||||
if (end < start || end > (sexp_sint_t)sexp_string_size(src))
|
|
||||||
return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
|
|
||||||
pfrom = (unsigned char*)sexp_string_data(dst) + from;
|
|
||||||
pto = (unsigned char*)sexp_string_data(dst) + to;
|
|
||||||
pstart = (unsigned char*)sexp_string_data(src) + start;
|
|
||||||
pend = (unsigned char*)sexp_string_data(src) + end;
|
|
||||||
for ( ; pfrom < pto && pstart < pend; ++pfrom, ++pstart)
|
|
||||||
*pfrom = *pstart;
|
|
||||||
/* adjust for incomplete trailing chars */
|
|
||||||
prev = (unsigned char*)sexp_string_utf8_prev(pfrom);
|
|
||||||
if (sexp_utf8_initial_byte_count(*prev) > pfrom - prev) {
|
|
||||||
for (p = prev; p < pfrom; ++p)
|
|
||||||
*p = '\0';
|
|
||||||
pstart -= pfrom - prev;
|
|
||||||
}
|
|
||||||
return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
|
|
||||||
}
|
|
||||||
|
|
||||||
sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
|
|
||||||
#ifdef PLAN9
|
#ifdef PLAN9
|
||||||
return SEXP_FALSE;
|
return SEXP_FALSE;
|
||||||
#else
|
#else
|
||||||
|
@ -586,7 +448,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,32 +463,25 @@ 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) {
|
|
||||||
sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
|
|
||||||
sexp_exception_message(res) = SEXP_TRAMPOLINE;
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
#define sexp_define_type(ctx, name, tag) \
|
#define sexp_define_type(ctx, name, tag) \
|
||||||
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 +514,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
|
sexp_define_type(ctx, "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 +531,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
|
sexp_define_type_predicate(ctx, env, "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 +555,22 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
|
sexp_define_accessors(ctx, env, SEXP_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 +593,12 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
|
sexp_define_foreign(ctx, env, "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,31 +608,17 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
||||||
sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
|
sexp_define_foreign(ctx, env, "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, "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);
|
||||||
sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
|
sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
|
||||||
sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv);
|
sexp_define_foreign(ctx, env, "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_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,42 +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)}
|
|
||||||
|
|
||||||
;;> Equivalent to \scheme{setenv} but does nothing and returns
|
|
||||||
;;> \scheme{#f} if \var{value} is a function definition. Used to
|
|
||||||
;;> circumvent the vulnerability of the shellshock bug.
|
|
||||||
|
|
||||||
(define (safe-setenv name value)
|
|
||||||
(define (function-def? str)
|
|
||||||
(and (> (string-size value) 5)
|
|
||||||
(equal? "() {" (substring value 0 4))))
|
|
||||||
(and (not (function-def? value))
|
|
||||||
(setenv name value)))
|
|
||||||
|
|
||||||
;;> \procedure{(atomically expr)}
|
;;> \procedure{(atomically expr)}
|
||||||
|
|
||||||
;;> Run \var{expr} atomically, disabling yields. Ideally should only be
|
;;> Run \var{expr} atomically, disabling yields. Ideally should only be
|
||||||
|
@ -436,7 +375,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
|
||||||
object-size object->integer integer->immediate gc gc-usecs gc-count
|
string-contains errno integer->error-string
|
||||||
atomically thread-list abort
|
flatten-dot update-free-vars! setenv unsetenv)
|
||||||
string-contains string-cursor-copy! errno integer->error-string
|
|
||||||
flatten-dot update-free-vars! setenv unsetenv safe-setenv
|
|
||||||
immutable? immutable-string make-immutable!
|
|
||||||
thread-interrupt!
|
|
||||||
chibi-version)
|
|
||||||
(import (chibi))
|
(import (chibi))
|
||||||
(include-shared "ast")
|
(include-shared "ast")
|
||||||
(include "ast.scm"))
|
(include "ast.scm"))
|
||||||
|
|
|
@ -1,42 +0,0 @@
|
||||||
(define-library (chibi base64-test)
|
|
||||||
(export run-tests)
|
|
||||||
(import (scheme base) (chibi base64) (chibi string) (chibi test))
|
|
||||||
(begin
|
|
||||||
(define (run-tests)
|
|
||||||
(test-begin "base64")
|
|
||||||
|
|
||||||
(test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
|
|
||||||
(base64-encode-string "any carnal pleasure."))
|
|
||||||
(test "YW55IGNhcm5hbCBwbGVhc3VyZQ=="
|
|
||||||
(base64-encode-string "any carnal pleasure"))
|
|
||||||
(test "YW55IGNhcm5hbCBwbGVhc3Vy"
|
|
||||||
(base64-encode-string "any carnal pleasur"))
|
|
||||||
(test "YW55IGNhcm5hbCBwbGVhc3U="
|
|
||||||
(base64-encode-string "any carnal pleasu"))
|
|
||||||
(test "YW55IGNhcm5hbCBwbGVhcw=="
|
|
||||||
(base64-encode-string "any carnal pleas"))
|
|
||||||
|
|
||||||
(test "any carnal pleas"
|
|
||||||
(base64-decode-string "YW55IGNhcm5hbCBwbGVhcw=="))
|
|
||||||
(test "any carnal pleasu"
|
|
||||||
(base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U="))
|
|
||||||
(test "any carnal pleasur"
|
|
||||||
(base64-decode-string "YW55IGNhcm5hbCBwbGVhc3Vy"))
|
|
||||||
(test "any carnal pleas"
|
|
||||||
(base64-decode-string "YW55IGNhcm5hbCBwbGVhcw"))
|
|
||||||
(test "any carnal pleasu"
|
|
||||||
(base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U"))
|
|
||||||
|
|
||||||
(test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
|
|
||||||
(call-with-output-string
|
|
||||||
(lambda (out)
|
|
||||||
(call-with-input-string "any carnal pleasure."
|
|
||||||
(lambda (in) (base64-encode in out))))))
|
|
||||||
|
|
||||||
(test "any carnal pleasure."
|
|
||||||
(call-with-output-string
|
|
||||||
(lambda (out)
|
|
||||||
(call-with-input-string "YW55IGNhcm5hbCBwbGVhc3VyZS4="
|
|
||||||
(lambda (in) (base64-decode in out))))))
|
|
||||||
|
|
||||||
(test-end))))
|
|
|
@ -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,265 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; Record types with user-specified binary formats.
|
||||||
;; Binary Records
|
;; A work in progress, but sufficient for tar files.
|
||||||
|
|
||||||
;;> \macro{(define-binary-record-type <name> [<bindings> ...] (block: <fields> ...))}
|
(define (assert-read-u8 in i)
|
||||||
;;>
|
(let ((i2 (read-u8 in)))
|
||||||
;;> Defines a new record type that supports serializing to and from
|
(if (not (eqv? i i2))
|
||||||
;;> binary ports. The generated procedures accept keyword-style
|
(error "unexpected value: " i i2)
|
||||||
;;> arguments:
|
i2)))
|
||||||
;;>
|
|
||||||
;;> \itemlist[
|
(define (assert-read-char in ch)
|
||||||
;;> \item{\scheme{(make: <constructor-name>)}}
|
(let ((ch2 (read-char in)))
|
||||||
;;> \item{\scheme{(pred: <predicate-name>)}}
|
(if (not (eqv? ch ch2))
|
||||||
;;> \item{\scheme{(read: <reader-name>)}}
|
(error "unexpected value: " ch ch2)
|
||||||
;;> \item{\scheme{(write: <writer-name>)}}
|
ch2)))
|
||||||
;;> \item{\scheme{(block: <fields> ...)}}
|
|
||||||
;;> ]
|
(define (assert-read-string in s)
|
||||||
;;>
|
(let ((s2 (read-string (string-length s) in)))
|
||||||
;;> The fields are also similar to \scheme{define-record-type} but
|
(if (not (equal? s s2))
|
||||||
;;> with an additional type:
|
(error "unexpected value: " s s2)
|
||||||
;;>
|
s2)))
|
||||||
;;> \scheme{(field (type args ...) getter setter)}
|
|
||||||
;;>
|
(define (assert-read-bytevector in bv)
|
||||||
;;> Built-in types include:
|
(let ((bv2 (read-bytevector (bytevector-length bv) in)))
|
||||||
;;>
|
(if (not (equal? bv bv2))
|
||||||
;;> \itemlist[
|
(error "unexpected value: " bv bv2)
|
||||||
;;> \item{\scheme{(u8)} - a single byte in [0, 255]}
|
bv2)))
|
||||||
;;> \item{\scheme{(u16/le)} - a little-endian short integer}
|
|
||||||
;;> \item{\scheme{(u16/be)} - a big-endian short integer}
|
(define (assert-read-integer in len radix)
|
||||||
;;> \item{\scheme{(fixed-string <length>)} - a fixed-length utf-8 string}
|
(let* ((s (string-trim (read-string len in)
|
||||||
;;> \item{\scheme{(padded-string <length> (pad <pad-char>))} - a utf-8 string padded to a given length}
|
(lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
|
||||||
;;> \item{\scheme{(octal <length>)} - an integer in octal string format}
|
(n (if (equal? s "") 0 (string->number s radix))))
|
||||||
;;> \item{\scheme{(decimal <length>)} - an integer in decimal string format}
|
(or n (error "invalid number syntax: " s))))
|
||||||
;;> \item{\scheme{(hexadecimal <length>)} - an integer in hexadecimal string format}
|
|
||||||
;;> ]
|
(define (read-padded-string in len pad)
|
||||||
;;>
|
(string-trim-right (read-string len in) pad))
|
||||||
;;> In addition, the field can be a literal (char, string or
|
|
||||||
;;> bytevector), for instance as a file magic sequence or fixed
|
(define (expand-read rename in spec)
|
||||||
;;> separator. The fields (and any constants) are serialized in the
|
(case (car spec)
|
||||||
;;> order they appear in the block. For example, the header of a GIF
|
((literal)
|
||||||
;;> file could be defined as:
|
(let ((val (cadr spec)))
|
||||||
;;>
|
(cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
|
||||||
;;> \example{
|
((char? val) `(,(rename 'assert-read-char) ,in ,val))
|
||||||
;;> (define-binary-record-type gif-header
|
((string? val) `(,(rename 'assert-read-string) ,in ,val))
|
||||||
;;> (make: make-gif-header)
|
((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
|
||||||
;;> (pred: gif-header?)
|
(else (error "unknown binary literal: " val)))))
|
||||||
;;> (read: read-gif-header)
|
((octal)
|
||||||
;;> (write: write-gif-header)
|
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
|
||||||
;;> (block:
|
((decimal)
|
||||||
;;> "GIF89a"
|
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
|
||||||
;;> (width (u16/le) gif-header-width)
|
((hexadecimal)
|
||||||
;;> (height (u16/le) gif-header-height)
|
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
|
||||||
;;> (gct (u8) gif-header-gct)
|
((fixed-string)
|
||||||
;;> (bgcolor (u8) gif-header-gbcolor)
|
(let ((len (cadr spec)))
|
||||||
;;> (aspect-ratio (u8) gif-header-aspect-ratio)
|
`(,(rename 'read-string) ,len ,in)))
|
||||||
;;> ))
|
((padded-string)
|
||||||
;;> }
|
(let ((len (cadr spec))
|
||||||
;;>
|
(pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
|
||||||
;;> For a more complex example see the \scheme{(chibi tar)}
|
`(,(rename 'read-padded-string) ,in ,len ,pad)))
|
||||||
;;> implementation.
|
(else
|
||||||
;;>
|
(error "unknown binary format: " spec))))
|
||||||
;;> The binary type itself is a macro used to expand to a predicate
|
|
||||||
;;> and reader/writer procedures, which can be defined with
|
(define (string-pad-left str len . o)
|
||||||
;;> \scheme{define-binary-type}. For example,
|
(let ((diff (- len (string-length str)))
|
||||||
;;>
|
(pad-ch (if (pair? o) (car o) #\space)))
|
||||||
;;> \example{
|
(if (positive? diff)
|
||||||
;;> (define-binary-type (u8)
|
(string-append (make-string diff pad-ch) str)
|
||||||
;;> (lambda (x) (and (exact-integer? x) (<= 0 x 255)))
|
str)))
|
||||||
;;> read-u8
|
|
||||||
;;> write-u8)
|
(define (string-pad-right str len . o)
|
||||||
;;> }
|
(let ((diff (- len (string-length str)))
|
||||||
|
(pad-ch (if (pair? o) (car o) #\space)))
|
||||||
|
(if (positive? diff)
|
||||||
|
(string-append str (make-string diff pad-ch))
|
||||||
|
str)))
|
||||||
|
|
||||||
|
(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
|
||||||
|
(let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch)))
|
||||||
|
(cond
|
||||||
|
((>= (string-length s) len)
|
||||||
|
(error "number too large for width" n radix len))
|
||||||
|
(else
|
||||||
|
(write-string s out)
|
||||||
|
(write-char right-pad-ch out)))))
|
||||||
|
|
||||||
|
(define (expand-write rename out val spec)
|
||||||
|
(let ((_if (rename 'if))
|
||||||
|
(_not (rename 'not))
|
||||||
|
(_let (rename 'let))
|
||||||
|
(_string-length (rename 'string-length))
|
||||||
|
(_write-string (rename 'write-string))
|
||||||
|
(_write-bytevector (rename 'write-bytevector))
|
||||||
|
(_error (rename 'error))
|
||||||
|
(_> (rename '>))
|
||||||
|
(_= (rename '=)))
|
||||||
|
(case (car spec)
|
||||||
|
((literal)
|
||||||
|
(let ((val (cadr spec)))
|
||||||
|
(cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
|
||||||
|
((char? val) `(,(rename 'write-char) ,val ,out))
|
||||||
|
((string? val) `(,_write-string ,val ,out))
|
||||||
|
((bytevector? val) `(,_write-bytevector ,val ,out))
|
||||||
|
(else (error "unknown binary literal: " val)))))
|
||||||
|
((octal)
|
||||||
|
`(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
|
||||||
|
((decimal)
|
||||||
|
`(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
|
||||||
|
((hexadecimal)
|
||||||
|
`(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
|
||||||
|
((fixed-string)
|
||||||
|
(let ((len (cadr spec)))
|
||||||
|
`(,_if (,_not (,_= ,len (,_string-length ,val)))
|
||||||
|
(,_error "wrong field length: " ,val ,len)
|
||||||
|
(,_write-string ,val ,out))))
|
||||||
|
((padded-string)
|
||||||
|
(let ((len (cadr spec))
|
||||||
|
(pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
|
||||||
|
`(,_let ((l (,_string-length ,val)))
|
||||||
|
(,_if (,_> l ,len)
|
||||||
|
(,_error "field too large: " ,val ,len)
|
||||||
|
(,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
|
||||||
|
,out)))))
|
||||||
|
(else
|
||||||
|
(error "unknown binary format: " spec)))))
|
||||||
|
|
||||||
|
(define (expand-assert rename spec x v)
|
||||||
|
(let ((_if (rename 'if))
|
||||||
|
(_not (rename 'not))
|
||||||
|
(_error (rename 'error))
|
||||||
|
(_integer? (rename 'integer?))
|
||||||
|
(_string? (rename 'string?))
|
||||||
|
(_string-length (rename 'string-length))
|
||||||
|
(_> (rename '>)))
|
||||||
|
(case (car spec)
|
||||||
|
((literal) #t)
|
||||||
|
((octal decimal hexadecimal)
|
||||||
|
`(,_if (,_not (,_integer? ,v))
|
||||||
|
(,_error "expected an integer" ,v)))
|
||||||
|
((fixed-string padded-string)
|
||||||
|
(let ((len (cadr spec)))
|
||||||
|
`(,_if (,_not (,_string? ,v))
|
||||||
|
(,_error "expected a string" ,v)
|
||||||
|
(,_if (,_> (,_string-length ,v) ,len)
|
||||||
|
(,_error "string too long" ,v ,len)))))
|
||||||
|
(else (error "unknown binary format: " spec)))))
|
||||||
|
|
||||||
|
(define (expand-default rename spec)
|
||||||
|
(case (car spec)
|
||||||
|
((literal) (cadr spec))
|
||||||
|
((octal decimal hexadecimal) 0)
|
||||||
|
((fixed-string) (make-string (cadr spec) #\space))
|
||||||
|
((padded-string) "")
|
||||||
|
(else (error "unknown binary format: " spec))))
|
||||||
|
|
||||||
|
(define (param-ref ls key . o)
|
||||||
|
(cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
|
||||||
|
|
||||||
|
(define (symbol-append a b)
|
||||||
|
(string->symbol (string-append (symbol->string a) (symbol->string b))))
|
||||||
|
|
||||||
|
(define-record-type Field
|
||||||
|
(make-field name get set raw-set spec)
|
||||||
|
field?
|
||||||
|
(name field-name)
|
||||||
|
(get field-get)
|
||||||
|
(set field-set)
|
||||||
|
(raw-set field-raw-set)
|
||||||
|
(spec field-spec))
|
||||||
|
|
||||||
|
(define (extract-fields type ls)
|
||||||
|
(let lp ((ls ls) (res '()))
|
||||||
|
(cond
|
||||||
|
((null? ls)
|
||||||
|
(reverse res))
|
||||||
|
((not (pair? (car ls)))
|
||||||
|
(lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
|
||||||
|
(else
|
||||||
|
(let* ((name (caar ls))
|
||||||
|
(get (or (param-ref (car ls) 'getter)
|
||||||
|
(and (not (eq? name '_))
|
||||||
|
(symbol-append type (symbol-append '- name)))))
|
||||||
|
(set (or (param-ref (car ls) 'setter)
|
||||||
|
(and (not (eq? name '_))
|
||||||
|
(symbol-append (symbol-append type '-)
|
||||||
|
(symbol-append name '-set!)))))
|
||||||
|
(raw-set (and set (symbol-append '% set)))
|
||||||
|
(spec (cadr (car ls))))
|
||||||
|
(lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
|
||||||
|
|
||||||
(define-syntax define-binary-record-type
|
(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,8 @@
|
||||||
|
|
||||||
(define-library (chibi binary-record)
|
(define-library (chibi binary-record)
|
||||||
(import (scheme base) (srfi 1))
|
(import (scheme base)
|
||||||
(cond-expand
|
(srfi 1) (srfi 9)
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
(chibi io) (chibi string)
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
(only (chibi) identifier? er-macro-transformer))
|
||||||
(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))))
|
|
|
@ -1,83 +1,28 @@
|
||||||
|
|
||||||
;;> \section{Additional accessors}
|
;;> \section{Additional accessors}
|
||||||
|
|
||||||
;;> Retrieve a 16-bit unsigned integer value from the given bytevector
|
(define (bytevector-u16-ref-le str i)
|
||||||
;;> \var{bv} at offset \var{i}, in little-endian order.
|
(+ (bytevector-u8-ref str i)
|
||||||
|
(arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8)))
|
||||||
|
|
||||||
(define (bytevector-u16-ref-le bv i)
|
(define (bytevector-u16-ref-be str i)
|
||||||
(+ (bytevector-u8-ref bv i)
|
(+ (arithmetic-shift (bytevector-u8-ref str i) 8)
|
||||||
(arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 8)))
|
(bytevector-u8-ref str (+ i 1))))
|
||||||
|
|
||||||
;;> Retrieve a 16-bit unsigned integer value from the given bytevector
|
(define (bytevector-u32-ref-le str i)
|
||||||
;;> \var{bv} at offset \var{i}, in big-endian order.
|
(+ (bytevector-u8-ref str i)
|
||||||
|
(arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8)
|
||||||
|
(arithmetic-shift (bytevector-u8-ref str (+ i 2)) 16)
|
||||||
|
(arithmetic-shift (bytevector-u8-ref str (+ i 3)) 24)))
|
||||||
|
|
||||||
(define (bytevector-u16-ref-be bv i)
|
(define (bytevector-u32-ref-be str i)
|
||||||
(+ (arithmetic-shift (bytevector-u8-ref bv i) 8)
|
(+ (arithmetic-shift (bytevector-u8-ref str i) 24)
|
||||||
(bytevector-u8-ref bv (+ i 1))))
|
(arithmetic-shift (bytevector-u8-ref str (+ i 1)) 16)
|
||||||
|
(arithmetic-shift (bytevector-u8-ref str (+ i 2)) 8)
|
||||||
;;> Retrieve a 32-bit unsigned integer value from the given bytevector
|
(bytevector-u8-ref str (+ i 3))))
|
||||||
;;> \var{bv} at offset \var{i}, in little-endian order.
|
|
||||||
|
|
||||||
(define (bytevector-u32-ref-le bv i)
|
|
||||||
(+ (bytevector-u8-ref bv i)
|
|
||||||
(arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 8)
|
|
||||||
(arithmetic-shift (bytevector-u8-ref bv (+ i 2)) 16)
|
|
||||||
(arithmetic-shift (bytevector-u8-ref bv (+ i 3)) 24)))
|
|
||||||
|
|
||||||
;;> Retrieve a 32-bit unsigned integer value from the given bytevector
|
|
||||||
;;> \var{bv} at offset \var{i}, in big-endian order.
|
|
||||||
|
|
||||||
(define (bytevector-u32-ref-be bv i)
|
|
||||||
(+ (arithmetic-shift (bytevector-u8-ref bv i) 24)
|
|
||||||
(arithmetic-shift (bytevector-u8-ref bv (+ i 1)) 16)
|
|
||||||
(arithmetic-shift (bytevector-u8-ref bv (+ i 2)) 8)
|
|
||||||
(bytevector-u8-ref bv (+ i 3))))
|
|
||||||
|
|
||||||
;;> \section{Bignum encodings}
|
|
||||||
|
|
||||||
;;> A BER compressed integer (X.209) is an unsigned integer in base 128,
|
|
||||||
;;> most significant digit first, where the high bit is set on all but the
|
|
||||||
;;> final (least significant) byte. Thus any size integer can be
|
|
||||||
;;> encoded, but the encoding is efficient and small integers don't take
|
|
||||||
;;> up any more space than they would in normal char/short/int encodings.
|
|
||||||
|
|
||||||
(define (bytevector-ber-ref bv . o)
|
|
||||||
(let ((end (if (and (pair? o) (pair? (cdr o)))
|
|
||||||
(cadr o)
|
|
||||||
(bytevector-length bv))))
|
|
||||||
(let lp ((acc 0) (i (if (pair? o) (car o) 0)))
|
|
||||||
(if (>= i end)
|
|
||||||
(error "unterminated ber integer in bytevector" bv)
|
|
||||||
(let ((b (bytevector-u8-ref bv i)))
|
|
||||||
(if (< b 128)
|
|
||||||
(+ acc b)
|
|
||||||
(lp (arithmetic-shift (+ acc (bitwise-and b 127)) 7)
|
|
||||||
(+ i 1))))))))
|
|
||||||
|
|
||||||
(define (bytevector-ber-set! bv n . o)
|
|
||||||
;;(assert (integer? number) (not (negative? number)))
|
|
||||||
(let ((start (if (pair? o) (car o) 0))
|
|
||||||
(end (if (and (pair? o) (pair? (cdr o)))
|
|
||||||
(cadr o)
|
|
||||||
(bytevector-length bv))))
|
|
||||||
(let lp ((n (arithmetic-shift n -7))
|
|
||||||
(ls (list (bitwise-and n 127))))
|
|
||||||
(if (zero? n)
|
|
||||||
(do ((i start (+ i 1))
|
|
||||||
(ls ls (cdr ls)))
|
|
||||||
((null? ls))
|
|
||||||
(if (>= i end)
|
|
||||||
(error "integer doesn't fit in bytevector as ber"
|
|
||||||
bv n start end)
|
|
||||||
(bytevector-u8-set! bv i (car ls))))
|
|
||||||
(lp (arithmetic-shift n -7)
|
|
||||||
(cons (+ 128 (bitwise-and n 127)) ls))))))
|
|
||||||
|
|
||||||
;;> \section{Integer conversion}
|
;;> \section{Integer conversion}
|
||||||
|
|
||||||
;;> Convert an unsigned integer \var{n} to a bytevector representing
|
|
||||||
;;> the base-256 big-endian form (the zero index holds the MSB).
|
|
||||||
|
|
||||||
(define (integer->bytevector n)
|
(define (integer->bytevector n)
|
||||||
(cond
|
(cond
|
||||||
((zero? n)
|
((zero? n)
|
||||||
|
@ -95,10 +40,6 @@
|
||||||
(bytevector-u8-set! bv i (car ls))))
|
(bytevector-u8-set! bv i (car ls))))
|
||||||
(lp (quotient n 256) (cons (remainder n 256) res)))))))
|
(lp (quotient n 256) (cons (remainder n 256) res)))))))
|
||||||
|
|
||||||
;;> The inverse of \scheme{integer->bytevector}. Convert a bytevector
|
|
||||||
;;> representing the base-256 big-endian form (the zero index holds
|
|
||||||
;;> the MSB) to the corresponding unsigned integer.
|
|
||||||
|
|
||||||
(define (bytevector->integer bv)
|
(define (bytevector->integer bv)
|
||||||
(let ((len (bytevector-length bv)))
|
(let ((len (bytevector-length bv)))
|
||||||
(let lp ((i 0) (n 0))
|
(let lp ((i 0) (n 0))
|
||||||
|
@ -108,9 +49,6 @@
|
||||||
(+ (arithmetic-shift n 8)
|
(+ (arithmetic-shift n 8)
|
||||||
(bytevector-u8-ref bv i)))))))
|
(bytevector-u8-ref bv i)))))))
|
||||||
|
|
||||||
;;> Utility to pad a bytevector with zeros. Padding is added to the
|
|
||||||
;;> left so as not to change the big-endian value.
|
|
||||||
|
|
||||||
(define (bytevector-pad-left bv len)
|
(define (bytevector-pad-left bv len)
|
||||||
(let ((diff (- len (bytevector-length bv))))
|
(let ((diff (- len (bytevector-length bv))))
|
||||||
(if (positive? diff)
|
(if (positive? diff)
|
||||||
|
|
|
@ -1,41 +1,11 @@
|
||||||
|
|
||||||
;;> Additional bytevector utilities.
|
|
||||||
|
|
||||||
(define-library (chibi bytevector)
|
(define-library (chibi bytevector)
|
||||||
(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) (srfi 33))
|
||||||
bytevector-ieee-single-native-ref
|
(include "bytevector.scm"))
|
||||||
bytevector-ieee-single-set!
|
|
||||||
bytevector-ieee-single-native-set!
|
|
||||||
bytevector-ieee-double-ref
|
|
||||||
bytevector-ieee-double-native-ref
|
|
||||||
bytevector-ieee-double-set!
|
|
||||||
bytevector-ieee-double-native-set!
|
|
||||||
)
|
|
||||||
(import (scheme base) (scheme inexact))
|
|
||||||
(cond-expand
|
|
||||||
(big-endian
|
|
||||||
(begin
|
|
||||||
(define-syntax native-endianness
|
|
||||||
(syntax-rules () ((_) 'big)))))
|
|
||||||
(else
|
|
||||||
(begin
|
|
||||||
(define-syntax native-endianness
|
|
||||||
(syntax-rules () ((_) 'little))))))
|
|
||||||
(cond-expand
|
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
|
||||||
(else (import (srfi 60))))
|
|
||||||
(include "bytevector.scm")
|
|
||||||
(cond-expand
|
|
||||||
(chibi
|
|
||||||
(import (except (scheme bytevector) bytevector-copy!)))
|
|
||||||
(else
|
|
||||||
(include "ieee-754.scm"))))
|
|
||||||
|
|
|
@ -26,7 +26,7 @@
|
||||||
(set-cdr! rear new))
|
(set-cdr! rear new))
|
||||||
(else ; sending to empty channel
|
(else ; sending to empty channel
|
||||||
(channel-front-set! chan new)
|
(channel-front-set! chan new)
|
||||||
(condition-variable-broadcast! (channel-condvar chan)))))
|
(condition-variable-signal! (channel-condvar chan)))))
|
||||||
(mutex-unlock! (channel-mutex chan)))
|
(mutex-unlock! (channel-mutex chan)))
|
||||||
|
|
||||||
(define (channel-receive! chan)
|
(define (channel-receive! chan)
|
||||||
|
|
|
@ -1,9 +1,6 @@
|
||||||
|
|
||||||
(define-library (chibi channel)
|
(define-library (chibi channel)
|
||||||
(cond-expand
|
(import (chibi) (srfi 9) (srfi 18))
|
||||||
(chibi (import (chibi) (srfi 9)))
|
|
||||||
(else (import (scheme base))))
|
|
||||||
(import (srfi 18))
|
|
||||||
(export Channel make-channel channel? channel-empty?
|
(export Channel make-channel channel? channel-empty?
|
||||||
channel-send! channel-receive!)
|
channel-send! channel-receive!)
|
||||||
(include "channel.scm"))
|
(include "channel.scm"))
|
||||||
|
|
|
@ -1,8 +1,6 @@
|
||||||
|
|
||||||
;;> A minimal character set library.
|
|
||||||
|
|
||||||
(define-library (chibi char-set)
|
(define-library (chibi char-set)
|
||||||
(import (chibi char-set base) (chibi char-set extras))
|
(import (chibi) (chibi char-set base) (chibi char-set extras))
|
||||||
(export
|
(export
|
||||||
Char-Set char-set? char-set-contains?
|
Char-Set char-set? char-set-contains?
|
||||||
char-set ucs-range->char-set char-set-copy char-set-size
|
char-set ucs-range->char-set char-set-copy char-set-size
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
||||||
|
|
|
@ -1,23 +1,14 @@
|
||||||
|
|
||||||
(define-library (chibi char-set base)
|
(define-library (chibi char-set base)
|
||||||
(cond-expand
|
(import (chibi) (chibi iset base))
|
||||||
(chibi
|
|
||||||
(import (chibi))
|
|
||||||
(begin
|
|
||||||
(define-syntax immutable-char-set
|
|
||||||
(sc-macro-transformer
|
|
||||||
(lambda (expr use-env)
|
|
||||||
(eval (cadr expr) use-env))))))
|
|
||||||
(else
|
|
||||||
(import (scheme base))
|
|
||||||
(begin
|
|
||||||
(define-syntax immutable-char-set
|
|
||||||
(syntax-rules () ((immutable-char-set cs) cs))))))
|
|
||||||
(import (chibi iset base))
|
|
||||||
(export (rename Integer-Set Char-Set)
|
(export (rename Integer-Set Char-Set)
|
||||||
(rename iset? char-set?)
|
(rename iset? char-set?)
|
||||||
immutable-char-set
|
immutable-char-set
|
||||||
char-set-contains?)
|
char-set-contains?)
|
||||||
(begin
|
(begin
|
||||||
|
(define-syntax immutable-char-set
|
||||||
|
(sc-macro-transformer
|
||||||
|
(lambda (expr use-env)
|
||||||
|
(eval (cadr expr) use-env))))
|
||||||
(define (char-set-contains? cset ch)
|
(define (char-set-contains? cset ch)
|
||||||
(iset-contains? cset (char->integer ch)))))
|
(iset-contains? cset (char->integer ch)))))
|
||||||
|
|
|
@ -1,19 +1,11 @@
|
||||||
;; Character sets for Unicode boundaries, TR29.
|
;; Character sets for Unicode boundaries, TR29.
|
||||||
;; This code is written by Alex Shinn and placed in the
|
|
||||||
;; Public Domain. All warranties are disclaimed.
|
|
||||||
|
|
||||||
;;> Char-sets used for
|
|
||||||
;;> \hyperlink["http://unicode.org/reports/tr29/"]{TR29} word
|
|
||||||
;;> boundaries.
|
|
||||||
|
|
||||||
(define-library (chibi char-set boundary)
|
(define-library (chibi char-set boundary)
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(chibi (import (chibi)))
|
(chibi
|
||||||
(else (import (scheme base))))
|
(import (chibi) (chibi char-set)))
|
||||||
(cond-expand
|
|
||||||
((library (chibi char-set)) (import (chibi char-set)))
|
|
||||||
(else
|
(else
|
||||||
(import (srfi 14))
|
(import (scheme base) (srfi 14))
|
||||||
(begin (define (immutable-char-set cs) cs))))
|
(begin (define (immutable-char-set cs) cs))))
|
||||||
(export char-set:regional-indicator
|
(export char-set:regional-indicator
|
||||||
char-set:extend-or-spacing-mark
|
char-set:extend-or-spacing-mark
|
||||||
|
|
|
@ -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!)
|
||||||
|
|
|
@ -1,9 +1,6 @@
|
||||||
|
|
||||||
(define-library (chibi char-set extras)
|
(define-library (chibi char-set extras)
|
||||||
(cond-expand
|
(import (chibi) (chibi iset) (chibi char-set base))
|
||||||
(chibi (import (chibi)))
|
|
||||||
(else (import (scheme base))))
|
|
||||||
(import (chibi iset) (chibi char-set base))
|
|
||||||
(include "extras.scm")
|
(include "extras.scm")
|
||||||
(export
|
(export
|
||||||
char-set ucs-range->char-set char-set-copy char-set-size
|
char-set ucs-range->char-set char-set-copy char-set-size
|
||||||
|
|
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)
|
||||||
|
@ -297,7 +287,7 @@
|
||||||
(define (conf-get-multi config key)
|
(define (conf-get-multi config key)
|
||||||
(if (not config)
|
(if (not config)
|
||||||
'()
|
'()
|
||||||
(append (conf-get-list (conf-head config) key)
|
(append (conf-get-list (conf-head config))
|
||||||
(conf-get-multi (conf-parent config) key))))
|
(conf-get-multi (conf-parent config) key))))
|
||||||
|
|
||||||
;;> Extends the config with anadditional alist.
|
;;> Extends the config with anadditional alist.
|
||||||
|
@ -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,39 +0,0 @@
|
||||||
(c-include-verbatim "sha2.c")
|
|
||||||
|
|
||||||
;; \procedure{(start-sha type)}
|
|
||||||
;;
|
|
||||||
;; Allocates a new opaque computation context for a SHA-\var{type}
|
|
||||||
;; digest, where \var{type} can be one of the following constants:
|
|
||||||
;; \scheme{type-sha-224}, \scheme{type-sha-256}.
|
|
||||||
|
|
||||||
(define-c-struct sha_context)
|
|
||||||
|
|
||||||
(define-c sexp (start-sha "sexp_start_sha")
|
|
||||||
((value ctx sexp) (value self sexp) unsigned-int (value NULL sha_context)))
|
|
||||||
|
|
||||||
(define-c-const unsigned-int (type-sha-224 "SHA_TYPE_224"))
|
|
||||||
(define-c-const unsigned-int (type-sha-256 "SHA_TYPE_256"))
|
|
||||||
|
|
||||||
;; \procedure{(add-sha-data! sha-context data)}
|
|
||||||
;;
|
|
||||||
;; Adds a new piece of data into the given context. \var{data} can be
|
|
||||||
;; a bytevector or a string. Bytevectors are added as sequences bytes.
|
|
||||||
;; Strings are added as sequences of byte representations of their
|
|
||||||
;; chars (which is either UTF-8 or ASCII code point sequence, depending
|
|
||||||
;; on whether Chibi was compiled with Unicode support).
|
|
||||||
;;
|
|
||||||
;; It is an error to add more data into a context that was finalized
|
|
||||||
;; by \scheme{get-sha}. This procedure returns an unspecified value.
|
|
||||||
|
|
||||||
(define-c sexp (add-sha-data! "sexp_add_sha_data")
|
|
||||||
((value ctx sexp) (value self sexp) sha_context sexp))
|
|
||||||
|
|
||||||
;; \procedure{(get-sha sha-context)}
|
|
||||||
;;
|
|
||||||
;; Finalizes computation and returns resulting SHA-2 digest as a hex
|
|
||||||
;; string (in lowercase). It is not possible to add more data with
|
|
||||||
;; \scheme{add-sha-data!} after this call. Though, digest string can
|
|
||||||
;; be retrieved multiple times from the same computation context.
|
|
||||||
|
|
||||||
(define-c sexp (get-sha "sexp_get_sha")
|
|
||||||
((value ctx sexp) (value self sexp) sha_context))
|
|
|
@ -1,13 +0,0 @@
|
||||||
(define-library (chibi crypto md5-test)
|
|
||||||
(export run-tests)
|
|
||||||
(import (scheme base) (chibi crypto md5) (chibi test))
|
|
||||||
(begin
|
|
||||||
(define (run-tests)
|
|
||||||
(test-begin "md5")
|
|
||||||
(test "d41d8cd98f00b204e9800998ecf8427e"
|
|
||||||
(md5 ""))
|
|
||||||
(test "900150983cd24fb0d6963f7d28e17f72"
|
|
||||||
(md5 "abc"))
|
|
||||||
(test "9e107d9d372bb6826bd81d3542a419d6"
|
|
||||||
(md5 "The quick brown fox jumps over the lazy dog"))
|
|
||||||
(test-end))))
|
|
|
@ -130,10 +130,6 @@
|
||||||
#xffef #xf47d #x8584 #x5dd1 #x6fa8 #x7e4f #xfe2c #xe6e0 #xa301 #x4314
|
#xffef #xf47d #x8584 #x5dd1 #x6fa8 #x7e4f #xfe2c #xe6e0 #xa301 #x4314
|
||||||
#x4e08 #x11a1 #xf753 #x7e82 #xbd3a #xf235 #x2ad7 #xd2bb #xeb86 #xd391))
|
#x4e08 #x11a1 #xf753 #x7e82 #xbd3a #xf235 #x2ad7 #xd2bb #xeb86 #xd391))
|
||||||
|
|
||||||
;;> Returns the md5 checksum of \var{src} as a lowercase hex-string.
|
|
||||||
;;> \var{src} can be any of a string (interpreted as utf8), a
|
|
||||||
;;> bytevector, or a binary input port.
|
|
||||||
|
|
||||||
(define (md5 src)
|
(define (md5 src)
|
||||||
(let ((in (cond ((string? src) (open-input-bytevector (string->utf8 src)))
|
(let ((in (cond ((string? src) (open-input-bytevector (string->utf8 src)))
|
||||||
((bytevector? src) (open-input-bytevector src))
|
((bytevector? src) (open-input-bytevector src))
|
||||||
|
|
|
@ -1,12 +1,5 @@
|
||||||
|
|
||||||
;;> Implementation of the MD5 (Message Digest) cryptographic hash. In
|
|
||||||
;;> new applications SHA-2 should be preferred.
|
|
||||||
|
|
||||||
(define-library (chibi crypto md5)
|
(define-library (chibi crypto md5)
|
||||||
(import (scheme base) (chibi bytevector))
|
(import (scheme base) (srfi 33) (chibi bytevector))
|
||||||
(cond-expand
|
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
|
||||||
(else (import (srfi 60))))
|
|
||||||
(export md5)
|
(export md5)
|
||||||
(include "md5.scm"))
|
(include "md5.scm"))
|
||||||
|
|
|
@ -1,81 +0,0 @@
|
||||||
(define-library (chibi crypto rsa-test)
|
|
||||||
(export run-tests)
|
|
||||||
(import (scheme base)
|
|
||||||
(chibi crypto rsa)
|
|
||||||
(chibi crypto sha2)
|
|
||||||
(chibi test))
|
|
||||||
(begin
|
|
||||||
(define (run-tests)
|
|
||||||
|
|
||||||
(define (test-key key)
|
|
||||||
(test #t (rsa-key? key))
|
|
||||||
(test #t (positive? (rsa-key-n key)))
|
|
||||||
(test #t (positive? (rsa-key-e key)))
|
|
||||||
(test #t (positive? (rsa-key-d key)))
|
|
||||||
(test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
|
|
||||||
|
|
||||||
(test-begin "rsa")
|
|
||||||
|
|
||||||
;; Verify an explicit key.
|
|
||||||
|
|
||||||
;; p = 61, q = 53
|
|
||||||
(let* ((priv-key (rsa-key-gen-from-primes 8 61 53))
|
|
||||||
(pub-key (rsa-pub-key priv-key)))
|
|
||||||
(test 439 (rsa-sign priv-key 42))
|
|
||||||
(test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
|
|
||||||
(let ((msg 42))
|
|
||||||
(test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg)))))
|
|
||||||
|
|
||||||
(let* ((priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
|
|
||||||
(pub-key2 (rsa-pub-key priv-key2)))
|
|
||||||
(let ((msg 42))
|
|
||||||
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
|
|
||||||
|
|
||||||
(let ((msg #u8(42)))
|
|
||||||
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
|
|
||||||
|
|
||||||
(let ((msg "*"))
|
|
||||||
(test msg (utf8->string (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg)))))
|
|
||||||
|
|
||||||
(let ((msg "*"))
|
|
||||||
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
|
|
||||||
|
|
||||||
(let ((msg #u8(42)))
|
|
||||||
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg)))))
|
|
||||||
|
|
||||||
;; Key generation.
|
|
||||||
|
|
||||||
(test-key (rsa-key-gen 8))
|
|
||||||
(test-key (rsa-key-gen 16))
|
|
||||||
(test-key (rsa-key-gen 32))
|
|
||||||
(test-key (rsa-key-gen-from-primes 32 2936546443 3213384203))
|
|
||||||
|
|
||||||
;; These are expensive to test. Times with -h1G:
|
|
||||||
;; (test-key (rsa-key-gen 128)) ; 0.04s
|
|
||||||
;; (test-key (rsa-key-gen 256)) ; 0.4s
|
|
||||||
;; (test-key (rsa-key-gen 512)) ; 4s
|
|
||||||
;; (test-key (rsa-key-gen 1024)) ; 92s
|
|
||||||
|
|
||||||
;; padding
|
|
||||||
|
|
||||||
(test #u8(8 8 8 8 8 8 8 8) (pkcs1-pad #u8()))
|
|
||||||
(test #u8(1 7 7 7 7 7 7 7) (pkcs1-pad #u8(1)))
|
|
||||||
(test #u8(1 2 6 6 6 6 6 6) (pkcs1-pad #u8(1 2)))
|
|
||||||
(test #u8(1 2 3 5 5 5 5 5) (pkcs1-pad #u8(1 2 3)))
|
|
||||||
(test #u8(1 2 3 4 4 4 4 4) (pkcs1-pad #u8(1 2 3 4)))
|
|
||||||
(test #u8(1 2 3 4 5 3 3 3) (pkcs1-pad #u8(1 2 3 4 5)))
|
|
||||||
(test #u8(1 2 3 4 5 6 2 2) (pkcs1-pad #u8(1 2 3 4 5 6)))
|
|
||||||
(test #u8(1 2 3 4 5 6 7 1) (pkcs1-pad #u8(1 2 3 4 5 6 7)))
|
|
||||||
(test #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8) (pkcs1-pad #u8(1 2 3 4 5 6 7 8)))
|
|
||||||
|
|
||||||
(test #u8() (pkcs1-unpad #u8(8 8 8 8 8 8 8 8)))
|
|
||||||
(test #u8(1) (pkcs1-unpad #u8(1 7 7 7 7 7 7 7)))
|
|
||||||
(test #u8(1 2) (pkcs1-unpad #u8(1 2 6 6 6 6 6 6)))
|
|
||||||
(test #u8(1 2 3) (pkcs1-unpad #u8(1 2 3 5 5 5 5 5)))
|
|
||||||
(test #u8(1 2 3 4) (pkcs1-unpad #u8(1 2 3 4 4 4 4 4)))
|
|
||||||
(test #u8(1 2 3 4 5) (pkcs1-unpad #u8(1 2 3 4 5 3 3 3)))
|
|
||||||
(test #u8(1 2 3 4 5 6) (pkcs1-unpad #u8(1 2 3 4 5 6 2 2)))
|
|
||||||
(test #u8(1 2 3 4 5 6 7) (pkcs1-unpad #u8(1 2 3 4 5 6 7 1)))
|
|
||||||
(test #u8(1 2 3 4 5 6 7 8) (pkcs1-unpad #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8)))
|
|
||||||
|
|
||||||
(test-end))))
|
|
|
@ -1,13 +1,7 @@
|
||||||
|
|
||||||
;;> RSA public key cryptography implementation.
|
|
||||||
|
|
||||||
(define-library (chibi crypto rsa)
|
(define-library (chibi crypto rsa)
|
||||||
(import (scheme base) (srfi 27)
|
(import (scheme base) (srfi 27) (srfi 33)
|
||||||
(chibi bytevector) (chibi math prime))
|
(chibi bytevector) (chibi math prime))
|
||||||
(cond-expand
|
|
||||||
((library (srfi 151)) (import (srfi 151)))
|
|
||||||
((library (srfi 33)) (import (srfi 33)))
|
|
||||||
(else (import (srfi 60))))
|
|
||||||
(export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key
|
(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,24 +0,0 @@
|
||||||
;; sha2-native.scm -- SHA-2 digest algorithms native interface
|
|
||||||
;; Copyright (c) 2015 Alexei Lozovsky. All rights reserved.
|
|
||||||
;; BSD-style license: http://synthcode.com/license.txt
|
|
||||||
|
|
||||||
(define (process-sha-data! context src)
|
|
||||||
(cond ((or (bytevector? src) (string? src))
|
|
||||||
(add-sha-data! context src))
|
|
||||||
((input-port? src)
|
|
||||||
(let lp ((chunk (read-bytevector 1024 src)))
|
|
||||||
(unless (eof-object? chunk)
|
|
||||||
(add-sha-data! context chunk)
|
|
||||||
(lp (read-bytevector 1024 src)))))
|
|
||||||
(else
|
|
||||||
(error "unknown digest source: " src))))
|
|
||||||
|
|
||||||
(define (sha-224 src)
|
|
||||||
(let ((context (start-sha type-sha-224)))
|
|
||||||
(process-sha-data! context src)
|
|
||||||
(get-sha context)))
|
|
||||||
|
|
||||||
(define (sha-256 src)
|
|
||||||
(let ((context (start-sha type-sha-256)))
|
|
||||||
(process-sha-data! context src)
|
|
||||||
(get-sha context)))
|
|
|
@ -1,83 +0,0 @@
|
||||||
(define-library (chibi crypto sha2-test)
|
|
||||||
(export run-tests)
|
|
||||||
(import (scheme base) (chibi crypto sha2) (chibi test))
|
|
||||||
(begin
|
|
||||||
(define (run-tests)
|
|
||||||
(test-begin "sha2")
|
|
||||||
(test "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
|
|
||||||
(sha-224 ""))
|
|
||||||
(test "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7"
|
|
||||||
(sha-224 "abc"))
|
|
||||||
(test "730e109bd7a8a32b1cb9d9a09aa2325d2430587ddbc0c38bad911525"
|
|
||||||
(sha-224 "The quick brown fox jumps over the lazy dog"))
|
|
||||||
(test "7c9da3bf97ccdeee630639aacdce35d3c136e514332a28e67097a4a4"
|
|
||||||
(sha-224 "Boundary test for 448 bits (-1) - 012345678901234567890"))
|
|
||||||
(test "35aebce593c857a2c817428340ff465922ffe43ed076d24553db1a24"
|
|
||||||
(sha-224 "Boundary test for 448 bits (0) - 0123456789012345678901"))
|
|
||||||
(test "3f8dbeb9c33981d7007e20641d506d048e89e98a9546ecccc3224d3b"
|
|
||||||
(sha-224 "Boundary test for 448 bits (+1) - 01234567890123456789012"))
|
|
||||||
(test "8b311209d5880800911d3e72ffe7e75ec33a6e83932d5cdd00c96327"
|
|
||||||
(sha-224 "Boundary test for 512 bits (-1) - 01234567890123456789012345678"))
|
|
||||||
(test "9b68fdc122e1cb38575ba97f54699d71eaf0e58ee88f9e653b31d6ce"
|
|
||||||
(sha-224 "Boundary test for 512 bits (0) - 012345678901234567890123456789"))
|
|
||||||
(test "52b28e31226ee5e6ada43e33194e11d8015abf8b5511c1631ad11aea"
|
|
||||||
(sha-224 "Boundary test for 512 bits (+1) - 0123456789012345678901234567890"))
|
|
||||||
(test "aa85fe2924d9c259f92e154fa88d0c845654fe69aa7dc1e3f7e4c789"
|
|
||||||
(sha-224 "Boundary test for 960 bits (-1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234"))
|
|
||||||
(test "dd8af6abfe24e78065afd1ae06220e8d46401db13f202109770ca2d2"
|
|
||||||
(sha-224 "Boundary test for 960 bits (0) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345"))
|
|
||||||
(test "5299a41ce9c6e8b405f42b193922fb4af3da16a1519610057baca20f"
|
|
||||||
(sha-224 "Boundary test for 960 bits (+1) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456"))
|
|
||||||
(test "cb88e45dc662233ef4e7171e9e1c4903bd6502dd25923105778ea82e"
|
|
||||||
(sha-224 "Boundary test for 1024 bits (-1) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901"))
|
|
||||||
(test "f41c907a7fd2fa3aec70815669fe467760f4fd15763a75192d2c9f45"
|
|
||||||
(sha-224 "Boundary test for 1024 bits (0) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012"))
|
|
||||||
(test "cc1501345f86b1ef60eaf3637f7a37c38c63252b5674d343a3cc4aea"
|
|
||||||
(sha-224 "Boundary test for 1024 bits (+1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123"))
|
|
||||||
(test "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
|
|
||||||
(sha-224 #u8()))
|
|
||||||
(test "ae40be26ae2072dd84f37c13a5f6af48e3c33ea1c08a5ef4a54b22e3"
|
|
||||||
(sha-224 #u8(1 2 3 4 5 6 7 8 9)))
|
|
||||||
(test "54e5eb52479c241cc4759318619f548994ae46979124cb9b1435db14"
|
|
||||||
(sha-224 (open-input-bytevector #u8(1 2 3 9))))
|
|
||||||
(test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
|
|
||||||
(sha-256 ""))
|
|
||||||
(test "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
|
|
||||||
(sha-256 "abc"))
|
|
||||||
(test "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592"
|
|
||||||
(sha-256 "The quick brown fox jumps over the lazy dog"))
|
|
||||||
(test "61f8fe4c4cdc8b3e10673933fcd0c5b1f6b46d3392550e42b265daefc7bc0d31"
|
|
||||||
(sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklm"))
|
|
||||||
(test "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
|
|
||||||
(sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"))
|
|
||||||
(test "f904e41d6488bc982a929e1f9307d9b47f12e6cc01ab42d109b083a780dbb70a"
|
|
||||||
(sha-256 "Boundary test for 448 bits (-1) - 012345678901234567890"))
|
|
||||||
(test "4621c7c067a12951ed5b0339a6c6811aec2dea4adcb2dcbb1383868765dbbc21"
|
|
||||||
(sha-256 "Boundary test for 448 bits (0) - 0123456789012345678901"))
|
|
||||||
(test "a62bd24e12494c5a213dc366fec9d79e2bd77789febf6b1437191f264ad0a7fe"
|
|
||||||
(sha-256 "Boundary test for 448 bits (+1) - 01234567890123456789012"))
|
|
||||||
(test "2c47adeb018cd5634aa3c121bf0e6d122789448568814e7243b19b6c26ac4860"
|
|
||||||
(sha-256 "Boundary test for 512 bits (-1) - 01234567890123456789012345678"))
|
|
||||||
(test "eb1018cf7e5f40ba45a711c4154584234e2194f10cc6fa7559a438bed9e4a388"
|
|
||||||
(sha-256 "Boundary test for 512 bits (0) - 012345678901234567890123456789"))
|
|
||||||
(test "714f030e4971ade8976564693a8fe202ca357e87cb1cb7391a9af3c45590f7c0"
|
|
||||||
(sha-256 "Boundary test for 512 bits (+1) - 0123456789012345678901234567890"))
|
|
||||||
(test "a745d68a9999da92558757735428346439e2af5668b188e9e4da7935e318335b"
|
|
||||||
(sha-256 "Boundary test for 960 bits (-1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234"))
|
|
||||||
(test "f2d7ad79e0360fbad145dd551db33548dc7cd253e6c56c975f2820e4c99dee51"
|
|
||||||
(sha-256 "Boundary test for 960 bits (0) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345"))
|
|
||||||
(test "9f0378e0ba55965bd17232f994710b786e9d72a88a806c0b10cd9d36a06e41ed"
|
|
||||||
(sha-256 "Boundary test for 960 bits (+1) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456"))
|
|
||||||
(test "483a36ca7824cc0d9bff2d63901301ba8ca7deb675628c71d8a08d52a0396cfe"
|
|
||||||
(sha-256 "Boundary test for 1024 bits (-1) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901"))
|
|
||||||
(test "8bd16f15e5f1b753650753497d09e1956137fba0cb2162a61dc6a2b49c7fcda3"
|
|
||||||
(sha-256 "Boundary test for 1024 bits (0) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012"))
|
|
||||||
(test "c6c960e1c106d214e82d58c12c44adb000903d2022ea2ce239f273294d3055e5"
|
|
||||||
(sha-256 "Boundary test for 1024 bits (+1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123"))
|
|
||||||
(test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
|
|
||||||
(sha-256 #u8()))
|
|
||||||
(test "47e4ee7f211f73265dd17658f6e21c1318bd6c81f37598e20a2756299542efcf"
|
|
||||||
(sha-256 #u8(1 2 3 4 5 6 7 8 9)))
|
|
||||||
(test "a745f3ca4f474d583c050eaf476ce76439d171ebe2b49d4af8b44f13ba71fb56"
|
|
||||||
(sha-256 (open-input-bytevector #u8(1 2 3 9))))
|
|
||||||
(test-end))))
|
|
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Reference in a new issue