conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into bench

This commit is contained in:
Sunrim KIM (keen) 2015-06-10 22:37:13 +09:00
parent 84e234dda4 7973794f75
commit 86084498f0
133 changed files with 5173 additions and 5381 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored
View File

@ -1,6 +1,9 @@
build/*
*.o
bin/
lib/
src/load_piclib.c
src/init_contrib.c
docs/contrib.rst
.dir-locals.el
GPATH
GRTAGS

12
.travis.yml
View File

@ -2,9 +2,15 @@ language: c
compiler:
- gcc
- clang
env:
- CFLAGS="-m32"
- CFLAGS="-m64"
before_script:
- cd build
- sudo apt-get update -qq
- sudo apt-get install -y libc6:i386 libgcc1:i386 gcc-4.6-base:i386 gcc-multilib
script:
- perl --version
- cmake .. && make test
- cmake -DCMAKE_BUILD_TYPE=Debug .. && make test > /dev/null
- make test
- make clean
- make debug
- make test 2> /dev/null >/dev/null

50
CMakeLists.txt
View File

@ -1,50 +0,0 @@
cmake_minimum_required(VERSION 2.6)
cmake_policy(VERSION 2.6)
if(POLICY CMP0037)
cmake_policy(SET CMP0037 OLD)
endif()
PROJECT(picrin)
# load extra cmake modules
set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/cmake/")
set(CMAKE_RUNTIME_OUTPUT_DIRECTORY bin)
set(CMAKE_LIBRARY_OUTPUT_DIRECTORY lib)
set(CMAKE_C_FLAGS "-O2 -Wall -Wextra")
set(CMAKE_C_FLAGS_DEBUG "-g -DDEBUG=1")
option(USE_C11_FEATURE "Enable c11 feature" OFF)
if(USE_C11_FEATURE)
add_definitions(-std=c11)
else()
add_definitions(-std=c99) # at least c99 is required
endif()
include_directories(extlib/benz/include)
# build picrin
include(piclib/CMakeLists.txt)
include(contrib/CMakeLists.txt)
include(src/CMakeLists.txt)
include(docs/CMakeLists.txt)
# ----
# $ make run
add_custom_target(run bin/picrin DEPENDS repl)
# $ make test
add_custom_target(test DEPENDS test-r7rs test-contribs)
# $ make test-r7rs
add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl)
# $ make test-contribs
add_custom_target(test-contribs DEPENDS ${CONTRIB_TESTS})
# $ make tak
add_custom_target(tak bin/picrin ${PROJECT_SOURCE_DIR}/etc/tak.scm DEPENDS repl)
# $ make lines
add_custom_target(lines find . -name "*.[chyl]" | xargs wc -l WORKING_DIRECTORY ${PROJECT_SOURCE_DIR})

88
Makefile Normal file
View File

@ -0,0 +1,88 @@
BENZ_SRCS = $(wildcard extlib/benz/*.c)
BENZ_OBJS = $(BENZ_SRCS:.c=.o)
PICRIN_SRCS = \
src/main.c\
src/load_piclib.c\
src/init_contrib.c
PICRIN_OBJS = \
$(PICRIN_SRCS:.c=.o)
PICRIN_LIBS = \
piclib/picrin/base.scm\
piclib/picrin/macro.scm\
piclib/picrin/record.scm\
piclib/picrin/array.scm\
piclib/picrin/experimental/lambda.scm\
piclib/picrin/syntax-rules.scm\
piclib/picrin/test.scm
CONTRIB_SRCS =
CONTRIB_OBJS = $(CONTRIB_SRCS:.c=.o)
CONTRIB_LIBS =
CONTRIB_INITS =
CONTRIB_TESTS =
CONTRIB_DOCS = $(wildcard contrib/*/docs/*.rst)
CFLAGS += -I./extlib/benz/include -Wall -Wextra
LDFLAGS += -lm
prefix = /usr/local
all: CFLAGS += -O2
all: bin/picrin
include $(sort $(wildcard contrib/*/nitro.mk))
debug: CFLAGS += -O0 -g -DDEBUG=1
debug: bin/picrin
bin/picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a
$(CC) $(CFLAGS) -o $@ $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a $(LDFLAGS)
src/load_piclib.c: $(PICRIN_LIBS) $(CONTRIB_LIBS)
perl etc/mkloader.pl $(PICRIN_LIBS) $(CONTRIB_LIBS) > $@
src/init_contrib.c:
perl etc/mkinit.pl $(CONTRIB_INITS) > $@
lib/libbenz.a: $(BENZ_OBJS)
$(AR) $(ARFLAGS) $@ $(BENZ_OBJS)
$(BENZ_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): extlib/benz/include/picrin.h extlib/benz/include/picrin/*.h
doc: docs/*.rst docs/contrib.rst
$(MAKE) -C docs html
mkdir -p doc
cp -uR docs/_build/* -t doc/
docs/contrib.rst: $(CONTRIB_DOCS)
echo "Contrib Libraries \\\(a.k.a nitros\\\)" > $@
echo "================================" >> $@
echo "" >> $@
cat $(CONTRIB_DOCS) >> $@
run: bin/picrin
bin/picrin
test: test-r7rs test-contribs test-nostdlib
test-r7rs: bin/picrin t/r7rs-tests.scm
bin/picrin t/r7rs-tests.scm
test-contribs: bin/picrin $(CONTRIB_TESTS)
test-nostdlib:
$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0'-nostdlib -fPIC -shared -std=c89 -ansi -pedantic -Wall -Wextra -o lib/libbenz.so $(BENZ_SRCS)
rm -f lib/libbenz.so
install: all
install -c bin/picrin $(prefix)/bin/picrin
clean:
rm -f src/load_piclib.c src/init_contrib.c
rm -f lib/libbenz.a
rm -f $(BENZ_OBJS)
rm -f $(PICRIN_OBJS)
rm -f $(CONTRIB_OBJS)
.PHONY: all insall clean run test test-r7rs test-contribs doc $(CONTRIB_TESTS)

74
README.md
View File

@ -1,9 +1,20 @@
<img width="500" src="https://raw.githubusercontent.com/picrin-scheme/picrin/master/etc/picrin-logo-fin01-02.png"></img>
[![Build Status](https://travis-ci.org/picrin-scheme/picrin.png)](https://travis-ci.org/picrin-scheme/picrin)
[![Build Status](https://travis-ci.org/picrin-scheme/picrin.png?branch=master)](https://travis-ci.org/picrin-scheme/picrin)
[![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/)
Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not require any special external libraries installed on the platform.
Picrin is a lightweight R7RS scheme implementation written in pure C89. It contains a reasonably fast VM, an improved hygienic macro system, usuful contribution libraries, and simple but powerful C interface.
- R7RS compatible
- Reentrant design (all VM states are stored in single global state object)
- Bytecode interpreter
- Direct threaded VM
- Internal representation by nan-boxing (available only on x64)
- Conservative call/cc implementation (VM stack and native c stack can interleave)
- Exact GC (simple mark and sweep, partially reference count)
- String representation by rope
- Hygienic macro transformers (syntactic closures, explicit and implicit renaming macros)
- Extended library syntax
## Documentation
@ -17,71 +28,36 @@ https://github.com/picrin-scheme/picrin
## IRC
There is a chat room on chat.freenode.org, channel #picrin. IRC logs here: https://botbot.me/freenode/picrin/
Our chat room is at #picrin channel, chat.freenode.org. IRC logs here: https://botbot.me/freenode/picrin/
## How to use it
## Build
To build picrin, you need some build tools installed on your platform.
- cmake (>= 2.6)
### Generate Makefile
Change directory to `build` then run `cmake` to create Makefile. Once `Makefile` is generated you can run `make` command to build picrin.
$ cd build
$ cmake ..
Actually you don't necessarily need to move to `build` directory before running `cmake` (in that case `$ cmake .`), but I strongly recommend to follow above instruction.
Before generating Makefile, you can change some compilation switches to enable or disable optional features. Take *NAN_BOXING* for example, when you turn on "Use C11 feature" flag and the platform supports addresses of 48bit length, it is enabled.
### Build
A built executable binary will be under bin/ directory and shared libraries under lib/.
Just type `make` in the project root directory. You will find an executable binary newly created at bin/ directory.
$ make
If you are building picrin on other systems than x86_64, PIC_NAN_BOXING flag is automatically turned on (see include/picrin/config.h for detail).
When you are building picrin on x86_64 system, PIC_NAN_BOXING flag is automatically turned on (see include/picrin/config.h for detail).
### Install
## Install
Just running `make install`, picrin library, headers, and runtime binary are install on your system, by default into `/usr/local` directory. You can change this value via cmake.
`make install` target is provided. By default it installs picrin binary into `/usr/local/bin/`.
$ make install
### Run
Since picrin does not use autoconf, if you want to specify the install directory, pass the custom path to `make` via command line argument.
Before installing picrin, you can try picrin without breaking any of your system. Simply directly run the binary `bin/picrin` from terminal, or you can use `make` to execute it like this.
$ make run
### Run Test
To run all the test including contribs, execute this.
$ make test
To test only R7RS features,
$ make test-r7rs
### Debug run
If you execute `cmake` with debug flag `-DCMAKE_BUILD_TYPE=Debug`, it builds the binary with all debug flags enabled (PIC_GC_STRESS, VM_DEBUG, DEBUG).
$ cmake -DCMAKE_BUILD_TYPE=Debug ..
$ make install prefix=/path/to/dir
## Requirement
Picrin scheme depends on some external libraries to build the binary:
To build Picrin Scheme from source code, some external libraries are required:
- perl
- regex.h of POSIX.1
- libedit (optional)
- regex.h of POSIX.1 (optional)
Optional libraries are, if cmake detected them, automatically enabled.
The compilation is tested only on Mac OSX and Ubuntu. I think (or hope) it'll be ok to compile and run on other operating systems such as Arch or Windows, but I don't guarantee :(
Make command automatically turns on optional libraries if available.
Picrin is mainly developed on Mac OS X and only tested on OS X or Ubuntu 14.04+. When you tried to run picrin on other platforms and found something was wrong with it, please send us an issue.
## Authors

0
build/.gitkeep → bin/.gitkeep
View File

193
cmake/FindPYTHON.cmake
View File

@ -1,193 +0,0 @@
##############################################################################
# @file FindPythonInterp.cmake
# @brief Find Python interpreter.
#
# @par Input variables:
# <table border="0">
# <tr>
# @tp @b Python_ADDITIONAL_VERSIONS @endtp
# <td>List of version numbers that should be taken into account when
# searching for Python.</td>
# </tr>
# </table>
#
# @par Output variables:
# <table border="0">
# <tr>
# @tp @b PYTHONINTERP_FOUND @endtp
# <td>Was the Python executable found.</td>
# </tr>
# <tr>
# @tp @b PYTHON_EXECUTABLE @endtp
# <td>Path to the Python interpreter.</td>
# </tr>
# <tr>
# @tp @b PYTHON_VERSION_STRING @endtp
# <td>Python version found e.g. 2.5.2.</td>
# </tr>
# <tr>
# @tp @b PYTHON_VERSION_MAJOR @endtp
# <td>Python major version found e.g. 2.</td>
# </tr>
# <tr>
# @tp @b PYTHON_VERSION_MINOR @endtp
# <td>Python minor version found e.g. 5.</td>
# </tr>
# <tr>
# @tp @b PYTHON_VERSION_PATCH @endtp
# <td>Python patch version found e.g. 2.</td>
# </tr>
# </table>
#
# @note This module has been copied from the Git repository of CMake on
# 4/12/2012, i.e., before the release of CMake 2.8.8. Once CMake 2.8.8
# or any version is available for all major platforms, consider to
# remove this module from the BASIS package.
#
# @ingroup CMakeFindModules
##############################################################################
#=============================================================================
# Copyright 2005-2010 Kitware, Inc.
# Copyright 2011 Bjoern Ricks <bjoern.ricks@gmail.com>
# Copyright 2012 Rolf Eike Beer <eike@sf-mail.de>
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# * Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
#
# * Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# * Neither the names of Kitware, Inc., the Insight Software Consortium,
# nor the names of their contributors may be used to endorse or promote
# products derived from this software without specific prior written
# permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#=============================================================================
unset(_Python_NAMES)
set(_PYTHON1_VERSIONS 1.6 1.5)
set(_PYTHON2_VERSIONS 2.7 2.6 2.5 2.4 2.3 2.2 2.1 2.0)
set(_PYTHON3_VERSIONS 3.3 3.2 3.1 3.0)
if(PythonInterp_FIND_VERSION)
if(PythonInterp_FIND_VERSION MATCHES "^[0-9]+\\.[0-9]+(\\.[0-9]+.*)?$")
string(REGEX REPLACE "^([0-9]+\\.[0-9]+).*" "\\1" _PYTHON_FIND_MAJ_MIN "${PythonInterp_FIND_VERSION}")
string(REGEX REPLACE "^([0-9]+).*" "\\1" _PYTHON_FIND_MAJ "${_PYTHON_FIND_MAJ_MIN}")
list(APPEND _Python_NAMES python${_PYTHON_FIND_MAJ_MIN} python${_PYTHON_FIND_MAJ})
unset(_PYTHON_FIND_OTHER_VERSIONS)
if(NOT PythonInterp_FIND_VERSION_EXACT)
foreach(_PYTHON_V ${_PYTHON${_PYTHON_FIND_MAJ}_VERSIONS})
if(NOT _PYTHON_V VERSION_LESS _PYTHON_FIND_MAJ_MIN)
list(APPEND _PYTHON_FIND_OTHER_VERSIONS ${_PYTHON_V})
endif()
endforeach()
endif(NOT PythonInterp_FIND_VERSION_EXACT)
unset(_PYTHON_FIND_MAJ_MIN)
unset(_PYTHON_FIND_MAJ)
else(PythonInterp_FIND_VERSION MATCHES "^[0-9]+\\.[0-9]+(\\.[0-9]+.*)?$")
list(APPEND _Python_NAMES python${PythonInterp_FIND_VERSION})
set(_PYTHON_FIND_OTHER_VERSIONS ${_PYTHON${PythonInterp_FIND_VERSION}_VERSIONS})
endif(PythonInterp_FIND_VERSION MATCHES "^[0-9]+\\.[0-9]+(\\.[0-9]+.*)?$")
else(PythonInterp_FIND_VERSION)
set(_PYTHON_FIND_OTHER_VERSIONS ${_PYTHON3_VERSIONS} ${_PYTHON2_VERSIONS} ${_PYTHON1_VERSIONS})
endif(PythonInterp_FIND_VERSION)
list(APPEND _Python_NAMES python)
# Search for the current active python version first
find_program(PYTHON_EXECUTABLE NAMES ${_Python_NAMES})
# Set up the versions we know about, in the order we will search. Always add
# the user supplied additional versions to the front.
set(_Python_VERSIONS
${Python_ADDITIONAL_VERSIONS}
${_PYTHON_FIND_OTHER_VERSIONS}
)
unset(_PYTHON_FIND_OTHER_VERSIONS)
unset(_PYTHON1_VERSIONS)
unset(_PYTHON2_VERSIONS)
unset(_PYTHON3_VERSIONS)
# Search for newest python version if python executable isn't found
if(NOT PYTHON_EXECUTABLE)
foreach(_CURRENT_VERSION ${_Python_VERSIONS})
set(_Python_NAMES python${_CURRENT_VERSION})
if(WIN32)
list(APPEND _Python_NAMES python)
endif()
find_program(PYTHON_EXECUTABLE
NAMES ${_Python_NAMES}
PATHS [HKEY_LOCAL_MACHINE\\SOFTWARE\\Python\\PythonCore\\${_CURRENT_VERSION}\\InstallPath]
)
endforeach()
endif()
# determine python version string
if(PYTHON_EXECUTABLE)
execute_process(COMMAND "${PYTHON_EXECUTABLE}" -E -c
"import sys; sys.stdout.write(';'.join([str(x) for x in sys.version_info[:3]]))"
OUTPUT_VARIABLE _VERSION
RESULT_VARIABLE _PYTHON_VERSION_RESULT
ERROR_QUIET)
if(NOT _PYTHON_VERSION_RESULT)
string(REPLACE ";" "." PYTHON_VERSION_STRING "${_VERSION}")
list(GET _VERSION 0 PYTHON_VERSION_MAJOR)
list(GET _VERSION 1 PYTHON_VERSION_MINOR)
list(GET _VERSION 2 PYTHON_VERSION_PATCH)
if(PYTHON_VERSION_PATCH EQUAL 0)
# it's called "Python 2.7", not "2.7.0"
string(REGEX REPLACE "\\.0$" "" PYTHON_VERSION_STRING "${PYTHON_VERSION_STRING}")
endif()
else()
# sys.version predates sys.version_info, so use that
execute_process(COMMAND "${PYTHON_EXECUTABLE}" -E -c "import sys; sys.stdout.write(sys.version)"
OUTPUT_VARIABLE _VERSION
RESULT_VARIABLE _PYTHON_VERSION_RESULT
ERROR_QUIET)
if(NOT _PYTHON_VERSION_RESULT)
string(REGEX REPLACE " .*" "" PYTHON_VERSION_STRING "${_VERSION}")
string(REGEX REPLACE "^([0-9]+)\\.[0-9]+.*" "\\1" PYTHON_VERSION_MAJOR "${PYTHON_VERSION_STRING}")
string(REGEX REPLACE "^[0-9]+\\.([0-9])+.*" "\\1" PYTHON_VERSION_MINOR "${PYTHON_VERSION_STRING}")
if(PYTHON_VERSION_STRING MATCHES "^[0-9]+\\.[0-9]+\\.[0-9]+.*")
string(REGEX REPLACE "^[0-9]+\\.[0-9]+\\.([0-9]+).*" "\\1" PYTHON_VERSION_PATCH "${PYTHON_VERSION_STRING}")
else()
set(PYTHON_VERSION_PATCH "0")
endif()
else()
# sys.version was first documented for Python 1.5, so assume
# this is older.
set(PYTHON_VERSION_STRING "1.4")
set(PYTHON_VERSION_MAJOR "1")
set(PYTHON_VERSION_MINOR "4")
set(PYTHON_VERSION_PATCH "0")
endif()
endif()
unset(_PYTHON_VERSION_RESULT)
unset(_VERSION)
endif(PYTHON_EXECUTABLE)
# handle the QUIETLY and REQUIRED arguments and set PYTHONINTERP_FOUND to TRUE if
# all listed variables are TRUE
include(FindPackageHandleStandardArgs)
FIND_PACKAGE_HANDLE_STANDARD_ARGS(PythonInterp REQUIRED_VARS PYTHON_EXECUTABLE VERSION_VAR PYTHON_VERSION_STRING)
mark_as_advanced(PYTHON_EXECUTABLE)

4
contrib/03.callcc/CMakeLists.txt
View File

@ -1,4 +0,0 @@
file(GLOB PICRIN_CALLCC_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.callcc/*.c)
list(APPEND PICRIN_CONTRIB_INITS callcc)
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_CALLCC_SOURCES})

105
contrib/03.callcc/callcc.c
View File

@ -1,13 +1,11 @@
#include "picrin.h"
#include "picrin/data.h"
#include "picrin/proc.h"
#include "picrin/pair.h"
#include "picrin/cont.h"
struct pic_cont {
struct pic_fullcont {
jmp_buf jmp;
struct pic_winder *wind;
pic_jmpbuf *prev_jmp;
pic_checkpoint *cp;
char *stk_pos, *stk_ptr;
ptrdiff_t stk_len;
@ -23,6 +21,8 @@ struct pic_cont {
pic_code *ip;
pic_value ptable;
struct pic_object **arena;
size_t arena_size;
int arena_idx;
@ -33,7 +33,7 @@ struct pic_cont {
static void
cont_dtor(pic_state *pic, void *data)
{
struct pic_cont *cont = data;
struct pic_fullcont *cont = data;
pic_free(pic, cont->stk_ptr);
pic_free(pic, cont->st_ptr);
@ -46,20 +46,20 @@ cont_dtor(pic_state *pic, void *data)
static void
cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value))
{
struct pic_cont *cont = data;
struct pic_winder *wind;
struct pic_fullcont *cont = data;
pic_checkpoint *cp;
pic_value *stack;
pic_callinfo *ci;
struct pic_proc **xp;
size_t i;
/* winder */
for (wind = cont->wind; wind != NULL; wind = wind->prev) {
if (wind->in) {
mark(pic, pic_obj_value(wind->in));
/* checkpoint */
for (cp = cont->cp; cp != NULL; cp = cp->prev) {
if (cp->in) {
mark(pic, pic_obj_value(cp->in));
}
if (wind->out) {
mark(pic, pic_obj_value(wind->out));
if (cp->out) {
mark(pic, pic_obj_value(cp->out));
}
}
@ -70,8 +70,8 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value))
/* callinfo */
for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) {
if (ci->env) {
mark(pic, pic_obj_value(ci->env));
if (ci->cxt) {
mark(pic, pic_obj_value(ci->cxt));
}
}
@ -85,14 +85,17 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value))
mark(pic, pic_obj_value(cont->arena[i]));
}
/* parameter table */
mark(pic, cont->ptable);
/* result values */
mark(pic, cont->results);
}
static const pic_data_type cont_type = { "continuation", cont_dtor, cont_mark };
static void save_cont(pic_state *, struct pic_cont **);
static void restore_cont(pic_state *, struct pic_cont *);
static void save_cont(pic_state *, struct pic_fullcont **);
static void restore_cont(pic_state *, struct pic_fullcont *);
static ptrdiff_t
native_stack_length(pic_state *pic, char **pos)
@ -109,51 +112,55 @@ native_stack_length(pic_state *pic, char **pos)
}
static void
save_cont(pic_state *pic, struct pic_cont **c)
save_cont(pic_state *pic, struct pic_fullcont **c)
{
void pic_vm_tear_off(pic_state *);
struct pic_cont *cont;
struct pic_fullcont *cont;
char *pos;
pic_vm_tear_off(pic); /* tear off */
cont = *c = pic_alloc(pic, sizeof(struct pic_cont));
cont = *c = pic_malloc(pic, sizeof(struct pic_fullcont));
cont->wind = pic->wind;
cont->prev_jmp = pic->jmp;
cont->cp = pic->cp;
cont->stk_len = native_stack_length(pic, &pos);
cont->stk_pos = pos;
assert(cont->stk_len > 0);
cont->stk_ptr = pic_alloc(pic, cont->stk_len);
cont->stk_ptr = pic_malloc(pic, cont->stk_len);
memcpy(cont->stk_ptr, cont->stk_pos, cont->stk_len);
cont->sp_offset = pic->sp - pic->stbase;
cont->st_len = pic->stend - pic->stbase;
cont->st_ptr = pic_alloc(pic, sizeof(pic_value) * cont->st_len);
cont->st_ptr = pic_malloc(pic, sizeof(pic_value) * cont->st_len);
memcpy(cont->st_ptr, pic->stbase, sizeof(pic_value) * cont->st_len);
cont->ci_offset = pic->ci - pic->cibase;
cont->ci_len = pic->ciend - pic->cibase;
cont->ci_ptr = pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len);
cont->ci_ptr = pic_malloc(pic, sizeof(pic_callinfo) * cont->ci_len);
memcpy(cont->ci_ptr, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
cont->xp_offset = pic->xp - pic->xpbase;
cont->xp_len = pic->xpend - pic->xpbase;
cont->xp_ptr = pic_alloc(pic, sizeof(struct pic_proc *) * cont->xp_len);
cont->xp_ptr = pic_malloc(pic, sizeof(struct pic_proc *) * cont->xp_len);
memcpy(cont->xp_ptr, pic->xpbase, sizeof(struct pic_proc *) * cont->xp_len);
cont->ip = pic->ip;
cont->ptable = pic->ptable;
cont->arena_idx = pic->arena_idx;
cont->arena_size = pic->arena_size;
cont->arena = pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size);
cont->arena = pic_malloc(pic, sizeof(struct pic_object *) * pic->arena_size);
memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size);
cont->results = pic_undef_value();
}
static void
native_stack_extend(pic_state *pic, struct pic_cont *cont)
native_stack_extend(pic_state *pic, struct pic_fullcont *cont)
{
volatile pic_value v[1024];
@ -161,11 +168,11 @@ native_stack_extend(pic_state *pic, struct pic_cont *cont)
restore_cont(pic, cont);
}
pic_noreturn static void
restore_cont(pic_state *pic, struct pic_cont *cont)
PIC_NORETURN static void
restore_cont(pic_state *pic, struct pic_fullcont *cont)
{
char v;
struct pic_cont *tmp = cont;
struct pic_fullcont *tmp = cont;
if (&v < pic->native_stack_start) {
if (&v > cont->stk_pos) native_stack_extend(pic, cont);
@ -174,7 +181,9 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
}
pic->wind = cont->wind;
pic->jmp = cont->prev_jmp;
pic->cp = cont->cp;
pic->stbase = pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len);
@ -193,6 +202,8 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
pic->ip = cont->ip;
pic->ptable = cont->ptable;
pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size);
memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * cont->arena_size);
pic->arena_size = cont->arena_size;
@ -203,30 +214,30 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
longjmp(tmp->jmp, 1);
}
pic_noreturn static pic_value
PIC_NORETURN static pic_value
cont_call(pic_state *pic)
{
struct pic_proc *proc;
size_t argc;
pic_value *argv;
struct pic_cont *cont;
struct pic_fullcont *cont;
proc = pic_get_proc(pic);
pic_get_args(pic, "*", &argc, &argv);
cont = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(proc), "@@cont"))->data;
cont = pic_data_ptr(pic_proc_env_ref(pic, proc, "cont"))->data;
cont->results = pic_list_by_array(pic, argc, argv);
/* execute guard handlers */
pic_wind(pic, pic->wind, cont->wind);
pic_wind(pic, pic->cp, cont->cp);
restore_cont(pic, cont);
}
pic_value
pic_callcc(pic_state *pic, struct pic_proc *proc)
pic_callcc_full(pic_state *pic, struct pic_proc *proc)
{
struct pic_cont *cont;
struct pic_fullcont *cont;
save_cont(pic, &cont);
if (setjmp(cont->jmp)) {
@ -241,16 +252,16 @@ pic_callcc(pic_state *pic, struct pic_proc *proc)
dat = pic_data_alloc(pic, &cont_type, cont);
/* save the continuation object in proc */
pic_attr_set(pic, pic_obj_value(c), "@@cont", pic_obj_value(dat));
pic_proc_env_set(pic, c, "cont", pic_obj_value(dat));
return pic_apply1(pic, proc, pic_obj_value(c));
}
}
static pic_value
pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
pic_callcc_full_trampoline(pic_state *pic, struct pic_proc *proc)
{
struct pic_cont *cont;
struct pic_fullcont *cont;
save_cont(pic, &cont);
if (setjmp(cont->jmp)) {
@ -265,7 +276,7 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
dat = pic_data_alloc(pic, &cont_type, cont);
/* save the continuation object in proc */
pic_attr_set(pic, pic_obj_value(c), "@@cont", pic_obj_value(dat));
pic_proc_env_set(pic, c, "cont", pic_obj_value(dat));
return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c)));
}
@ -278,7 +289,7 @@ pic_callcc_callcc(pic_state *pic)
pic_get_args(pic, "l", &cb);
return pic_callcc_trampoline(pic, cb);
return pic_callcc_full_trampoline(pic, cb);
}
#define pic_redefun(pic, lib, name, func) \
@ -287,6 +298,12 @@ pic_callcc_callcc(pic_state *pic)
void
pic_init_callcc(pic_state *pic)
{
pic_deflibrary (pic, "(picrin control)") {
pic_define(pic, "escape", pic_ref(pic, pic->PICRIN_BASE, "call-with-current-continuation"));
}
pic_deflibrary (pic, "(scheme base)") {
pic_redefun(pic, pic->PICRIN_BASE, "call-with-current-continuation", pic_callcc_callcc);
pic_redefun(pic, pic->PICRIN_BASE, "call/cc", pic_callcc_callcc);
}
}

2
contrib/03.callcc/nitro.mk Normal file
View File

@ -0,0 +1,2 @@
CONTRIB_INITS += callcc
CONTRIB_SRCS += $(wildcard contrib/03.callcc/*.c)

4
contrib/03.file/CMakeLists.txt
View File

@ -1,4 +0,0 @@
file(GLOB PICRIN_FILE_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.file/src/*.c)
list(APPEND PICRIN_CONTRIB_INITS file)
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_FILE_SOURCES})

4
contrib/03.load/CMakeLists.txt
View File

@ -1,4 +0,0 @@
file(GLOB PICRIN_LOAD_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.load/src/*.c)
list(APPEND PICRIN_CONTRIB_INITS load)
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_LOAD_SOURCES})

5
contrib/03.mutable-string/CMakeLists.txt
View File

@ -1,5 +0,0 @@
file(GLOB PICRIN_MUTABLE_STRING_SOURCES
${PROJECT_SOURCE_DIR}/contrib/03.mutable-string/*.c)
list(APPEND PICRIN_CONTRIB_INITS mutable_string)
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_MUTABLE_STRING_SOURCES})

4
contrib/03.system/CMakeLists.txt
View File

@ -1,4 +0,0 @@
file(GLOB PICRIN_SYSTEM_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.system/src/*.c)
list(APPEND PICRIN_CONTRIB_INITS system)
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_SYSTEM_SOURCES})

4
contrib/03.time/CMakeLists.txt
View File

@ -1,4 +0,0 @@
file(GLOB PICRIN_TIME_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.time/src/*.c)
list(APPEND PICRIN_CONTRIB_INITS time)
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_TIME_SOURCES})

15
contrib/05.r7rs/CMakeLists.txt
View File

@ -1,15 +0,0 @@
list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/base.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/cxr.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/read.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/write.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/file.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/case-lambda.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/lazy.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/eval.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/inexact.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/load.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/process-context.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/time.scm
${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/r5rs.scm
)

24
contrib/05.r7rs/nitro.mk Normal file
View File

@ -0,0 +1,24 @@
CONTRIB_INITS += r7rs
CONTRIB_SRCS += \
contrib/05.r7rs/src/r7rs.c\
contrib/05.r7rs/src/file.c\
contrib/05.r7rs/src/load.c\
contrib/05.r7rs/src/mutable-string.c\
contrib/05.r7rs/src/system.c\
contrib/05.r7rs/src/time.c
CONTRIB_LIBS += \
contrib/05.r7rs/scheme/base.scm\
contrib/05.r7rs/scheme/cxr.scm\
contrib/05.r7rs/scheme/read.scm\
contrib/05.r7rs/scheme/write.scm\
contrib/05.r7rs/scheme/file.scm\
contrib/05.r7rs/scheme/case-lambda.scm\
contrib/05.r7rs/scheme/lazy.scm\
contrib/05.r7rs/scheme/eval.scm\
contrib/05.r7rs/scheme/inexact.scm\
contrib/05.r7rs/scheme/load.scm\
contrib/05.r7rs/scheme/process-context.scm\
contrib/05.r7rs/scheme/time.scm\
contrib/05.r7rs/scheme/r5rs.scm

12
contrib/03.file/src/file.c → contrib/05.r7rs/src/file.c
View File

@ -3,13 +3,15 @@
*/
#include "picrin.h"
#include "picrin/port.h"
#include "picrin/error.h"
pic_noreturn static void
PIC_NORETURN static void
file_error(pic_state *pic, const char *msg)
{
pic_throw(pic, pic->sFILE, msg, pic_nil_value());
struct pic_error *e;
e = pic_make_error(pic, pic->sFILE, msg, pic_nil_value());
pic_raise(pic, pic_obj_value(e));
}
static pic_value
@ -102,7 +104,7 @@ pic_file_delete(pic_state *pic)
if (remove(fname) != 0) {
file_error(pic, "file cannot be deleted");
}
return pic_none_value();
return pic_undef_value();
}
void

5
contrib/03.load/src/load.c → contrib/05.r7rs/src/load.c
View File

@ -3,9 +3,6 @@
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/port.h"
#include "picrin/error.h"
void
pic_load(pic_state *pic, const char *filename)
@ -38,7 +35,7 @@ pic_load_load(pic_state *pic)
pic_load(pic, fn);
return pic_none_value();
return pic_undef_value();
}
void

25
contrib/03.mutable-string/mutable-string.c → contrib/05.r7rs/src/mutable-string.c
View File

@ -1,23 +1,22 @@
#include "picrin.h"
#include "picrin/string.h"
void
pic_str_set(pic_state *pic, pic_str *str, size_t i, char c)
{
pic_str *x, *y, *z, *tmp;
if (pic_strlen(str) <= i) {
if (pic_str_len(str) <= i) {
pic_errorf(pic, "index out of range %d", i);
}
x = pic_substr(pic, str, 0, i);
x = pic_str_sub(pic, str, 0, i);
y = pic_make_str_fill(pic, 1, c);
z = pic_substr(pic, str, i + 1, pic_strlen(str));
z = pic_str_sub(pic, str, i + 1, pic_str_len(str));
tmp = pic_strcat(pic, x, pic_strcat(pic, y, z));
tmp = pic_str_cat(pic, x, pic_str_cat(pic, y, z));
XROPE_INCREF(tmp->rope);
XROPE_DECREF(str->rope);
pic_rope_incref(pic, tmp->rope);
pic_rope_decref(pic, str->rope);
str->rope = tmp->rope;
}
@ -31,7 +30,7 @@ pic_str_string_set(pic_state *pic)
pic_get_args(pic, "sic", &str, &k, &c);
pic_str_set(pic, str, k, c);
return pic_none_value();
return pic_undef_value();
}
static pic_value
@ -46,16 +45,16 @@ pic_str_string_copy_ip(pic_state *pic)
case 3:
start = 0;
case 4:
end = pic_strlen(from);
end = pic_str_len(from);
}
if (to == from) {
from = pic_substr(pic, from, 0, end);
from = pic_str_sub(pic, from, 0, end);
}
while (start < end) {
pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++));
}
return pic_none_value();
return pic_undef_value();
}
static pic_value
@ -71,13 +70,13 @@ pic_str_string_fill_ip(pic_state *pic)
case 2:
start = 0;
case 3:
end = pic_strlen(str);
end = pic_str_len(str);
}
while (start < end) {
pic_str_set(pic, str, start++, c);
}
return pic_none_value();
return pic_undef_value();
}
void

21
contrib/05.r7rs/src/r7rs.c Normal file
View File

@ -0,0 +1,21 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
void pic_init_file(pic_state *);
void pic_init_load(pic_state *);
void pic_init_mutable_string(pic_state *);
void pic_init_system(pic_state *);
void pic_init_time(pic_state *);
void
pic_init_r7rs(pic_state *pic)
{
pic_init_file(pic);
pic_init_load(pic);
pic_init_mutable_string(pic);
pic_init_system(pic);
pic_init_time(pic);
}

5
contrib/03.system/src/system.c → contrib/05.r7rs/src/system.c
View File

@ -5,9 +5,6 @@
#include <stdlib.h>
#include "picrin.h"
#include "picrin/string.h"
#include "picrin/pair.h"
#include "picrin/cont.h"
static pic_value
pic_system_cmdline(pic_state *pic)
@ -111,7 +108,7 @@ pic_system_getenvs(pic_state *pic)
;
key = pic_make_str(pic, *envp, i);
val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key)));
val = pic_make_str_cstr(pic, getenv(pic_str_cstr(pic, key)));
/* push */
data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);

0
contrib/03.time/src/time.c → contrib/05.r7rs/src/time.c
View File

9
contrib/10.optional/CMakeLists.txt
View File

@ -1,9 +0,0 @@
file(GLOB OPTIONAL_FILES ${PROJECT_SOURCE_DIR}/contrib/10.optional/piclib/*.scm)
list(APPEND PICLIB_CONTRIB_LIBS ${OPTIONAL_FILES})
add_custom_target(test-optional
for test in ${PROJECT_SOURCE_DIR}/contrib/10.optional/t/*.scm \;
do
bin/picrin "$$test" \;
done
DEPENDS repl)
set(CONTRIB_TESTS ${CONTRIB_TESTS} test-optional)

7
contrib/10.optional/nitro.mk Normal file
View File

@ -0,0 +1,7 @@
CONTRIB_LIBS += $(wildcard contrib/10.optional/piclib/*.scm)
CONTRIB_TESTS += test-optional
test-optional: bin/picrin
for test in `ls contrib/10.optional/t/*.scm`; do \
bin/picrin $$test; \
done

2
contrib/10.partcont/CMakeLists.txt
View File

@ -1,2 +0,0 @@
file(GLOB PARTCONT_FILES ${PROJECT_SOURCE_DIR}/contrib/10.partcont/piclib/*.scm)
list(APPEND PICLIB_CONTRIB_LIBS ${PARTCONT_FILES})

4
contrib/10.partcont/docs/doc.rst
View File

@ -6,3 +6,7 @@ Delimited control operators.
- **(reset h)**
- **(shift k)**
Escape Continuation
- **(escape f)**

1
contrib/10.partcont/nitro.mk Normal file
View File

@ -0,0 +1 @@
CONTRIB_LIBS += $(wildcard contrib/10.partcont/piclib/*.scm)

1
contrib/10.pretty-print/CMakeLists.txt
View File

@ -1 +0,0 @@
list(APPEND PICLIB_CONTRIB_LIBS ${PROJECT_SOURCE_DIR}/contrib/10.pretty-print/pretty-print.scm)

1
contrib/10.pretty-print/nitro.mk Normal file
View File

@ -0,0 +1 @@
CONTRIB_LIBS += contrib/10.pretty-print/pretty-print.scm

11
contrib/10.random/CMakeLists.txt
View File

@ -1,11 +0,0 @@
file(GLOB PICRIN_RANDOM_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.random/src/*.c)
list(APPEND PICRIN_CONTRIB_INITS random)
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_RANDOM_SOURCES})
add_custom_target(test-random
for test in ${PROJECT_SOURCE_DIR}/contrib/10.random/t/*.scm \;
do
bin/picrin "$$test" \;
done
DEPENDS repl)
set(CONTRIB_TESTS ${CONTRIB_TESTS} test-random)

8
contrib/10.random/nitro.mk Normal file
View File

@ -0,0 +1,8 @@
CONTRIB_INITS += random
CONTRIB_SRCS += $(wildcard contrib/10.random/src/*.c)
CONTRIB_TESTS += test-random
test-random: bin/picrin
for test in `ls contrib/10.random/t/*.scm`; do \
bin/picrin $$test; \
done

17
contrib/10.readline/CMakeLists.txt
View File

@ -1,17 +0,0 @@
# readline
set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${PROJECT_SOURCE_DIR}/contrib/10.readline/cmake/")
find_package(Libedit)
if (Libedit_FOUND)
add_definitions(${Libedit_DEFINITIONS} -DPIC_READLINE_FOUND=1 -DPIC_READLINE_INCLUDE_DIR_SUFFIX=${Libedit_INCLUDE_DIR_SUFFIX})
include_directories(${Libedit_INCLUDE_DIR})
file(GLOB PICRIN_READLINE_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.readline/src/*.c)
list(APPEND PICRIN_CONTRIB_INITS readline)
list(APPEND PICRIN_CONTRIB_LIBRARIES ${Libedit_LIBRARIES})
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_READLINE_SOURCES})
add_custom_target(test-readline for test in ${PROJECT_SOURCE_DIR}/contrib/10.readline/t/*.scm \; do bin/picrin "$$test" \; done DEPENDS repl)
set(CONTRIB_TESTS ${CONTRIB_TESTS} test-readline)
endif(Libedit_FOUND)

107
contrib/10.readline/cmake/FindLibedit.cmake
View File

@ -1,107 +0,0 @@
# - Try to find libedit
# Once done this will define
#
# Libedit_FOUND - system has libedit
# Libedit_INCLUDE_DIRS - the libedit include directory
# Libedit_LIBRARIES - Link these to use libedit
# Libedit_DEFINITIONS - Compiler switches required for using libedit
#
# Copyright (c) 2014 Yuichi Nishiwaki <yuichi@idylls.jp>
# Copyright (c) 2008 Andreas Schneider <mail@cynapses.org>
# Modified for other libraries by Lasse Kärkkäinen <tronic>
#
# Redistribution and use is allowed according to the terms of the New
# BSD license.
#
if (Libedit_LIBRARIES AND Libedit_INCLUDE_DIRS)
# in cache already
set(Libedit_FOUND TRUE)
else (Libedit_LIBRARIES AND Libedit_INCLUDE_DIRS)
# use pkg-config to get the directories and then use these values
# in the FIND_PATH() and FIND_LIBRARY() calls
if (${CMAKE_MAJOR_VERSION} EQUAL 2 AND ${CMAKE_MINOR_VERSION} EQUAL 4)
include(UsePkgConfig)
pkgconfig(libedit _Libedit_INCLUDEDIR _Libedit_LIBDIR _Libedit_LDFLAGS _Libedit_CFLAGS)
else (${CMAKE_MAJOR_VERSION} EQUAL 2 AND ${CMAKE_MINOR_VERSION} EQUAL 4)
find_package(PkgConfig)
if (PKG_CONFIG_FOUND)
pkg_check_modules(_LIBEDIT libedit)
endif (PKG_CONFIG_FOUND)
endif (${CMAKE_MAJOR_VERSION} EQUAL 2 AND ${CMAKE_MINOR_VERSION} EQUAL 4)
find_path(Libedit_EDITLINE_INCLUDE_DIR
NAMES
editline/readline.h
editline/history.h
PATHS
${_Libedit_INCLUDEDIR}
/usr/include
/usr/local/include
/opt/local/include
/sw/include
)
if (Libedit_EDITLINE_INCLUDE_DIR)
set(Libedit_INCLUDE_DIR_SUFFIX editline)
set(Libedit_INCLUDE_DIR ${Libedit_EDITLINE_INCLUDE_DIR})
else (Libedit_EDITLINE_INCLUDE_DIR)
find_path(Libedit_READLINE_INCLUDE_DIR
NAMES
readline/readline.h
readline/history.h
PATHS
/usr/include/edit
/usr/local/include/edit
/opt/local/include/edit
/sw/include/edit
)
if (Libedit_READLINE_INCLUDE_DIR)
set(Libedit_INCLUDE_DIR_SUFFIX readline)
set(Libedit_INCLUDE_DIR ${Libedit_READLINE_INCLUDE_DIR})
endif (Libedit_READLINE_INCLUDE_DIR)
endif (Libedit_EDITLINE_INCLUDE_DIR)
find_library(Libedit_LIBRARY
NAMES
edit
PATHS
${_Libedit_LIBDIR}
/usr/lib
/usr/local/lib
/opt/local/lib
/sw/lib
)
if (Libedit_LIBRARY)
set(Libedit_FOUND TRUE)
endif (Libedit_LIBRARY)
set(Libedit_INCLUDE_DIRS
${Libedit_INCLUDE_DIR}
)
if (Libedit_FOUND)
set(Libedit_LIBRARIES
${Libedit_LIBRARIES}
${Libedit_LIBRARY}
)
endif (Libedit_FOUND)
if (Libedit_INCLUDE_DIRS AND Libedit_LIBRARIES)
set(Libedit_FOUND TRUE)
endif (Libedit_INCLUDE_DIRS AND Libedit_LIBRARIES)
if (Libedit_FOUND)
if (NOT Libedit_FIND_QUIETLY)
message(STATUS "Found libedit: ${Libedit_LIBRARY}, ${Libedit_INCLUDE_DIR}")
endif (NOT Libedit_FIND_QUIETLY)
else (Libedit_FOUND)
if (Libedit_FIND_REQUIRED)
message(FATAL_ERROR "Could not find libedit")
endif (Libedit_FIND_REQUIRED)
endif (Libedit_FOUND)
# show the Libedit_INCLUDE_DIRS and Libedit_LIBRARIES variables only in the advanced view
mark_as_advanced(Libedit_INCLUDE_DIRS Libedit_LIBRARIES)
endif (Libedit_LIBRARIES AND Libedit_INCLUDE_DIRS)

16
contrib/10.readline/nitro.mk Normal file
View File

@ -0,0 +1,16 @@
libedit_exists := $(shell pkg-config libedit --exists; echo $$?)
ifeq ($(libedit_exists),0)
CONTRIB_SRCS += contrib/10.readline/src/readline.c
CONTRIB_INITS += readline
CONTRIB_TESTS += test-readline
LDFLAGS += `pkg-config libedit --libs`
endif
contrib/src/readline.o: contrib/src/readline.c
$(CC) $(CFLAGS) -o $@ $< `pkg-config libedit --cflags`
test-readline: bin/picrin
for test in `ls contrib/10.readline/t/*.scm`; do \
bin/picrin $$test; \
done

9
contrib/10.readline/src/readline.c
View File

@ -6,17 +6,8 @@
forget to use the C++ extern "C" to get it to compile.
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/port.h"
#if PIC_READLINE_INCLUDE_DIR_SUFFIX == readline
#include <readline/readline.h>
#include <readline/history.h>
#else
#include <editline/readline.h>
#include <editline/history.h>
#endif
static pic_value
pic_rl_readline(pic_state *pic)

18
contrib/10.regexp/CMakeLists.txt
View File

@ -1,18 +0,0 @@
# regex
set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${PROJECT_SOURCE_DIR}/contrib/10.regexp/cmake/")
find_package(REGEX)
if (REGEX_FOUND)
add_definitions(${REGEX_DEFINITIONS})
include_directories(${REGEX_INCLUDE_DIR})
file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.regexp/src/*.c)
list(APPEND PICRIN_CONTRIB_INITS regexp)
list(APPEND PICRIN_CONTRIB_LIBRARIES ${REGEX_LIBRARIES})
list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_REGEX_SOURCES})
add_custom_target(test-regexp for test in ${PROJECT_SOURCE_DIR}/contrib/10.regexp/t/*.scm \; do bin/picrin "$$test" \; done DEPENDS repl)
set(CONTRIB_TESTS ${CONTRIB_TESTS} test-regexp)
endif()

82
contrib/10.regexp/cmake/FindREGEX.cmake
View File

@ -1,82 +0,0 @@
# -*- cmake -*-
#
# FindRegex.cmake: Try to find Regex
#
# Copyright (C) 2014- Yuichi Nishiwaki
# Copyright (C) 2005-2013 EDF-EADS-Phimeca
#
# This library is free software: you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# along with this library. If not, see <http://www.gnu.org/licenses/>.
#
# @author dutka
# @date 2010-02-04 16:44:49 +0100 (Thu, 04 Feb 2010)
#
# - Try to find Regex
# Once done this will define
#
# REGEX_FOUND - System has Regex
# REGEX_INCLUDE_DIR - The Regex include directory
# REGEX_LIBRARIES - The libraries needed to use Regex
# REGEX_DEFINITIONS - Compiler switches required for using Regex
#
#
# ChangeLogs:
#
# 2014/05/07 - Yuichi Nishiwaki
# On Mac, it finds /System/Library/Frameworks/Ruby.framework/Headers/regex.h,
# which was a part of superold version of glibc when POSIX standard didn't exist.
# To avoid this behavior, we call find_path twice, searching /usr/include and
# /usr/local/include first and if nothing was found then searching $PATH in the
# second stage.
#
IF (REGEX_INCLUDE_DIR AND REGEX_LIBRARIES)
# in cache already
SET(Regex_FIND_QUIETLY TRUE)
ENDIF (REGEX_INCLUDE_DIR AND REGEX_LIBRARIES)
#IF (NOT WIN32)
# # use pkg-config to get the directories and then use these values
# # in the FIND_PATH() and FIND_LIBRARY() calls
# FIND_PACKAGE(PkgConfig)
# PKG_CHECK_MODULES(PC_REGEX regex)
# SET(REGEX_DEFINITIONS ${PC_REGEX_CFLAGS_OTHER})
#ENDIF (NOT WIN32)
FIND_PATH(REGEX_INCLUDE_DIR regex.h
PATHS /usr/include /usr/local/include
NO_DEFAULT_PATH
)
IF (NOT REGEX_INCLUDE_DIR)
FIND_PATH(REGEX_INCLUDE_DIR regex.h
HINTS
${REGEX_INCLUDEDIR}
${PC_LIBXML_INCLUDE_DIRS}
PATH_SUFFIXES regex
)
ENDIF()
FIND_LIBRARY(REGEX_LIBRARIES NAMES c regex
HINTS
${PC_REGEX_LIBDIR}
${PC_REGEX_LIBRARY_DIRS}
)
INCLUDE(FindPackageHandleStandardArgs)
# handle the QUIETLY and REQUIRED arguments and set REGEX_FOUND to TRUE if
# all listed variables are TRUE
FIND_PACKAGE_HANDLE_STANDARD_ARGS(Regex DEFAULT_MSG REGEX_LIBRARIES REGEX_INCLUDE_DIR)
MARK_AS_ADVANCED(REGEX_INCLUDE_DIR REGEX_LIBRARIES)

8
contrib/10.regexp/nitro.mk Normal file
View File

@ -0,0 +1,8 @@
CONTRIB_SRCS += contrib/10.regexp/src/regexp.c
CONTRIB_INITS += regexp
CONTRIB_TESTS += test-regexp
test-regexp: bin/picrin
for test in `ls contrib/10.regexp/t/*.scm`; do \
bin/picrin $$test; \
done

14
contrib/10.regexp/src/regexp.c
View File

@ -1,8 +1,4 @@
#include "picrin.h"
#include "picrin/data.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/cont.h"
#include <regex.h>
@ -54,11 +50,11 @@ pic_regexp_regexp(pic_state *pic)
}
}
reg = pic_alloc(pic, sizeof(struct pic_regexp_t));
reg = pic_malloc(pic, sizeof(struct pic_regexp_t));
reg->flags = flags;
if ((err = regcomp(&reg->reg, ptrn, cflags)) != 0) {
char errbuf[regerror(err, &reg->reg, NULL, 0)];
char errbuf[256];
regerror(err, &reg->reg, errbuf, sizeof errbuf);
regexp_dtor(pic, &reg->reg);
@ -168,13 +164,13 @@ pic_regexp_regexp_replace(pic_state *pic)
pic_assert_type(pic, reg, regexp);
while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, &match, 0) != REG_NOMATCH) {
output = pic_strcat(pic, output, pic_make_str(pic, input, match.rm_so));
output = pic_strcat(pic, output, txt);
output = pic_str_cat(pic, output, pic_make_str(pic, input, match.rm_so));
output = pic_str_cat(pic, output, txt);
input += match.rm_eo;
}
output = pic_strcat(pic, output, pic_make_str(pic, input, strlen(input)));
output = pic_str_cat(pic, output, pic_make_str(pic, input, strlen(input)));
return pic_obj_value(output);
}

2
contrib/10.regexp/t/test.scm
View File

@ -8,5 +8,5 @@
(test '("a" "b" "c" "d") (regexp-split (regexp ",") "a,b,c,d"))
(test '("a" "b" "c" "d") (regexp-split (regexp "\\.+") "a.b....c.....d"))
(test "a b c d" (regexp-replace (regexp ",") "a,b,c,d" " "))
(test "newline tab space " (regexp-replace (regexp "\\s") "newline
(test "newline tab space " (regexp-replace (regexp "[\n\t ]") "newline
tab space " " "))

10
contrib/10.srfi/CMakeLists.txt
View File

@ -1,10 +0,0 @@
list(APPEND PICLIB_CONTRIB_LIBS
${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/1.scm
${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/8.scm
${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/17.scm
${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/26.scm
${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/43.scm
${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/60.scm
${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/95.scm
${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/111.scm
)

9
contrib/10.srfi/nitro.mk Normal file
View File

@ -0,0 +1,9 @@
CONTRIB_LIBS += \
contrib/10.srfi/srfi/1.scm\
contrib/10.srfi/srfi/8.scm\
contrib/10.srfi/srfi/17.scm\
contrib/10.srfi/srfi/26.scm\
contrib/10.srfi/srfi/43.scm\
contrib/10.srfi/srfi/60.scm\
contrib/10.srfi/srfi/95.scm\
contrib/10.srfi/srfi/111.scm

10
contrib/10.srfi/srfi/17.scm
View File

@ -2,7 +2,6 @@
(import (except (scheme base) set!)
(prefix (only (scheme base) set!) %)
(picrin dictionary)
(except (picrin base) set!)
(srfi 1)
(srfi 8))
@ -17,11 +16,10 @@
(define setter
(letrec ((setter
(lambda (proc)
(receive (setter exists) (dictionary-ref (attribute proc)
'@@setter)
(if exists
setter
(error "No setter found")))))
(let ((setter (dictionary-ref (attribute proc) '@@setter)))
(if (undefined? setter)
(error "no setter found")
setter))))
(set-setter!
(lambda (proc setter)
(dictionary-set! (attribute proc) '@@setter setter))))

18
contrib/10.srfi/srfi/43.scm
View File

@ -1,5 +1,5 @@
(define-library (srfi 43)
(import (scheme base)
(import (except (scheme base) vector-map)
(srfi 8))
;; # Constructors
@ -92,15 +92,27 @@
(map (lambda (v) (vector-ref v count)) vects))
(- count 1))))))
(define (vector-map! f vec . vects)
(define (vector-map f vec . vects)
(let* ((vects (cons vec vects))
(veclen (apply min (map vector-length vects)))
(new-vect (make-vector veclen)))
(let rec ((count 0))
(if (= count veclen)
new-vect
(begin
(vector-set! new-vect count
(apply f count (map (lambda (v) (vector-ref v count))
vects)))
(rec (+ 1 count)))))))
(define (vector-map! f vec . vects)
(let* ((vects (cons vec vects))
(veclen (apply min (map vector-length vects))))
(let rec ((count 0))
(if (< count veclen)
(begin
(vector-set! vec count
(apply f (map (lambda (v) (vector-ref v count))
(apply f count (map (lambda (v) (vector-ref v count))
vects)))
(rec (+ 1 count)))))))

4
contrib/20.for/CMakeLists.txt
View File

@ -1,4 +0,0 @@
file(GLOB FOR_FILES ${PROJECT_SOURCE_DIR}/contrib/20.for/piclib/*.scm)
list(APPEND PICLIB_CONTRIB_LIBS ${FOR_FILES})
add_custom_target(test-for for test in ${PROJECT_SOURCE_DIR}/contrib/20.for/t/*.scm \; do bin/picrin "$$test" \; done DEPENDS repl)
set(CONTRIB_TESTS ${CONTRIB_TESTS} test-for)

7
contrib/20.for/nitro.mk Normal file
View File

@ -0,0 +1,7 @@
CONTRIB_LIBS += $(wildcard contrib/20.for/piclib/*.scm)
CONTRIB_TESTS += test-for
test-for: bin/picrin
for test in `ls contrib/20.for/t/*.scm`; do \
bin/picrin "$$test"; \
done

3
contrib/20.repl/CMakeLists.txt
View File

@ -1,3 +0,0 @@
list(APPEND PICLIB_CONTRIB_LIBS ${PROJECT_SOURCE_DIR}/contrib/20.repl/repl.scm)
list(APPEND PICRIN_CONTRIB_SOURCES ${PROJECT_SOURCE_DIR}/contrib/20.repl/repl.c)
list(APPEND PICRIN_CONTRIB_INITS repl)

3
contrib/20.repl/nitro.mk Normal file
View File

@ -0,0 +1,3 @@
CONTRIB_LIBS += contrib/20.repl/repl.scm
CONTRIB_SRCS += contrib/20.repl/repl.c
CONTRIB_INITS += repl

5
contrib/20.repl/repl.scm
View File

@ -11,7 +11,9 @@
(else
(begin
(define (readline str)
(if (tty?) (display str))
(when (tty?)
(display str)
(flush-output-port))
(read-line))
(define (add-history str)
#f))))
@ -28,7 +30,6 @@
(scheme lazy)
(scheme time)
(picrin macro)
(picrin dictionary)
(picrin array)
(picrin library))
'(picrin user))

1
contrib/30.main/CMakeLists.txt
View File

@ -1 +0,0 @@
list(APPEND PICLIB_CONTRIB_LIBS ${PROJECT_SOURCE_DIR}/contrib/30.main/main.scm)

1
contrib/30.main/nitro.mk Normal file
View File

@ -0,0 +1 @@
CONTRIB_LIBS += contrib/30.main/main.scm

2
contrib/40.class/CMakeLists.txt
View File

@ -1,2 +0,0 @@
file(GLOB CLASS_FILES ${PROJECT_SOURCE_DIR}/contrib/40.class/piclib/picrin/*.scm)
list(APPEND PICLIB_CONTRIB_LIBS ${CLASS_FILES})

1
contrib/40.class/nitro.mk Normal file
View File

@ -0,0 +1 @@
CONTRIB_LIBS += $(wildcard contrib/40.class/piclib/picrin/*.scm)

2
contrib/50.protocol/CMakeLists.txt
View File

@ -1,2 +0,0 @@
file(GLOB PROTOCOL_FILES ${PROJECT_SOURCE_DIR}/contrib/50.protocol/piclib/picrin/*.scm)
list(APPEND PICLIB_CONTRIB_LIBS ${PROTOCOL_FILES})

1
contrib/50.protocol/nitro.mk Normal file
View File

@ -0,0 +1 @@
CONTRIB_LIBS += $(wildcard contrib/50.protocol/piclib/picrin/*.scm)

5
contrib/CMakeLists.txt
View File

@ -1,5 +0,0 @@
file(GLOB CONTRIBS ${PROJECT_SOURCE_DIR}/contrib/*/CMakeLists.txt)
list(SORT CONTRIBS)
foreach(contrib ${CONTRIBS})
include(${contrib})
endforeach()

27
docs/CMakeLists.txt
View File

@ -1,27 +0,0 @@
# contribs
file(GLOB PICRIN_CONTRIB_DOCS ${PROJECT_SOURCE_DIR}/contrib/*/docs/*.rst)
file(GLOB PICRIN_DOCS ${PROJECT_SOURCE_DIR}/docs/*.rst)
list(SORT PICRIN_CONTRIB_DOCS)
set(PICRIN_CONTRIBS_DOC ${PROJECT_SOURCE_DIR}/docs/contrib.rst)
set(PICRIN_DOC_OUTPUT_DIRECTORY doc)
add_custom_command(
OUTPUT ${PICRIN_CONTRIBS_DOC}
COMMAND echo "Contrib Libraries \\\(a.k.a nitros\\\)" > ${PICRIN_CONTRIBS_DOC}
COMMAND echo "================================" >> ${PICRIN_CONTRIBS_DOC}
COMMAND echo "" >> ${PICRIN_CONTRIBS_DOC}
COMMAND cat ${PICRIN_CONTRIB_DOCS} >> ${PICRIN_CONTRIBS_DOC}
DEPENDS ${PICRIN_CONTRIB_DOCS}
)
add_custom_target(doc
COMMAND make -C ${PROJECT_SOURCE_DIR}/docs html
DEPENDS ${PICRIN_CONTRIBS_DOC}
)
add_custom_command(
TARGET doc POST_BUILD
COMMAND mkdir -p ${PICRIN_DOC_OUTPUT_DIRECTORY}
COMMAND cp -uR ${PROJECT_SOURCE_DIR}/docs/_build/* -t ${PICRIN_DOC_OUTPUT_DIRECTORY}/
)

1
docs/capi.rst
View File

@ -51,7 +51,6 @@ When you use dynamic memory allocation inside C APIs, you must be caseful about
/** foo.c **/
#include <stdlib.h>
#include "picrin.h"
#include "picrin/data.h"
/*
* C-side API

141
docs/contrib.rst
View File

@ -1,141 +0,0 @@
Contrib Libraries (a.k.a nitros)
================================
Scheme standard libraries
-------------------------
- (scheme write)
- (scheme cxr)
- (scheme file)
- (scheme inexact)
- (scheme time)
- (scheme process-context)
- (scheme load)
- (scheme lazy)
(picrin control)
----------------
Delimited control operators.
- **(reset h)**
- **(shift k)**
(picrin pretty-print)
---------------------
Pretty-printer.
- **(pretty-print obj)**
Prints obj with human-readable indention to current-output-port.
(picrin regexp)
---------------
- **(regexp ptrn [flags])**
Compiles pattern string into a regexp object. A string flags may contain any of #\g, #\i, #\m.
- **(regexp? obj)**
Judges if obj is a regexp object or not.
- **(regexp-match re input)**
Returns two values: a list of match strings, and a list of match indeces.
- **(regexp-replace re input txt)**
- **(regexp-split re input)**
SRFI libraries
--------------
- `(srfi 1)
<http://srfi.schemers.org/srfi-1/>`_
List library.
- `(srfi 8)
<http://srfi.schemers.org/srfi-8/>`_
``receive`` macro.
- `(srfi 17)
<http://srfi.schemers.org/srfi-17/>`_
Generalized set!
- `(srfi 26)
<http://srfi.schemers.org/srfi-26/>`_
Cut/cute macros.
- `(srfi 43)
<http://srfi.schemers.org/srfi-43/>`_
Vector library.
- `(srfi 60)
<http://srfi.schemers.org/srfi-60/>`_
Bitwise operations.
- `(srfi 95)
<http://srfi.schemers.org/srfi-95/>`_
Sorting and Marging.
- `(srfi 111)
<http://srfi.schemers.org/srfi-111/>`_
Boxes
(picrin control list)
---------------------
Monadic list operators.
The triple of for/in/yield enables you to write a list operation in a very easy and simple code. One of the best examples is list composition::
(for (let ((a (in '(1 2 3)))
(b (in '(2 3 4))))
(yield (+ a b))))
;=> (5 6 7 6 7 8 7 8 9)
All monadic operations are done in *for* macro. In this example, *in* operators choose an element from the given lists, a and b are bound here, then *yielding* the sum of them. Because a and b are values moving around in the list elements, the expression (+ a b) can become every possible result. *yield* operator is a operator that gathers the possibilities into a list, so *for* macro returns a list of 3 * 3 results in total. Since expression inside *for* macro is a normal expression, you can write everything that you can write elsewhere. The code below has perfectly the same effect to above one::
(for (yield (+ (in '(1 2 3))
(in '(4 5 6)))))
The second best exmaple is filtering. In the next case, we show that you can do something depending on the condition of chosen elements::
(for (let ((x (in (iota 10))))
(if (even? x)
(yield x)
(null))))
;=> (0 2 4 6 8)
This expression is equivalent to ``(filter even? (iota 10))`` but it is more procedual and non-magical.
- **(for expr)**
[Macro] Executes expr in a list monad context.
- **(in list)**
Choose a value from list. *in* function must only appear in *for* macro. The delimited continuation from the position of *in* function to the outside *for* macro is executed for each element in list. If list contains no values, that is ``(in '())``, the continuation is discarded.
- **(yield value)**
Yields value from the monad context. The result of *for* will be a list of yielded values.
- **(null . value)**
Returns ``()`` whatever value is given. The identity element of list composition. This operator corresponds to Haskell's fail method of Monad class.

58
docs/deploy.rst
View File

@ -4,68 +4,34 @@ Installation
Installation instructions below.
Build and Install
-----------------
To build picrin, you need some build tools installed on your platform.
- cmake (>= 2.6)
- git
Because of submodule dependencies, it is necessary to get picrin's source code via git clone command. Basically our git dependencies are only due to submodules, so in fact, If you have no git on your machine, it is possible to build it by downloading a tarball from github page as well. But in such case, you are assumed to modify CMakeLists.txt by yourself to get it work completely. We just strongly recommend you to use git-clone.
Generate Makefile
^^^^^^^^^^^^^^^^^
Change directory to `build` then run `ccmake` to create Makefile. Once `Makefile` is generated you can run `make` command to build picrin::
$ cd build
$ ccmake ..
Actually you don't necessarily need to move to `build` directory before running `ccmake` (in that case `$ ccmake .`), but I strongly recommend to follow above instruction.
Before generating Makefile, you can change some compilation switches to enable or disable optional features. Take *NAN_BOXING* for example, when you turn on "Use C11 feature" flag and the platform supports addresses of 48bit length, it is enabled.
Build
^^^^^
-----
A built executable binary will be under bin/ directory and shared libraries under lib/::
Just type `make` in the project root directory. You will find an executable binary newly created at bin/ directory.
$ make
If you are building picrin on other systems than x86_64, PIC_NAN_BOXING flag is automatically turned on (see include/picrin/config.h for detail).
When you are building picrin on x86_64 system, PIC_NAN_BOXING flag is automatically turned on (see include/picrin/config.h for detail).
Install
^^^^^^^
-------
Just running `make install`, picrin library, headers, and runtime binary are install on your system, by default into `/usr/local` directory. You can change this value via ccmake::
`make install` target is provided. By default it installs picrin binary into `/usr/local/bin/`.
$ make install
Run
^^^
Before installing picrin, you can try picrin without breaking any of your system. Simply directly run the binary `bin/picrin` from terminal, or you can use `make` to execute it like this::
$ make run
Debug run
^^^^^^^^^
If you execute `cmake` with debug flag `-DCMAKE_BUILD_TYPE=Debug`, it builds the binary with all debug flags enabled (PIC_GC_STRESS, VM_DEBUG, DEBUG)::
$ cmake -DCMAKE_BUILD_TYPE=Debug ..
Since picrin does not use autoconf, if you want to specify the install directory, pass the custom path to `make` via command line argument.
$ make install prefix=/path/to/dir
Requirement
-----------
Picrin scheme depends on some external libraries to build the binary:
To build Picrin Scheme from source code, some external libraries are required:
- perl
- readline (optional)
- regex.h of POSIX.1 (optional)
- regex.h of POSIX.1
- libedit (optional)
Optional libraries are, if cmake detected them, automatically enabled.
The compilation is tested only on Mac OSX and Ubuntu. I think (or hope) it'll be ok to compile and run on other operating systems such as Arch or Windows, but I don't guarantee :(
Make command automatically turns on optional libraries if available.
Picrin is mainly developed on Mac OS X and only tested on OS X or Ubuntu 14.04+. When you tried to run picrin on other platforms and found something was wrong with it, please send us an issue.

24
docs/intro.rst
View File

@ -1,20 +1,18 @@
Introduction
============
Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not require any special external libraries installed on the platform.
Picrin is a lightweight R7RS scheme implementation written in pure C89. It contains a reasonably fast VM, an improved hygienic macro system, usuful contribution libraries, and simple but powerful C interface.
- R7RS compatibility
- reentrant design (all VM states are stored in single global state object)
- bytecode interpreter (based on stack VM)
- direct threaded VM
- internal representation by nan-boxing
- conservative call/cc implementation (users can freely interleave native stack with VM stack)
- exact GC (simple mark and sweep, partially reference count is used as well)
- string representation by rope data structure
- support full set hygienic macro transformers, including implicit renaming macros
- extended library syntax
- advanced REPL support (multi-line input, etc)
- tiny & portable library (all functions will be in `libpicrin.so`)
- R7RS compatible
- Reentrant design (all VM states are stored in single global state object)
- Bytecode interpreter
- Direct threaded VM
- Internal representation by nan-boxing (available only on x64)
- Conservative call/cc implementation (VM stack and native c stack can interleave)
- Exact GC (simple mark and sweep, partially reference count)
- String representation by rope
- Hygienic macro transformers (syntactic closures, explicit and implicit renaming macros)
- Extended library syntax
Homepage
--------

10
docs/libs.rst
View File

@ -101,9 +101,7 @@ Technically, picrin's array is implemented as a ring-buffer, effective double-en
(picrin dictionary)
-------------------
Object-to-object table. Internally it is implemented on hash-table. Equivalence is tested with equal? procedure.
Note that dictionary is not a weak map; if you are going to make a highly memory-consuming program with dictionaries, you should know that dictionaries keep their bound objects and never let them free until you explicitly deletes bindings.
Symbol-to-object hash table.
- **(make-dictionary)**
@ -119,15 +117,13 @@ Note that dictionary is not a weak map; if you are going to make a highly memory
- **(dictionary-ref dict key)**
Look up dictionary dict for a value associated with key. It returns two values: first is the associated value if exists, and second is a boolean of lookup result.
Look up dictionary dict for a value associated with key. If dict has a slot for key `key`, the value stored in the slot is returned. Otherwise `#undefined` is returned.
- **(dictionary-set! dict key obj)**
If there is no value already associated with key, this function newly creates a binding of key with obj. Otherwise, updates the existing binding with given obj.
- **(dictionary-delete dict key)**
Deletes the binding associated with key from dict. If no binding on dict is associated with key, an error will be raised.
If obj is `#undefined`, this procedure behaves like a deleter: it will remove the key/value slot with the name `key` from the dictionary. When no slot is associated with `key`, it will do nothing.
- **(dictionary-size dict)**

19
etc/mkloader.pl
View File

@ -12,24 +12,27 @@ print <<EOL;
*/
#include "picrin.h"
#include "picrin/error.h"
EOL
foreach my $file (@ARGV) {
my $var = &escape_v($file);
print "static const char *$var =\n";
print "static const char ${var}[][80] = {\n";
open IN, $file;
while (<IN>) {
chomp;
local $/ = undef;
my $src = <IN>;
close IN;
my @lines = $src =~ /.{0,80}/gs;
foreach (@lines) {
s/\\/\\\\/g;
s/"/\\"/g;
print "\"$_\\n\"\n";
s/\n/\\n/g;
print "\"$_\",\n";
}
print ";\n\n";
print "};\n\n";
}
close IN;
print <<EOL;
void
@ -42,7 +45,7 @@ foreach my $file (@ARGV) {
my $var = &escape_v($file);
my $basename = basename($file);
my $dirname = basename(dirname($file));
print " pic_load_cstr(pic, $var);\n";
print " pic_load_cstr(pic, &${var}[0][0]);\n";
print<<EOL
}
pic_catch {

16
extlib/benz/attr.c
View File

@ -1,24 +1,22 @@
#include "picrin.h"
#include "picrin/dict.h"
struct pic_dict *
pic_attr(pic_state *pic, pic_value obj)
{
xh_entry *e;
struct pic_dict *dict;
if (pic_vtype(obj) != PIC_VTYPE_HEAP) {
if (! pic_obj_p(obj)) {
pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj);
}
e = xh_get_ptr(&pic->attrs, pic_ptr(obj));
if (e == NULL) {
struct pic_dict *dict = pic_make_dict(pic);
if (! pic_reg_has(pic, pic->attrs, pic_ptr(obj))) {
dict = pic_make_dict(pic);
e = xh_put_ptr(&pic->attrs, pic_ptr(obj), &dict);
pic_reg_set(pic, pic->attrs, pic_ptr(obj), pic_obj_value(dict));
assert(dict == xh_val(e, struct pic_dict *));
return dict;
}
return xh_val(e, struct pic_dict *);
return pic_dict_ptr(pic_reg_ref(pic, pic->attrs, pic_ptr(obj)));
}
pic_value

14
extlib/benz/blob.c
View File

@ -3,8 +3,6 @@
*/
#include "picrin.h"
#include "picrin/blob.h"
#include "picrin/pair.h"
struct pic_blob *
pic_make_blob(pic_state *pic, size_t len)
@ -12,7 +10,7 @@ pic_make_blob(pic_state *pic, size_t len)
struct pic_blob *bv;
bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB);
bv->data = pic_alloc(pic, len);
bv->data = pic_malloc(pic, len);
bv->len = len;
return bv;
}
@ -107,7 +105,7 @@ pic_blob_bytevector_u8_set(pic_state *pic)
pic_errorf(pic, "byte out of range");
bv->data[k] = (unsigned char)v;
return pic_none_value();
return pic_undef_value();
}
static pic_value
@ -132,14 +130,14 @@ pic_blob_bytevector_copy_i(pic_state *pic)
while (start < end) {
to->data[--at] = from->data[--end];
}
return pic_none_value();
return pic_undef_value();
}
while (start < end) {
to->data[at++] = from->data[start++];
}
return pic_none_value();
return pic_undef_value();
}
static pic_value
@ -203,7 +201,7 @@ pic_blob_list_to_bytevector(pic_state *pic)
{
pic_blob *blob;
unsigned char *data;
pic_value list, e;
pic_value list, e, it;
pic_get_args(pic, "o", &list);
@ -211,7 +209,7 @@ pic_blob_list_to_bytevector(pic_state *pic)
data = blob->data;
pic_for_each (e, list) {
pic_for_each (e, list, it) {
pic_assert_type(pic, e, int);
if (pic_int(e) < 0 || pic_int(e) > 255)

15
extlib/benz/bool.c
View File

@ -3,15 +3,11 @@
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/vector.h"
#include "picrin/blob.h"
#include "picrin/string.h"
static bool
str_equal_p(struct pic_string *str1, struct pic_string *str2)
str_equal_p(pic_state *pic, struct pic_string *str1, struct pic_string *str2)
{
return pic_strcmp(str1, str2) == 0;
return pic_str_cmp(pic, str1, str2) == 0;
}
static bool
@ -65,7 +61,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
switch (pic_type(x)) {
case PIC_TT_STRING:
return str_equal_p(pic_str_ptr(x), pic_str_ptr(y));
return str_equal_p(pic, pic_str_ptr(x), pic_str_ptr(y));
case PIC_TT_BLOB:
return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
@ -193,11 +189,14 @@ pic_bool_boolean_eq_p(pic_state *pic)
void
pic_init_bool(pic_state *pic)
{
void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
pic_defun(pic, "eq?", pic_bool_eq_p);
pic_defun(pic, "eqv?", pic_bool_eqv_p);
pic_defun(pic, "equal?", pic_bool_equal_p);
pic_defun(pic, "not", pic_bool_not);
pic_defun_vm(pic, "not", pic->rNOT, pic_bool_not);
pic_defun(pic, "boolean?", pic_bool_boolean_p);
pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);
}

542
extlib/benz/boot.c
View File

@ -14,17 +14,17 @@ my $src = <<'EOL';
"memoize on symbols"
(define cache (make-dictionary))
(lambda (sym)
(call-with-values (lambda () (dictionary-ref cache sym))
(lambda (value exists)
(if exists
(define value (dictionary-ref cache sym))
(if (not (undefined? value))
value
(begin
(define val (f sym))
(dictionary-set! cache sym val)
val))))))
val))))
(define (er-macro-transformer f)
(lambda (expr use-env mac-env)
(lambda (mac-env)
(lambda (expr use-env)
(define rename
(memoize
@ -38,7 +38,7 @@ my $src = <<'EOL';
#f
(identifier=? use-env x use-env y))))
(f expr rename compare)))
(f expr rename compare))))
(define-syntax syntax-error
(er-macro-transformer
@ -50,7 +50,8 @@ my $src = <<'EOL';
(lambda (expr r c)
(list (r 'define-syntax) (cadr expr)
(list (r 'lambda) '_
(list (r 'error) "invalid use of auxiliary syntax"))))))
(list (r 'lambda) '_
(list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'"))))))))
(define-auxiliary-syntax else)
(define-auxiliary-syntax =>)
@ -304,30 +305,15 @@ my $src = <<'EOL';
`(,(r 'begin) ,@(cdr clause)))
,(loop (cdr clauses)))))))))))
(define (dynamic-bind parameters values body)
(let* ((old-bindings
(current-dynamic-environment))
(binding
(map (lambda (parameter value)
(cons parameter (parameter value #f)))
parameters
values))
(new-bindings
(cons binding old-bindings)))
(dynamic-wind
(lambda () (current-dynamic-environment new-bindings))
body
(lambda () (current-dynamic-environment old-bindings)))))
(define-syntax parameterize
(er-macro-transformer
(lambda (form r compare)
(let ((formal (cadr form))
(body (cddr form)))
`(,(r 'dynamic-bind)
(list ,@(map car formal))
(list ,@(map cadr formal))
(,(r 'lambda) () ,@body))))))
`(,(r 'with-parameter)
(lambda ()
,@formal
,@body))))))
(define-syntax letrec-syntax
(er-macro-transformer
@ -371,23 +357,25 @@ foreach (@data) {
print "\n#endif\n\n";
print <<EOL;
const char pic_boot[] =
const char pic_boot[][80] = {
EOL
my @lines = split /\n/, $src;
my @lines = $src =~ /.{0,80}/gs;
foreach (@lines) {
s/\\/\\\\/g;
s/"/\\"/g;
print "\"$_\\n\"\n";
s/\n/\\n/g;
print "\"$_\",\n";
}
print "\"\"\n";
=pod
*/
=cut
print <<EOL;
;
};
#if 0
Local Variables:
@ -404,355 +392,151 @@ EOL
#endif
const char pic_boot[] =
"\n"
"(define-library (picrin base)\n"
"\n"
" (define (memoize f)\n"
" \"memoize on symbols\"\n"
" (define cache (make-dictionary))\n"
" (lambda (sym)\n"
" (call-with-values (lambda () (dictionary-ref cache sym))\n"
" (lambda (value exists)\n"
" (if exists\n"
" value\n"
" (begin\n"
" (define val (f sym))\n"
" (dictionary-set! cache sym val)\n"
" val))))))\n"
"\n"
" (define (er-macro-transformer f)\n"
" (lambda (expr use-env mac-env)\n"
"\n"
" (define rename\n"
" (memoize\n"
" (lambda (sym)\n"
" (make-identifier sym mac-env))))\n"
"\n"
" (define (compare x y)\n"
" (if (not (symbol? x))\n"
" #f\n"
" (if (not (symbol? y))\n"
" #f\n"
" (identifier=? use-env x use-env y))))\n"
"\n"
" (f expr rename compare)))\n"
"\n"
" (define-syntax syntax-error\n"
" (er-macro-transformer\n"
" (lambda (expr rename compare)\n"
" (apply error (cdr expr)))))\n"
"\n"
" (define-syntax define-auxiliary-syntax\n"
" (er-macro-transformer\n"
" (lambda (expr r c)\n"
" (list (r 'define-syntax) (cadr expr)\n"
" (list (r 'lambda) '_\n"
" (list (r 'error) \"invalid use of auxiliary syntax\"))))))\n"
"\n"
" (define-auxiliary-syntax else)\n"
" (define-auxiliary-syntax =>)\n"
" (define-auxiliary-syntax unquote)\n"
" (define-auxiliary-syntax unquote-splicing)\n"
"\n"
" (define-syntax let\n"
" (er-macro-transformer\n"
" (lambda (expr r compare)\n"
" (if (symbol? (cadr expr))\n"
" (begin\n"
" (define name (car (cdr expr)))\n"
" (define bindings (car (cdr (cdr expr))))\n"
" (define body (cdr (cdr (cdr expr))))\n"
" (list (r 'let) '()\n"
" (list (r 'define) name\n"
" (cons (r 'lambda) (cons (map car bindings) body)))\n"
" (cons name (map cadr bindings))))\n"
" (begin\n"
" (set! bindings (cadr expr))\n"
" (set! body (cddr expr))\n"
" (cons (cons (r 'lambda) (cons (map car bindings) body))\n"
" (map cadr bindings)))))))\n"
"\n"
" (define-syntax cond\n"
" (er-macro-transformer\n"
" (lambda (expr r compare)\n"
" (let ((clauses (cdr expr)))\n"
" (if (null? clauses)\n"
" #f\n"
" (begin\n"
" (define clause (car clauses))\n"
" (if (compare (r 'else) (car clause))\n"
" (cons (r 'begin) (cdr clause))\n"
" (if (if (>= (length clause) 2)\n"
" (compare (r '=>) (list-ref clause 1))\n"
" #f)\n"
" (list (r 'let) (list (list (r 'x) (car clause)))\n"
" (list (r 'if) (r 'x)\n"
" (list (list-ref clause 2) (r 'x))\n"
" (cons (r 'cond) (cdr clauses))))\n"
" (list (r 'if) (car clause)\n"
" (cons (r 'begin) (cdr clause))\n"
" (cons (r 'cond) (cdr clauses)))))))))))\n"
"\n"
" (define-syntax and\n"
" (er-macro-transformer\n"
" (lambda (expr r compare)\n"
" (let ((exprs (cdr expr)))\n"
" (cond\n"
" ((null? exprs)\n"
" #t)\n"
" ((= (length exprs) 1)\n"
" (car exprs))\n"
" (else\n"
" (list (r 'let) (list (list (r 'it) (car exprs)))\n"
" (list (r 'if) (r 'it)\n"
" (cons (r 'and) (cdr exprs))\n"
" (r 'it)))))))))\n"
"\n"
" (define-syntax or\n"
" (er-macro-transformer\n"
" (lambda (expr r compare)\n"
" (let ((exprs (cdr expr)))\n"
" (cond\n"
" ((null? exprs)\n"
" #t)\n"
" ((= (length exprs) 1)\n"
" (car exprs))\n"
" (else\n"
" (list (r 'let) (list (list (r 'it) (car exprs)))\n"
" (list (r 'if) (r 'it)\n"
" (r 'it)\n"
" (cons (r 'or) (cdr exprs))))))))))\n"
"\n"
" (define-syntax quasiquote\n"
" (er-macro-transformer\n"
" (lambda (form rename compare)\n"
"\n"
" (define (quasiquote? form)\n"
" (and (pair? form) (compare (car form) (rename 'quasiquote))))\n"
"\n"
" (define (unquote? form)\n"
" (and (pair? form) (compare (car form) (rename 'unquote))))\n"
"\n"
" (define (unquote-splicing? form)\n"
" (and (pair? form) (pair? (car form))\n"
" (compare (car (car form)) (rename 'unquote-splicing))))\n"
"\n"
" (define (qq depth expr)\n"
" (cond\n"
" ;; unquote\n"
" ((unquote? expr)\n"
" (if (= depth 1)\n"
" (car (cdr expr))\n"
" (list (rename 'list)\n"
" (list (rename 'quote) (rename 'unquote))\n"
" (qq (- depth 1) (car (cdr expr))))))\n"
" ;; unquote-splicing\n"
" ((unquote-splicing? expr)\n"
" (if (= depth 1)\n"
" (list (rename 'append)\n"
" (car (cdr (car expr)))\n"
" (qq depth (cdr expr)))\n"
" (list (rename 'cons)\n"
" (list (rename 'list)\n"
" (list (rename 'quote) (rename 'unquote-splicing))\n"
" (qq (- depth 1) (car (cdr (car expr)))))\n"
" (qq depth (cdr expr)))))\n"
" ;; quasiquote\n"
" ((quasiquote? expr)\n"
" (list (rename 'list)\n"
" (list (rename 'quote) (rename 'quasiquote))\n"
" (qq (+ depth 1) (car (cdr expr)))))\n"
" ;; list\n"
" ((pair? expr)\n"
" (list (rename 'cons)\n"
" (qq depth (car expr))\n"
" (qq depth (cdr expr))))\n"
" ;; vector\n"
" ((vector? expr)\n"
" (list (rename 'list->vector) (qq depth (vector->list expr))))\n"
" ;; simple datum\n"
" (else\n"
" (list (rename 'quote) expr))))\n"
"\n"
" (let ((x (cadr form)))\n"
" (qq 1 x)))))\n"
"\n"
" (define-syntax let*\n"
" (er-macro-transformer\n"
" (lambda (form r compare)\n"
" (let ((bindings (cadr form))\n"
" (body (cddr form)))\n"
" (if (null? bindings)\n"
" `(,(r 'let) () ,@body)\n"
" `(,(r 'let) ((,(caar bindings)\n"
" ,@(cdar bindings)))\n"
" (,(r 'let*) (,@(cdr bindings))\n"
" ,@body)))))))\n"
"\n"
" (define-syntax letrec*\n"
" (er-macro-transformer\n"
" (lambda (form r compare)\n"
" (let ((bindings (cadr form))\n"
" (body (cddr form)))\n"
" (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n"
" (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n"
" `(,(r 'let) (,@vars)\n"
" ,@initials\n"
" ,@body))))))\n"
"\n"
" (define-syntax letrec\n"
" (er-macro-transformer\n"
" (lambda (form rename compare)\n"
" `(,(rename 'letrec*) ,@(cdr form)))))\n"
"\n"
" (define-syntax let*-values\n"
" (er-macro-transformer\n"
" (lambda (form r c)\n"
" (let ((formals (cadr form)))\n"
" (if (null? formals)\n"
" `(,(r 'let) () ,@(cddr form))\n"
" `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n"
" (,(r 'lambda) (,@(caar formals))\n"
" (,(r 'let*-values) (,@(cdr formals))\n"
" ,@(cddr form)))))))))\n"
"\n"
" (define-syntax let-values\n"
" (er-macro-transformer\n"
" (lambda (form r c)\n"
" `(,(r 'let*-values) ,@(cdr form)))))\n"
"\n"
" (define-syntax define-values\n"
" (er-macro-transformer\n"
" (lambda (form r compare)\n"
" (let ((formal (cadr form))\n"
" (exprs (cddr form)))\n"
" `(,(r 'begin)\n"
" ,@(let loop ((formal formal))\n"
" (if (not (pair? formal))\n"
" (if (symbol? formal)\n"
" `((,(r 'define) ,formal #f))\n"
" '())\n"
" `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))))\n"
" (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n"
" (,(r 'lambda) ,(r 'args)\n"
" ,@(let loop ((formal formal) (args (r 'args)))\n"
" (if (not (pair? formal))\n"
" (if (symbol? formal)\n"
" `((,(r 'set!) ,formal ,args))\n"
" '())\n"
" `((,(r 'set!) ,(car formal) (,(r 'car) ,args))\n"
" ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))\n"
"\n"
" (define-syntax do\n"
" (er-macro-transformer\n"
" (lambda (form r compare)\n"
" (let ((bindings (car (cdr form)))\n"
" (finish (car (cdr (cdr form))))\n"
" (body (cdr (cdr (cdr form)))))\n"
" `(,(r 'let) ,(r 'loop) ,(map (lambda (x)\n"
" (list (car x) (cadr x)))\n"
" bindings)\n"
" (,(r 'if) ,(car finish)\n"
" (,(r 'begin) ,@(cdr finish))\n"
" (,(r 'begin) ,@body\n"
" (,(r 'loop) ,@(map (lambda (x)\n"
" (if (null? (cddr x))\n"
" (car x)\n"
" (car (cddr x))))\n"
" bindings)))))))))\n"
"\n"
" (define-syntax when\n"
" (er-macro-transformer\n"
" (lambda (expr rename compare)\n"
" (let ((test (cadr expr))\n"
" (body (cddr expr)))\n"
" `(,(rename 'if) ,test\n"
" (,(rename 'begin) ,@body)\n"
" #f)))))\n"
"\n"
" (define-syntax unless\n"
" (er-macro-transformer\n"
" (lambda (expr rename compare)\n"
" (let ((test (cadr expr))\n"
" (body (cddr expr)))\n"
" `(,(rename 'if) ,test\n"
" #f\n"
" (,(rename 'begin) ,@body))))))\n"
"\n"
" (define-syntax case\n"
" (er-macro-transformer\n"
" (lambda (expr r compare)\n"
" (let ((key (cadr expr))\n"
" (clauses (cddr expr)))\n"
" `(,(r 'let) ((,(r 'key) ,key))\n"
" ,(let loop ((clauses clauses))\n"
" (if (null? clauses)\n"
" #f\n"
" (begin\n"
" (define clause (car clauses))\n"
" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n"
" '#t\n"
" `(,(r 'or)\n"
" ,@(map (lambda (x)\n"
" `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n"
" (car clause))))\n"
" ,(if (compare (r '=>) (list-ref clause 1))\n"
" `(,(list-ref clause 2) ,(r 'key))\n"
" `(,(r 'begin) ,@(cdr clause)))\n"
" ,(loop (cdr clauses)))))))))))\n"
"\n"
" (define (dynamic-bind parameters values body)\n"
" (let* ((old-bindings\n"
" (current-dynamic-environment))\n"
" (binding\n"
" (map (lambda (parameter value)\n"
" (cons parameter (parameter value #f)))\n"
" parameters\n"
" values))\n"
" (new-bindings\n"
" (cons binding old-bindings)))\n"
" (dynamic-wind\n"
" (lambda () (current-dynamic-environment new-bindings))\n"
" body\n"
" (lambda () (current-dynamic-environment old-bindings)))))\n"
"\n"
" (define-syntax parameterize\n"
" (er-macro-transformer\n"
" (lambda (form r compare)\n"
" (let ((formal (cadr form))\n"
" (body (cddr form)))\n"
" `(,(r 'dynamic-bind)\n"
" (list ,@(map car formal))\n"
" (list ,@(map cadr formal))\n"
" (,(r 'lambda) () ,@body))))))\n"
"\n"
" (define-syntax letrec-syntax\n"
" (er-macro-transformer\n"
" (lambda (form r c)\n"
" (let ((formal (car (cdr form)))\n"
" (body (cdr (cdr form))))\n"
" `(let ()\n"
" ,@(map (lambda (x)\n"
" `(,(r 'define-syntax) ,(car x) ,(cadr x)))\n"
" formal)\n"
" ,@body)))))\n"
"\n"
" (define-syntax let-syntax\n"
" (er-macro-transformer\n"
" (lambda (form r c)\n"
" `(,(r 'letrec-syntax) ,@(cdr form)))))\n"
"\n"
" (export let let* letrec letrec*\n"
" let-values let*-values define-values\n"
" quasiquote unquote unquote-splicing\n"
" and or\n"
" cond case else =>\n"
" do when unless\n"
" parameterize\n"
" let-syntax letrec-syntax\n"
" syntax-error))\n"
;
const char pic_boot[][80] = {
"\n(define-library (picrin base)\n\n (define (memoize f)\n \"memoize on symbols\"\n ",
" (define cache (make-dictionary))\n (lambda (sym)\n (define value (dicti",
"onary-ref cache sym))\n (if (not (undefined? value))\n value\n ",
" (begin\n (define val (f sym))\n (dictionary-set! cache sy",
"m val)\n val))))\n\n (define (er-macro-transformer f)\n (lambda (mac-",
"env)\n (lambda (expr use-env)\n\n (define rename\n (memoize\n ",
" (lambda (sym)\n (make-identifier sym mac-env))))\n\n (de",
"fine (compare x y)\n (if (not (symbol? x))\n #f\n ",
" (if (not (symbol? y))\n #f\n (identifier=? use",
"-env x use-env y))))\n\n (f expr rename compare))))\n\n (define-syntax synta",
"x-error\n (er-macro-transformer\n (lambda (expr rename compare)\n (app",
"ly error (cdr expr)))))\n\n (define-syntax define-auxiliary-syntax\n (er-macro-",
"transformer\n (lambda (expr r c)\n (list (r 'define-syntax) (cadr expr)\n",
" (list (r 'lambda) '_\n (list (r 'lambda) '_\n ",
" (list (r 'error) (list (r 'string-append) \"invalid use of aux",
"iliary syntax: '\" (symbol->string (cadr expr)) \"'\"))))))))\n\n (define-auxiliary-",
"syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliary-syntax unquote)\n",
" (define-auxiliary-syntax unquote-splicing)\n\n (define-syntax let\n (er-macro",
"-transformer\n (lambda (expr r compare)\n (if (symbol? (cadr expr))\n ",
" (begin\n (define name (car (cdr expr)))\n (defi",
"ne bindings (car (cdr (cdr expr))))\n (define body (cdr (cdr (cdr",
" expr))))\n (list (r 'let) '()\n (list (r 'define) n",
"ame\n (cons (r 'lambda) (cons (map car bindings) body)))\n",
" (cons name (map cadr bindings))))\n (begin\n ",
" (set! bindings (cadr expr))\n (set! body (cddr expr))\n ",
" (cons (cons (r 'lambda) (cons (map car bindings) body))\n (ma",
"p cadr bindings)))))))\n\n (define-syntax cond\n (er-macro-transformer\n (la",
"mbda (expr r compare)\n (let ((clauses (cdr expr)))\n (if (null? cla",
"uses)\n #f\n (begin\n (define clause (car cla",
"uses))\n (if (compare (r 'else) (car clause))\n (c",
"ons (r 'begin) (cdr clause))\n (if (if (>= (length clause) 2)\n ",
" (compare (r '=>) (list-ref clause 1))\n ",
" #f)\n (list (r 'let) (list (list (r 'x) (car cla",
"use)))\n (list (r 'if) (r 'x)\n ",
" (list (list-ref clause 2) (r 'x))\n ",
" (cons (r 'cond) (cdr clauses))))\n (list (r 'if) (car clau",
"se)\n (cons (r 'begin) (cdr clause))\n ",
" (cons (r 'cond) (cdr clauses)))))))))))\n\n (define-syntax and\n (",
"er-macro-transformer\n (lambda (expr r compare)\n (let ((exprs (cdr expr",
")))\n (cond\n ((null? exprs)\n #t)\n ((= (length",
" exprs) 1)\n (car exprs))\n (else\n (list (r 'let) (li",
"st (list (r 'it) (car exprs)))\n (list (r 'if) (r 'it)\n ",
" (cons (r 'and) (cdr exprs))\n (r 'it)))))))))\n",
"\n (define-syntax or\n (er-macro-transformer\n (lambda (expr r compare)\n ",
" (let ((exprs (cdr expr)))\n (cond\n ((null? exprs)\n ",
" #t)\n ((= (length exprs) 1)\n (car exprs))\n (else\n ",
" (list (r 'let) (list (list (r 'it) (car exprs)))\n (list ",
"(r 'if) (r 'it)\n (r 'it)\n (cons (r '",
"or) (cdr exprs))))))))))\n\n (define-syntax quasiquote\n (er-macro-transformer\n",
" (lambda (form rename compare)\n\n (define (quasiquote? form)\n (",
"and (pair? form) (compare (car form) (rename 'quasiquote))))\n\n (define (un",
"quote? form)\n (and (pair? form) (compare (car form) (rename 'unquote))))",
"\n\n (define (unquote-splicing? form)\n (and (pair? form) (pair? (car",
" form))\n (compare (car (car form)) (rename 'unquote-splicing))))\n\n ",
" (define (qq depth expr)\n (cond\n ;; unquote\n ((un",
"quote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
" (list (rename 'list)\n (list (rename 'quote) (rename '",
"unquote))\n (qq (- depth 1) (car (cdr expr))))))\n ;;",
" unquote-splicing\n ((unquote-splicing? expr)\n (if (= depth 1)",
"\n (list (rename 'append)\n (car (cdr (car expr)",
"))\n (qq depth (cdr expr)))\n (list (rename 'con",
"s)\n (list (rename 'list)\n (list (r",
"ename 'quote) (rename 'unquote-splicing))\n (qq (- dept",
"h 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
" ;; quasiquote\n ((quasiquote? expr)\n (list (rename 'list",
")\n (list (rename 'quote) (rename 'quasiquote))\n ",
"(qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ",
" (list (rename 'cons)\n (qq depth (car expr))\n ",
" (qq depth (cdr expr))))\n ;; vector\n ((vector? expr)\n ",
" (list (rename 'list->vector) (qq depth (vector->list expr))))\n ;",
"; simple datum\n (else\n (list (rename 'quote) expr))))\n\n ",
" (let ((x (cadr form)))\n (qq 1 x)))))\n\n (define-syntax let*\n (er-mac",
"ro-transformer\n (lambda (form r compare)\n (let ((bindings (cadr form))",
"\n (body (cddr form)))\n (if (null? bindings)\n `(,",
"(r 'let) () ,@body)\n `(,(r 'let) ((,(caar bindings)\n ",
" ,@(cdar bindings)))\n (,(r 'let*) (,@(cdr bindings))\n ",
" ,@body)))))))\n\n (define-syntax letrec*\n (er-macro-transformer\n ",
" (lambda (form r compare)\n (let ((bindings (cadr form))\n (b",
"ody (cddr form)))\n (let ((vars (map (lambda (v) `(,v #f)) (map car bindi",
"ngs)))\n (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n",
" `(,(r 'let) (,@vars)\n ,@initials\n ,@body)))))",
")\n\n (define-syntax letrec\n (er-macro-transformer\n (lambda (form rename c",
"ompare)\n `(,(rename 'letrec*) ,@(cdr form)))))\n\n (define-syntax let*-valu",
"es\n (er-macro-transformer\n (lambda (form r c)\n (let ((formals (cadr",
" form)))\n (if (null? formals)\n `(,(r 'let) () ,@(cddr form))",
"\n `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n ",
" (,(r 'lambda) (,@(caar formals))\n (,(r 'let*-values) (,@",
"(cdr formals))\n ,@(cddr form)))))))))\n\n (define-syntax let-valu",
"es\n (er-macro-transformer\n (lambda (form r c)\n `(,(r 'let*-values) ",
",@(cdr form)))))\n\n (define-syntax define-values\n (er-macro-transformer\n ",
"(lambda (form r compare)\n (let ((formal (cadr form))\n (exprs ",
"(cddr form)))\n `(,(r 'begin)\n ,@(let loop ((formal formal))\n ",
" (if (not (pair? formal))\n (if (symbol? formal)",
"\n `((,(r 'define) ,formal #f))\n '(",
"))\n `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))",
"))\n (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n (",
",(r 'lambda) ,(r 'args)\n ,@(let loop ((formal formal) (args (r 'a",
"rgs)))\n (if (not (pair? formal))\n (if ",
"(symbol? formal)\n `((,(r 'set!) ,formal ,args))\n ",
" '())\n `((,(r 'set!) ,(car formal) ",
"(,(r 'car) ,args))\n ,@(loop (cdr formal) `(,(r 'cdr) ,a",
"rgs))))))))))))\n\n (define-syntax do\n (er-macro-transformer\n (lambda (for",
"m r compare)\n (let ((bindings (car (cdr form)))\n (finish (ca",
"r (cdr (cdr form))))\n (body (cdr (cdr (cdr form)))))\n `(",
",(r 'let) ,(r 'loop) ,(map (lambda (x)\n (",
"list (car x) (cadr x)))\n bindings)\n ",
" (,(r 'if) ,(car finish)\n (,(r 'begin) ,@(cdr finish))\n ",
"(,(r 'begin) ,@body\n (,(r 'loop) ,@(map (lambda (x)\n ",
" (if (null? (cddr x))\n (ca",
"r x)\n (car (cddr x))))\n ",
" bindings)))))))))\n\n (define-syntax when\n (er-macro-transformer\n ",
" (lambda (expr rename compare)\n (let ((test (cadr expr))\n (",
"body (cddr expr)))\n `(,(rename 'if) ,test\n (,(rename 'begin",
") ,@body)\n #f)))))\n\n (define-syntax unless\n (er-macro-transform",
"er\n (lambda (expr rename compare)\n (let ((test (cadr expr))\n ",
" (body (cddr expr)))\n `(,(rename 'if) ,test\n #f\n ",
" (,(rename 'begin) ,@body))))))\n\n (define-syntax case\n (er-macro-transfo",
"rmer\n (lambda (expr r compare)\n (let ((key (cadr expr))\n (",
"clauses (cddr expr)))\n `(,(r 'let) ((,(r 'key) ,key))\n ,(let ",
"loop ((clauses clauses))\n (if (null? clauses)\n #",
"f\n (begin\n (define clause (car clauses))\n ",
" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n ",
" '#t\n `(,(r 'or)\n ",
" ,@(map (lambda (x)\n ",
" `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n ",
" (car clause))))\n ,(if (com",
"pare (r '=>) (list-ref clause 1))\n `(,(list-ref claus",
"e 2) ,(r 'key))\n `(,(r 'begin) ,@(cdr clause)))\n ",
" ,(loop (cdr clauses)))))))))))\n\n (define-syntax parameterize\n",
" (er-macro-transformer\n (lambda (form r compare)\n (let ((formal (ca",
"dr form))\n (body (cddr form)))\n `(,(r 'with-parameter)\n ",
" (lambda ()\n ,@formal\n ,@body))))))\n\n (define-synt",
"ax letrec-syntax\n (er-macro-transformer\n (lambda (form r c)\n (let (",
"(formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(let",
" ()\n ,@(map (lambda (x)\n `(,(r 'define-syntax) ,(",
"car x) ,(cadr x)))\n formal)\n ,@body)))))\n\n (define",
"-syntax let-syntax\n (er-macro-transformer\n (lambda (form r c)\n `(,(",
"r 'letrec-syntax) ,@(cdr form)))))\n\n (export let let* letrec letrec*\n ",
"let-values let*-values define-values\n quasiquote unquote unquote-splici",
"ng\n and or\n cond case else =>\n do when unless\n ",
" parameterize\n let-syntax letrec-syntax\n syntax-error))\n\n",
"",
""
};
#if 0
Local Variables:

764
extlib/benz/codegen.c
View File

File diff suppressed because it is too large Load Diff

127
extlib/benz/cont.c
View File

@ -3,14 +3,9 @@
*/
#include "picrin.h"
#include "picrin/proc.h"
#include "picrin/cont.h"
#include "picrin/pair.h"
#include "picrin/data.h"
#include "picrin/error.h"
void
pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there)
pic_wind(pic_state *pic, pic_checkpoint *here, pic_checkpoint *there)
{
if (here == there)
return;
@ -28,23 +23,23 @@ pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there)
pic_value
pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
{
struct pic_winder *here;
pic_checkpoint *here;
pic_value val;
if (in != NULL) {
pic_apply0(pic, in); /* enter */
}
here = pic->wind;
pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
pic->wind->prev = here;
pic->wind->depth = here->depth + 1;
pic->wind->in = in;
pic->wind->out = out;
here = pic->cp;
pic->cp = pic_malloc(pic, sizeof(pic_checkpoint));
pic->cp->prev = here;
pic->cp->depth = here->depth + 1;
pic->cp->in = in;
pic->cp->out = out;
val = pic_apply0(pic, thunk);
pic->wind = here;
pic->cp = here;
if (out != NULL) {
pic_apply0(pic, out); /* exit */
@ -54,43 +49,51 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st
}
void
pic_save_point(pic_state *pic, struct pic_escape *escape)
pic_save_point(pic_state *pic, struct pic_cont *cont)
{
escape->valid = true;
cont->jmp.prev = pic->jmp;
pic->jmp = &cont->jmp;
/* save runtime context */
escape->wind = pic->wind;
escape->sp_offset = pic->sp - pic->stbase;
escape->ci_offset = pic->ci - pic->cibase;
escape->xp_offset = pic->xp - pic->xpbase;
escape->arena_idx = pic->arena_idx;
escape->ip = pic->ip;
cont->cp = pic->cp;
cont->sp_offset = pic->sp - pic->stbase;
cont->ci_offset = pic->ci - pic->cibase;
cont->xp_offset = pic->xp - pic->xpbase;
cont->arena_idx = pic->arena_idx;
cont->ip = pic->ip;
cont->ptable = pic->ptable;
escape->results = pic_undef_value();
cont->results = pic_undef_value();
}
void
pic_load_point(pic_state *pic, struct pic_escape *escape)
pic_load_point(pic_state *pic, struct pic_cont *cont)
{
if (! escape->valid) {
pic_jmpbuf *jmp;
for (jmp = pic->jmp; jmp != NULL; jmp = jmp->prev) {
if (jmp == &cont->jmp) {
break;
}
}
if (jmp == NULL) {
pic_errorf(pic, "calling dead escape continuation");
}
pic_wind(pic, pic->wind, escape->wind);
pic_wind(pic, pic->cp, cont->cp);
/* load runtime context */
pic->wind = escape->wind;
pic->sp = pic->stbase + escape->sp_offset;
pic->ci = pic->cibase + escape->ci_offset;
pic->xp = pic->xpbase + escape->xp_offset;
pic->arena_idx = escape->arena_idx;
pic->ip = escape->ip;
escape->valid = false;
pic->cp = cont->cp;
pic->sp = pic->stbase + cont->sp_offset;
pic->ci = pic->cibase + cont->ci_offset;
pic->xp = pic->xpbase + cont->xp_offset;
pic->arena_idx = cont->arena_idx;
pic->ip = cont->ip;
pic->ptable = cont->ptable;
}
static pic_value
escape_call(pic_state *pic)
cont_call(pic_state *pic)
{
size_t argc;
pic_value *argv;
@ -98,46 +101,51 @@ escape_call(pic_state *pic)
pic_get_args(pic, "*", &argc, &argv);
e = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
e = pic_data_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "escape"));
((struct pic_cont *)e->data)->results = pic_list_by_array(pic, argc, argv);
pic_load_point(pic, e->data);
longjmp(((struct pic_escape *)e->data)->jmp, 1);
PIC_LONGJMP(pic, ((struct pic_cont *)e->data)->jmp.buf, 1);
PIC_UNREACHABLE();
}
struct pic_proc *
pic_make_econt(pic_state *pic, struct pic_escape *escape)
pic_make_cont(pic_state *pic, struct pic_cont *cont)
{
static const pic_data_type escape_type = { "escape", pic_free, NULL };
struct pic_proc *cont;
static const pic_data_type cont_type = { "cont", pic_free, NULL };
struct pic_proc *c;
struct pic_data *e;
cont = pic_make_proc(pic, escape_call, "<escape-procedure>");
c = pic_make_proc(pic, cont_call, "<cont-procedure>");
e = pic_data_alloc(pic, &escape_type, escape);
e = pic_data_alloc(pic, &cont_type, cont);
/* save the escape continuation in proc */
pic_attr_set(pic, pic_obj_value(cont), "@@escape", pic_obj_value(e));
pic_proc_env_set(pic, c, "escape", pic_obj_value(e));
return cont;
return c;
}
pic_value
pic_escape(pic_state *pic, struct pic_proc *proc)
pic_callcc(pic_state *pic, struct pic_proc *proc)
{
struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape));
struct pic_cont *cont = pic_malloc(pic, sizeof(struct pic_cont));
pic_save_point(pic, escape);
pic_save_point(pic, cont);
if (setjmp(escape->jmp)) {
return pic_values_by_list(pic, escape->results);
if (PIC_SETJMP(pic, cont->jmp.buf)) {
pic->jmp = pic->jmp->prev;
return pic_values_by_list(pic, cont->results);
}
else {
pic_value val;
val = pic_apply1(pic, proc, pic_obj_value(pic_make_econt(pic, escape)));
val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, cont)));
escape->valid = false;
pic->jmp = pic->jmp->prev;
return val;
}
@ -189,22 +197,22 @@ pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
}
pic->ci->retc = (int)argc;
return argc == 0 ? pic_none_value() : pic->sp[0];
return argc == 0 ? pic_undef_value() : pic->sp[0];
}
pic_value
pic_values_by_list(pic_state *pic, pic_value list)
{
pic_value v;
pic_value v, it;
int i;
i = 0;
pic_for_each (v, list) {
pic_for_each (v, list, it) {
pic->sp[i++] = v;
}
pic->ci->retc = i;
return pic_nil_p(list) ? pic_none_value() : pic->sp[0];
return pic_nil_p(list) ? pic_undef_value() : pic->sp[0];
}
size_t
@ -231,7 +239,7 @@ pic_cont_callcc(pic_state *pic)
pic_get_args(pic, "l", &cb);
return pic_escape(pic, cb);
return pic_callcc(pic, cb);
}
static pic_value
@ -274,9 +282,12 @@ pic_cont_call_with_values(pic_state *pic)
void
pic_init_cont(pic_state *pic)
{
void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
pic_defun(pic, "call/cc", pic_cont_callcc);
pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
pic_defun(pic, "values", pic_cont_values);
pic_defun(pic, "call-with-values", pic_cont_call_with_values);
pic_defun_vm(pic, "values", pic->rVALUES, pic_cont_values);
pic_defun_vm(pic, "call-with-values", pic->rCALL_WITH_VALUES, pic_cont_call_with_values);
}

1
extlib/benz/data.c
View File

@ -1,5 +1,4 @@
#include "picrin.h"
#include "picrin/data.h"
struct pic_data *
pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata)

38
extlib/benz/debug.c
View File

@ -3,9 +3,6 @@
*/
#include "picrin.h"
#include "picrin/string.h"
#include "picrin/error.h"
#include "picrin/proc.h"
pic_str *
pic_get_backtrace(pic_state *pic)
@ -19,13 +16,13 @@ pic_get_backtrace(pic_state *pic)
for (ci = pic->ci; ci != pic->cibase; --ci) {
struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);
trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " at "));
trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " at "));
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));
if (pic_proc_func_p(proc)) {
trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
} else if (pic_proc_irep_p(proc)) {
trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */
}
}
@ -36,34 +33,27 @@ pic_get_backtrace(pic_state *pic)
}
void
pic_print_backtrace(pic_state *pic)
pic_print_backtrace(pic_state *pic, xFILE *file)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_str *trace;
assert(! pic_undef_p(pic->err));
assert(! pic_invalid_p(pic->err));
if (! pic_error_p(pic->err)) {
trace = pic_format(pic, "raised: ~s", pic->err);
xfprintf(file, "raise: ");
pic_fwrite(pic, pic->err, file);
} else {
struct pic_error *e;
e = pic_error_ptr(pic->err);
if (e->type != pic_intern_cstr(pic, "")) {
trace = pic_format(pic, "~s ", pic_sym_value(e->type));
} else {
trace = pic_make_str(pic, NULL, 0);
pic_fwrite(pic, pic_obj_value(e->type), file);
xfprintf(file, " ");
}
trace = pic_strcat(pic, trace, pic_format(pic, "error: ~s", pic_obj_value(e->msg)));
xfprintf(file, "error: ");
pic_fwrite(pic, pic_obj_value(e->msg), file);
xfprintf(file, "\n");
/* TODO: print error irritants */
trace = pic_strcat(pic, trace, pic_make_str(pic, "\n", 1));
trace = pic_strcat(pic, trace, e->stack);
xfputs(pic_str_cstr(pic, e->stack), file);
}
/* print! */
xfprintf(xstderr, "%s", pic_str_cstr(trace));
pic_gc_arena_restore(pic, ai);
}

95
extlib/benz/dict.c
View File

@ -3,10 +3,6 @@
*/
#include "picrin.h"
#include "picrin/dict.h"
#include "picrin/cont.h"
#include "picrin/pair.h"
#include "picrin/error.h"
struct pic_dict *
pic_make_dict(pic_state *pic)
@ -14,55 +10,49 @@ pic_make_dict(pic_state *pic)
struct pic_dict *dict;
dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
xh_init_int(&dict->hash, sizeof(pic_value));
xh_init_ptr(&dict->hash, sizeof(pic_value));
return dict;
}
pic_value
pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym key)
pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym *key)
{
xh_entry *e;
e = xh_get_int(&dict->hash, key);
e = xh_get_ptr(&dict->hash, key);
if (! e) {
pic_errorf(pic, "element not found for a key: ~s", pic_sym_value(key));
pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key));
}
return xh_val(e, pic_value);
}
void
pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_sym key, pic_value val)
pic_dict_set(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key, pic_value val)
{
PIC_UNUSED(pic);
xh_put_int(&dict->hash, key, &val);
xh_put_ptr(&dict->hash, key, &val);
}
size_t
pic_dict_size(pic_state *pic, struct pic_dict *dict)
pic_dict_size(pic_state PIC_UNUSED(*pic), struct pic_dict *dict)
{
PIC_UNUSED(pic);
return dict->hash.count;
}
bool
pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key)
pic_dict_has(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key)
{
PIC_UNUSED(pic);
return xh_get_int(&dict->hash, key) != NULL;
return xh_get_ptr(&dict->hash, key) != NULL;
}
void
pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key)
pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym *key)
{
if (xh_get_int(&dict->hash, key) == NULL) {
pic_errorf(pic, "no slot named ~s found in dictionary", pic_sym_value(key));
if (xh_get_ptr(&dict->hash, key) == NULL) {
pic_errorf(pic, "no slot named ~s found in dictionary", pic_obj_value(key));
}
xh_del_int(&dict->hash, key);
xh_del_ptr(&dict->hash, key);
}
static pic_value
@ -90,7 +80,7 @@ pic_dict_dictionary(pic_state *pic)
for (i = 0; i < argc; i += 2) {
pic_assert_type(pic, argv[i], sym);
pic_dict_set(pic, dict, pic_sym(argv[i]), argv[i+1]);
pic_dict_set(pic, dict, pic_sym_ptr(argv[i]), argv[i+1]);
}
return pic_obj_value(dict);
@ -110,42 +100,34 @@ static pic_value
pic_dict_dictionary_ref(pic_state *pic)
{
struct pic_dict *dict;
pic_sym key;
pic_sym *key;
pic_get_args(pic, "dm", &dict, &key);
if (pic_dict_has(pic, dict, key)) {
return pic_values2(pic, pic_dict_ref(pic, dict, key), pic_true_value());
} else {
return pic_values2(pic, pic_none_value(), pic_false_value());
if (! pic_dict_has(pic, dict, key)) {
return pic_undef_value();
}
return pic_dict_ref(pic, dict, key);
}
static pic_value
pic_dict_dictionary_set(pic_state *pic)
{
struct pic_dict *dict;
pic_sym key;
pic_sym *key;
pic_value val;
pic_get_args(pic, "dmo", &dict, &key, &val);
pic_dict_set(pic, dict, key, val);
return pic_none_value();
}
static pic_value
pic_dict_dictionary_del(pic_state *pic)
{
struct pic_dict *dict;
pic_sym key;
pic_get_args(pic, "dm", &dict, &key);
if (pic_undef_p(val)) {
if (pic_dict_has(pic, dict, key)) {
pic_dict_del(pic, dict, key);
return pic_none_value();
}
}
else {
pic_dict_set(pic, dict, key, val);
}
return pic_undef_value();
}
static pic_value
@ -169,7 +151,7 @@ pic_dict_dictionary_map(pic_state *pic)
pic_get_args(pic, "l*", &proc, &argc, &args);
it = pic_alloc(pic, argc * sizeof(xh_entry));
it = pic_malloc(pic, argc * sizeof(xh_entry));
for (i = 0; i < argc; ++i) {
if (! pic_dict_p(args[i])) {
pic_free(pic, it);
@ -186,7 +168,7 @@ pic_dict_dictionary_map(pic_state *pic)
if (it[i] == NULL) {
break;
}
pic_push(pic, pic_sym_value(xh_key(it[i], pic_sym)), arg);
pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg);
it[i] = xh_next(it[i]);
}
if (i != argc) {
@ -216,7 +198,7 @@ pic_dict_dictionary_for_each(pic_state *pic)
pic_get_args(pic, "l*", &proc, &argc, &args);
it = pic_alloc(pic, argc * sizeof(xh_entry));
it = pic_malloc(pic, argc * sizeof(xh_entry));
for (i = 0; i < argc; ++i) {
if (! pic_dict_p(args[i])) {
pic_free(pic, it);
@ -232,7 +214,7 @@ pic_dict_dictionary_for_each(pic_state *pic)
if (it[i] == NULL) {
break;
}
pic_push(pic, pic_sym_value(xh_key(it[i], pic_sym)), arg);
pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg);
it[i] = xh_next(it[i]);
}
if (i != argc) {
@ -248,7 +230,7 @@ pic_dict_dictionary_for_each(pic_state *pic)
pic_free(pic, it);
return pic_none_value();
return pic_undef_value();
}
static pic_value
@ -261,7 +243,7 @@ pic_dict_dictionary_to_alist(pic_state *pic)
pic_get_args(pic, "d", &dict);
for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
item = pic_cons(pic, pic_sym_value(xh_key(it, pic_sym)), xh_val(it, pic_value));
item = pic_cons(pic, pic_obj_value(xh_key(it, pic_sym *)), xh_val(it, pic_value));
pic_push(pic, item, alist);
}
@ -272,15 +254,15 @@ static pic_value
pic_dict_alist_to_dictionary(pic_state *pic)
{
struct pic_dict *dict;
pic_value alist, e;
pic_value alist, e, it;
pic_get_args(pic, "o", &alist);
dict = pic_make_dict(pic);
pic_for_each (e, pic_reverse(pic, alist)) {
pic_for_each (e, pic_reverse(pic, alist), it) {
pic_assert_type(pic, pic_car(pic, e), sym);
pic_dict_set(pic, dict, pic_sym(pic_car(pic, e)), pic_cdr(pic, e));
pic_dict_set(pic, dict, pic_sym_ptr(pic_car(pic, e)), pic_cdr(pic, e));
}
return pic_obj_value(dict);
@ -296,7 +278,7 @@ pic_dict_dictionary_to_plist(pic_state *pic)
pic_get_args(pic, "d", &dict);
for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
pic_push(pic, pic_sym_value(xh_key(it, pic_sym)), plist);
pic_push(pic, pic_obj_value(xh_key(it, pic_sym *)), plist);
pic_push(pic, xh_val(it, pic_value), plist);
}
@ -315,7 +297,7 @@ pic_dict_plist_to_dictionary(pic_state *pic)
for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) {
pic_assert_type(pic, pic_cadr(pic, e), sym);
pic_dict_set(pic, dict, pic_sym(pic_cadr(pic, e)), pic_car(pic, e));
pic_dict_set(pic, dict, pic_sym_ptr(pic_cadr(pic, e)), pic_car(pic, e));
}
return pic_obj_value(dict);
@ -329,7 +311,6 @@ pic_init_dict(pic_state *pic)
pic_defun(pic, "dictionary", pic_dict_dictionary);
pic_defun(pic, "dictionary-ref", pic_dict_dictionary_ref);
pic_defun(pic, "dictionary-set!", pic_dict_dictionary_set);
pic_defun(pic, "dictionary-delete!", pic_dict_dictionary_del);
pic_defun(pic, "dictionary-size", pic_dict_dictionary_size);
pic_defun(pic, "dictionary-map", pic_dict_dictionary_map);
pic_defun(pic, "dictionary-for-each", pic_dict_dictionary_for_each);

101
extlib/benz/error.c
View File

@ -3,20 +3,18 @@
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/proc.h"
#include "picrin/cont.h"
#include "picrin/data.h"
#include "picrin/string.h"
#include "picrin/error.h"
void
pic_panic(pic_state *pic, const char *msg)
pic_panic(pic_state PIC_UNUSED(*pic), const char *msg)
{
PIC_UNUSED(pic);
extern void abort();
#if DEBUG
fprintf(stderr, "abort: %s\n", msg);
abort();
#else
(void)msg;
#endif
PIC_ABORT(pic);
}
void
@ -29,7 +27,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
err_line = pic_xvformat(pic, fmt, ap);
va_end(ap);
fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))));
xfprintf(pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line))));
}
void
@ -43,7 +41,7 @@ pic_errorf(pic_state *pic, const char *fmt, ...)
err_line = pic_xvformat(pic, fmt, ap);
va_end(ap);
msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)));
msg = pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line)));
irrs = pic_cdr(pic, err_line);
pic_error(pic, msg, irrs);
@ -54,7 +52,7 @@ pic_errmsg(pic_state *pic)
{
pic_str *str;
assert(! pic_undef_p(pic->err));
assert(! pic_invalid_p(pic->err));
if (! pic_error_p(pic->err)) {
str = pic_format(pic, "~s", pic->err);
@ -62,11 +60,11 @@ pic_errmsg(pic_state *pic)
str = pic_error_ptr(pic->err)->msg;
}
return pic_str_cstr(str);
return pic_str_cstr(pic, str);
}
static pic_value
native_exception_handler(pic_state *pic)
pic_value
pic_native_exception_handler(pic_state *pic)
{
pic_value err;
struct pic_proc *cont;
@ -75,7 +73,7 @@ native_exception_handler(pic_state *pic)
pic->err = err;
cont = pic_proc_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
cont = pic_proc_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "cont"));
pic_apply1(pic, cont, pic_false_value());
@ -83,18 +81,11 @@ native_exception_handler(pic_state *pic)
}
void
pic_push_try(pic_state *pic, struct pic_escape *escape)
pic_push_handler(pic_state *pic, struct pic_proc *handler)
{
struct pic_proc *cont, *handler;
size_t xp_len;
ptrdiff_t xp_offset;
cont = pic_make_econt(pic, escape);
handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)");
pic_attr_set(pic, pic_obj_value(handler), "@@escape", pic_obj_value(cont));
if (pic->xp >= pic->xpend) {
xp_len = (size_t)(pic->xpend - pic->xpbase) * 2;
xp_offset = pic->xp - pic->xpbase;
@ -106,26 +97,18 @@ pic_push_try(pic_state *pic, struct pic_escape *escape)
*pic->xp++ = handler;
}
void
pic_pop_try(pic_state *pic)
struct pic_proc *
pic_pop_handler(pic_state *pic)
{
pic_value cont, escape;
if (pic->xp == pic->xpbase) {
pic_panic(pic, "no exception handler registered");
}
assert(pic->xp > pic->xpbase);
cont = pic_attr_ref(pic, pic_obj_value(*--pic->xp), "@@escape");
assert(pic_proc_p(cont));
escape = pic_attr_ref(pic, cont, "@@escape");
assert(pic_data_p(escape));
((struct pic_escape *)pic_data_ptr(escape)->data)->valid = false;
return *--pic->xp;
}
struct pic_error *
pic_make_error(pic_state *pic, pic_sym type, const char *msg, pic_value irrs)
pic_make_error(pic_state *pic, pic_sym *type, const char *msg, pic_value irrs)
{
struct pic_error *e;
pic_str *stack;
@ -147,17 +130,13 @@ pic_raise_continuable(pic_state *pic, pic_value err)
struct pic_proc *handler;
pic_value v;
if (pic->xp == pic->xpbase) {
pic_panic(pic, "no exception handler registered");
}
handler = *--pic->xp;
handler = pic_pop_handler(pic);
pic_gc_protect(pic, pic_obj_value(handler));
v = pic_apply1(pic, handler, err);
*pic->xp++ = handler;
pic_push_handler(pic, handler);
return v;
}
@ -169,50 +148,34 @@ pic_raise(pic_state *pic, pic_value err)
val = pic_raise_continuable(pic, err);
pic_pop_try(pic);
pic_pop_handler(pic);
pic_errorf(pic, "error handler returned with ~s on error ~s", val, err);
}
void
pic_throw(pic_state *pic, pic_sym type, const char *msg, pic_value irrs)
pic_error(pic_state *pic, const char *msg, pic_value irrs)
{
struct pic_error *e;
e = pic_make_error(pic, type, msg, irrs);
e = pic_make_error(pic, pic_intern_cstr(pic, ""), msg, irrs);
pic_raise(pic, pic_obj_value(e));
}
void
pic_error(pic_state *pic, const char *msg, pic_value irrs)
{
pic_throw(pic, pic_intern_cstr(pic, ""), msg, irrs);
}
static pic_value
pic_error_with_exception_handler(pic_state *pic)
{
struct pic_proc *handler, *thunk;
pic_value val;
size_t xp_len;
ptrdiff_t xp_offset;
pic_get_args(pic, "ll", &handler, &thunk);
if (pic->xp >= pic->xpend) {
xp_len = (size_t)(pic->xpend - pic->xpbase) * 2;
xp_offset = pic->xp - pic->xpbase;
pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len);
pic->xp = pic->xpbase + xp_offset;
pic->xpend = pic->xpbase + xp_len;
}
*pic->xp++ = handler;
pic_push_handler(pic, handler);
val = pic_apply0(pic, thunk);
--pic->xp;
pic_pop_handler(pic);
return val;
}
@ -253,14 +216,14 @@ static pic_value
pic_error_make_error_object(pic_state *pic)
{
struct pic_error *e;
pic_sym type;
pic_sym *type;
pic_str *msg;
size_t argc;
pic_value *argv;
pic_get_args(pic, "ms*", &type, &msg, &argc, &argv);
e = pic_make_error(pic, type, pic_str_cstr(msg), pic_list_by_array(pic, argc, argv));
e = pic_make_error(pic, type, pic_str_cstr(pic, msg), pic_list_by_array(pic, argc, argv));
return pic_obj_value(e);
}
@ -302,7 +265,7 @@ pic_error_error_object_type(pic_state *pic)
pic_get_args(pic, "e", &e);
return pic_sym_value(e->type);
return pic_obj_value(e->type);
}
void

1
extlib/benz/eval.c
View File

@ -3,7 +3,6 @@
*/
#include "picrin.h"
#include "picrin/macro.h"
pic_value
pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)

317
extlib/benz/gc.c
View File

@ -3,28 +3,12 @@
*/
#include "picrin.h"
#include "picrin/gc.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/vector.h"
#include "picrin/irep.h"
#include "picrin/proc.h"
#include "picrin/port.h"
#include "picrin/blob.h"
#include "picrin/cont.h"
#include "picrin/error.h"
#include "picrin/macro.h"
#include "picrin/lib.h"
#include "picrin/data.h"
#include "picrin/dict.h"
#include "picrin/record.h"
#include "picrin/read.h"
union header {
struct {
union header *ptr;
size_t size;
unsigned int mark : 1;
char mark;
} s;
long alignment[2];
};
@ -56,24 +40,24 @@ heap_init(struct pic_heap *heap)
}
struct pic_heap *
pic_heap_open()
pic_heap_open(pic_state *pic)
{
struct pic_heap *heap;
heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap));
heap = pic_calloc(pic, 1, sizeof(struct pic_heap));
heap_init(heap);
return heap;
}
void
pic_heap_close(struct pic_heap *heap)
pic_heap_close(pic_state *pic, struct pic_heap *heap)
{
struct heap_page *page;
while (heap->pages) {
page = heap->pages;
heap->pages = heap->pages->next;
free(page);
pic_free(pic, page);
}
}
@ -92,7 +76,7 @@ add_heap_page(pic_state *pic)
nu = (PIC_HEAP_PAGE_SIZE + sizeof(union header) - 1) / sizeof(union header) + 1;
up = (union header *)pic_calloc(pic, 1 + nu + 1, sizeof(union header));
up = pic_calloc(pic, 1 + nu + 1, sizeof(union header));
up->s.size = nu + 1;
up->s.mark = PIC_GC_UNMARK;
gc_free(pic, up);
@ -103,7 +87,7 @@ add_heap_page(pic_state *pic)
up->s.size = 1;
up->s.ptr = np;
page = (struct heap_page *)pic_alloc(pic, sizeof(struct heap_page));
page = pic_malloc(pic, sizeof(struct heap_page));
page->basep = up;
page->endp = up + nu + 1;
page->next = pic->heap->pages;
@ -111,8 +95,9 @@ add_heap_page(pic_state *pic)
pic->heap->pages = page;
}
static void *
alloc(void *ptr, size_t size)
#if PIC_ENABLE_LIBC
void *
pic_default_allocf(void *ptr, size_t size)
{
if (size == 0) {
if (ptr) {
@ -126,13 +111,14 @@ alloc(void *ptr, size_t size)
return malloc(size);
}
}
#endif
void *
pic_alloc(pic_state *pic, size_t size)
pic_malloc(pic_state *pic, size_t size)
{
void *ptr;
ptr = alloc(NULL, size);
ptr = pic->allocf(NULL, size);
if (ptr == NULL && size > 0) {
pic_panic(pic, "memory exhausted");
}
@ -142,7 +128,7 @@ pic_alloc(pic_state *pic, size_t size)
void *
pic_realloc(pic_state *pic, void *ptr, size_t size)
{
ptr = alloc(ptr, size);
ptr = pic->allocf(ptr, size);
if (ptr == NULL && size > 0) {
pic_panic(pic, "memory exhausted");
}
@ -155,7 +141,7 @@ pic_calloc(pic_state *pic, size_t count, size_t size)
void *ptr;
size *= count;
ptr = alloc(NULL, size);
ptr = pic->allocf(NULL, size);
if (ptr == NULL && size > 0) {
pic_panic(pic, "memory exhausted");
}
@ -166,9 +152,7 @@ pic_calloc(pic_state *pic, size_t count, size_t size)
void
pic_free(pic_state *pic, void *ptr)
{
PIC_UNUSED(pic);
free(ptr);
pic->allocf(ptr, 0);
}
static void
@ -333,6 +317,12 @@ gc_obj_is_marked(struct pic_object *obj)
return gc_is_marked(p);
}
static bool
gc_value_need_mark(pic_value value)
{
return pic_obj_p(value) && (! gc_obj_is_marked(pic_obj_ptr(value)));
}
static void
gc_unmark(union header *p)
{
@ -340,16 +330,16 @@ gc_unmark(union header *p)
}
static void
gc_mark_winder(pic_state *pic, struct pic_winder *wind)
gc_mark_checkpoint(pic_state *pic, pic_checkpoint *cp)
{
if (wind->prev) {
gc_mark_object(pic, (struct pic_object *)wind->prev);
if (cp->prev) {
gc_mark_object(pic, (struct pic_object *)cp->prev);
}
if (wind->in) {
gc_mark_object(pic, (struct pic_object *)wind->in);
if (cp->in) {
gc_mark_object(pic, (struct pic_object *)cp->in);
}
if (wind->out) {
gc_mark_object(pic, (struct pic_object *)wind->out);
if (cp->out) {
gc_mark_object(pic, (struct pic_object *)cp->out);
}
}
@ -370,25 +360,30 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
gc_mark(pic, ((struct pic_pair *)obj)->cdr);
break;
}
case PIC_TT_ENV: {
struct pic_env *env = (struct pic_env *)obj;
case PIC_TT_CXT: {
struct pic_context *cxt = (struct pic_context *)obj;
int i;
for (i = 0; i < env->regc; ++i) {
gc_mark(pic, env->regs[i]);
for (i = 0; i < cxt->regc; ++i) {
gc_mark(pic, cxt->regs[i]);
}
if (env->up) {
gc_mark_object(pic, (struct pic_object *)env->up);
if (cxt->up) {
gc_mark_object(pic, (struct pic_object *)cxt->up);
}
break;
}
case PIC_TT_PROC: {
struct pic_proc *proc = (struct pic_proc *)obj;
if (proc->env) {
gc_mark_object(pic, (struct pic_object *)proc->env);
}
if (pic_proc_irep_p(proc)) {
gc_mark_object(pic, (struct pic_object *)proc->u.irep);
gc_mark_object(pic, (struct pic_object *)proc->u.i.irep);
if (proc->u.i.cxt) {
gc_mark_object(pic, (struct pic_object *)proc->u.i.cxt);
}
} else {
gc_mark_object(pic, (struct pic_object *)proc->u.f.name);
if (proc->u.f.env) {
gc_mark_object(pic, (struct pic_object *)proc->u.f.env);
}
}
break;
}
@ -397,7 +392,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
}
case PIC_TT_ERROR: {
struct pic_error *err = (struct pic_error *)obj;
gc_mark_object(pic,(struct pic_object *)err->msg);
gc_mark_object(pic, (struct pic_object *)err->type);
gc_mark_object(pic, (struct pic_object *)err->msg);
gc_mark(pic, err->irrs);
gc_mark_object(pic, (struct pic_object *)err->stack);
break;
@ -415,42 +411,38 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_BLOB: {
break;
}
case PIC_TT_MACRO: {
struct pic_macro *mac = (struct pic_macro *)obj;
case PIC_TT_ENV: {
struct pic_env *env = (struct pic_env *)obj;
if (mac->proc) {
gc_mark_object(pic, (struct pic_object *)mac->proc);
if (env->up) {
gc_mark_object(pic, (struct pic_object *)env->up);
}
if (mac->senv) {
gc_mark_object(pic, (struct pic_object *)mac->senv);
}
break;
}
case PIC_TT_SENV: {
struct pic_senv *senv = (struct pic_senv *)obj;
if (senv->up) {
gc_mark_object(pic, (struct pic_object *)senv->up);
}
gc_mark(pic, senv->defer);
gc_mark(pic, env->defer);
gc_mark_object(pic, (struct pic_object *)env->map);
break;
}
case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj;
gc_mark(pic, lib->name);
gc_mark_object(pic, (struct pic_object *)lib->env);
gc_mark_object(pic, (struct pic_object *)lib->exports);
break;
}
case PIC_TT_IREP: {
struct pic_irep *irep = (struct pic_irep *)obj;
size_t i;
gc_mark_object(pic, (struct pic_object *)irep->name);
for (i = 0; i < irep->ilen; ++i) {
gc_mark_object(pic, (struct pic_object *)irep->irep[i]);
}
for (i = 0; i < irep->plen; ++i) {
gc_mark(pic, irep->pool[i]);
}
for (i = 0; i < irep->slen; ++i) {
gc_mark_object(pic, (struct pic_object *)irep->syms[i]);
}
break;
}
case PIC_TT_DATA: {
@ -470,27 +462,40 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
xh_entry *it;
for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
gc_mark_object(pic, (struct pic_object *)xh_key(it, pic_sym *));
gc_mark(pic, xh_val(it, pic_value));
}
break;
}
case PIC_TT_RECORD: {
struct pic_record *rec = (struct pic_record *)obj;
xh_entry *it;
for (it = xh_begin(&rec->hash); it != NULL; it = xh_next(it)) {
gc_mark(pic, xh_val(it, pic_value));
gc_mark_object(pic, (struct pic_object *)rec->data);
break;
}
case PIC_TT_SYMBOL: {
struct pic_symbol *sym = (struct pic_symbol *)obj;
gc_mark_object(pic, (struct pic_object *)sym->str);
break;
}
case PIC_TT_REG: {
struct pic_reg *reg = (struct pic_reg *)obj;
reg->prev = pic->regs;
pic->regs = reg;
break;
}
case PIC_TT_NIL:
case PIC_TT_BOOL:
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT:
#endif
case PIC_TT_INT:
case PIC_TT_SYMBOL:
case PIC_TT_CHAR:
case PIC_TT_EOF:
case PIC_TT_UNDEF:
case PIC_TT_INVALID:
pic_panic(pic, "logic flaw");
}
}
@ -507,19 +512,34 @@ gc_mark(pic_state *pic, pic_value v)
gc_mark_object(pic, obj);
}
static void
gc_mark_trie(pic_state *pic, struct pic_trie *trie)
{
size_t i;
#define M(x) gc_mark_object(pic, (struct pic_object *)pic->x)
for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) {
if (trie->table[i] != NULL) {
gc_mark_trie(pic, trie->table[i]);
}
}
if (trie->proc != NULL) {
gc_mark_object(pic, (struct pic_object *)trie->proc);
}
static void
gc_mark_global_symbols(pic_state *pic)
{
M(sDEFINE); M(sLAMBDA); M(sIF); M(sBEGIN); M(sQUOTE); M(sSETBANG);
M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING);
M(sDEFINE_SYNTAX); M(sIMPORT); M(sEXPORT);
M(sDEFINE_LIBRARY);
M(sCOND_EXPAND); M(sAND); M(sOR); M(sELSE); M(sLIBRARY);
M(sONLY); M(sRENAME); M(sPREFIX); M(sEXCEPT);
M(sCONS); M(sCAR); M(sCDR); M(sNILP);
M(sSYMBOLP); M(sPAIRP);
M(sADD); M(sSUB); M(sMUL); M(sDIV); M(sMINUS);
M(sEQ); M(sLT); M(sLE); M(sGT); M(sGE); M(sNOT);
M(sREAD); M(sFILE);
M(sCALL); M(sTAILCALL); M(sCALL_WITH_VALUES); M(sTAILCALL_WITH_VALUES);
M(sGREF); M(sLREF); M(sCREF); M(sRETURN);
M(rDEFINE); M(rLAMBDA); M(rIF); M(rBEGIN); M(rQUOTE); M(rSETBANG);
M(rDEFINE_SYNTAX); M(rIMPORT); M(rEXPORT);
M(rDEFINE_LIBRARY);
M(rCOND_EXPAND);
M(rCONS); M(rCAR); M(rCDR); M(rNILP);
M(rSYMBOLP); M(rPAIRP);
M(rADD); M(rSUB); M(rMUL); M(rDIV);
M(rEQ); M(rLT); M(rLE); M(rGT); M(rGE); M(rNOT);
M(rVALUES); M(rCALL_WITH_VALUES);
}
static void
@ -529,12 +549,12 @@ gc_mark_phase(pic_state *pic)
pic_callinfo *ci;
struct pic_proc **xhandler;
size_t j;
xh_entry *it;
struct pic_object *obj;
/* winder */
if (pic->wind) {
gc_mark_winder(pic, pic->wind);
assert(pic->regs == NULL);
/* checkpoint */
if (pic->cp) {
gc_mark_checkpoint(pic, pic->cp);
}
/* stack */
@ -544,8 +564,8 @@ gc_mark_phase(pic_state *pic)
/* callinfo */
for (ci = pic->ci; ci != pic->cibase; --ci) {
if (ci->env) {
gc_mark_object(pic, (struct pic_object *)ci->env);
if (ci->cxt) {
gc_mark_object(pic, (struct pic_object *)ci->cxt);
}
}
@ -559,14 +579,22 @@ gc_mark_phase(pic_state *pic)
gc_mark_object(pic, pic->arena[j]);
}
/* mark reserved symbols */
gc_mark_global_symbols(pic);
/* global variables */
for (it = xh_begin(&pic->globals); it != NULL; it = xh_next(it)) {
gc_mark(pic, xh_val(it, pic_value));
if (pic->globals) {
gc_mark_object(pic, (struct pic_object *)pic->globals);
}
/* macro objects */
for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) {
gc_mark_object(pic, xh_val(it, struct pic_object *));
if (pic->macros) {
gc_mark_object(pic, (struct pic_object *)pic->macros);
}
/* attribute table */
if (pic->attrs) {
gc_mark_object(pic, (struct pic_object *)pic->attrs);
}
/* error object */
@ -575,9 +603,6 @@ gc_mark_phase(pic_state *pic)
/* features */
gc_mark(pic, pic->features);
/* readers */
gc_mark_trie(pic, pic->reader->trie);
/* library table */
gc_mark(pic, pic->libs);
@ -592,18 +617,29 @@ gc_mark_phase(pic_state *pic)
gc_mark_object(pic, (struct pic_object *)pic->xSTDERR);
}
/* attributes */
do {
j = 0;
/* parameter table */
gc_mark(pic, pic->ptable);
for (it = xh_begin(&pic->attrs); it != NULL; it = xh_next(it)) {
if (gc_obj_is_marked(xh_key(it, struct pic_object *))) {
obj = (struct pic_object *)xh_val(it, struct pic_dict *);
if (! gc_obj_is_marked(obj)) {
gc_mark_object(pic, obj);
/* registries */
do {
struct pic_object *key;
pic_value val;
xh_entry *it;
struct pic_reg *reg;
j = 0;
reg = pic->regs;
while (reg != NULL) {
for (it = xh_begin(&reg->hash); it != NULL; it = xh_next(it)) {
key = xh_key(it, struct pic_object *);
val = xh_val(it, pic_value);
if (gc_obj_is_marked(key) && gc_value_need_mark(val)) {
gc_mark(pic, val);
++j;
}
}
reg = reg->prev;
}
} while (j > 0);
}
@ -621,7 +657,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_PAIR: {
break;
}
case PIC_TT_ENV: {
case PIC_TT_CXT: {
break;
}
case PIC_TT_PROC: {
@ -636,7 +672,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
break;
}
case PIC_TT_STRING: {
XROPE_DECREF(((struct pic_string *)obj)->rope);
pic_rope_decref(pic, ((struct pic_string *)obj)->rope);
break;
}
case PIC_TT_PORT: {
@ -645,17 +681,10 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_ERROR: {
break;
}
case PIC_TT_SENV: {
struct pic_senv *senv = (struct pic_senv *)obj;
xh_destroy(&senv->map);
break;
}
case PIC_TT_MACRO: {
case PIC_TT_ENV: {
break;
}
case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj;
xh_destroy(&lib->exports);
break;
}
case PIC_TT_IREP: {
@ -663,6 +692,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
pic_free(pic, irep->code);
pic_free(pic, irep->irep);
pic_free(pic, irep->pool);
pic_free(pic, irep->syms);
break;
}
case PIC_TT_DATA: {
@ -677,29 +707,62 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
break;
}
case PIC_TT_RECORD: {
struct pic_record *rec = (struct pic_record *)obj;
xh_destroy(&rec->hash);
break;
}
case PIC_TT_SYMBOL: {
break;
}
case PIC_TT_REG: {
struct pic_reg *reg = (struct pic_reg *)obj;
xh_destroy(&reg->hash);
break;
}
case PIC_TT_NIL:
case PIC_TT_BOOL:
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT:
#endif
case PIC_TT_INT:
case PIC_TT_SYMBOL:
case PIC_TT_CHAR:
case PIC_TT_EOF:
case PIC_TT_UNDEF:
case PIC_TT_INVALID:
pic_panic(pic, "logic flaw");
}
}
static void
gc_sweep_symbols(pic_state *pic)
{
xh_entry *it;
xvect_t(xh_entry *) xv;
size_t i;
char *cstr;
xv_init(xv);
for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) {
if (! gc_obj_is_marked((struct pic_object *)xh_val(it, pic_sym *))) {
xv_push(xh_entry *, xv, it);
}
}
for (i = 0; i < xv_size(xv); ++i) {
cstr = xh_key(xv_A(xv, i), char *);
xh_del_str(&pic->syms, cstr);
pic_free(pic, cstr);
}
}
static void
gc_sweep_page(pic_state *pic, struct heap_page *page)
{
#if GC_DEBUG
static union header *NIL = (union header *)0xdeadbeef;
static union header * const NIL = (union header *)0xdeadbeef;
#else
static union header *NIL = NULL;
static union header * const NIL = NULL;
#endif
union header *bp, *p, *s = NIL, *t = NIL;
@ -750,14 +813,18 @@ gc_sweep_phase(pic_state *pic)
struct heap_page *page = pic->heap->pages;
xh_entry *it, *next;
do {
for (it = xh_begin(&pic->attrs); it != NULL; it = next) {
/* registries */
while (pic->regs != NULL) {
for (it = xh_begin(&pic->regs->hash); it != NULL; it = next) {
next = xh_next(it);
if (! gc_obj_is_marked(xh_key(it, struct pic_object *))) {
xh_del_ptr(&pic->attrs, xh_key(it, struct pic_object *));
xh_del_ptr(&pic->regs->hash, xh_key(it, struct pic_object *));
}
}
} while (it != NULL);
pic->regs = pic->regs->prev;
}
gc_sweep_symbols(pic);
while (page) {
gc_sweep_page(pic, page);
@ -772,6 +839,10 @@ pic_gc_run(pic_state *pic)
struct heap_page *page;
#endif
if (! pic->gc_enable) {
return;
}
#if DEBUG
puts("gc run!");
#endif

175
extlib/benz/include/picrin.h
View File

@ -29,52 +29,57 @@ extern "C" {
#endif
#include <stddef.h>
#include <stdbool.h>
#include <stdint.h>
#include <limits.h>
#include <stdarg.h>
#include <stdio.h>
#include <setjmp.h>
#include <assert.h>
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include <ctype.h>
#include "picrin/config.h"
#include "picrin/util.h"
#include "picrin/compat.h"
#if PIC_ENABLE_FLOAT
# include <math.h>
#endif
#include "picrin/xvect.h"
#include "picrin/xhash.h"
#include "picrin/xfile.h"
#include "picrin/xrope.h"
#include "picrin/config.h"
#include "picrin/util.h"
#include "picrin/value.h"
typedef struct pic_code pic_code;
struct pic_winder {
typedef struct pic_jmpbuf {
PIC_JMPBUF buf;
struct pic_jmpbuf *prev;
} pic_jmpbuf;
typedef struct pic_checkpoint {
struct pic_proc *in;
struct pic_proc *out;
int depth;
struct pic_winder *prev;
};
struct pic_checkpoint *prev;
} pic_checkpoint;
typedef struct {
int argc, retc;
pic_code *ip;
pic_value *fp;
struct pic_env *env;
struct pic_context *cxt;
int regc;
pic_value *regs;
struct pic_env *up;
struct pic_context *up;
} pic_callinfo;
typedef void *(*pic_allocf)(void *, size_t);
typedef struct {
int argc;
char **argv, **envp;
struct pic_winder *wind;
pic_allocf allocf;
pic_jmpbuf *jmp;
pic_checkpoint *cp;
pic_value *sp;
pic_value *stbase, *stend;
@ -87,24 +92,34 @@ typedef struct {
pic_code *ip;
struct pic_lib *lib;
pic_value ptable;
pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
pic_sym sDEFINE_SYNTAX, sIMPORT, sEXPORT;
pic_sym sDEFINE_LIBRARY, sIN_LIBRARY;
pic_sym sCOND_EXPAND, sAND, sOR, sELSE, sLIBRARY;
pic_sym sONLY, sRENAME, sPREFIX, sEXCEPT;
pic_sym sCONS, sCAR, sCDR, sNILP;
pic_sym sSYMBOL_P, sPAIR_P;
pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
pic_sym sREAD, sFILE;
struct pic_lib *lib, *prev_lib;
pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT;
pic_sym rDEFINE_LIBRARY, rIN_LIBRARY;
pic_sym rCOND_EXPAND;
pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG;
pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING;
pic_sym *sDEFINE_SYNTAX, *sIMPORT, *sEXPORT;
pic_sym *sDEFINE_LIBRARY;
pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY;
pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT;
pic_sym *sCONS, *sCAR, *sCDR, *sNILP;
pic_sym *sSYMBOLP, *sPAIRP;
pic_sym *sADD, *sSUB, *sMUL, *sDIV, *sMINUS;
pic_sym *sEQ, *sLT, *sLE, *sGT, *sGE, *sNOT;
pic_sym *sREAD, *sFILE;
pic_sym *sGREF, *sCREF, *sLREF;
pic_sym *sCALL, *sTAILCALL, *sRETURN;
pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES;
pic_sym *rDEFINE, *rLAMBDA, *rIF, *rBEGIN, *rQUOTE, *rSETBANG;
pic_sym *rDEFINE_SYNTAX, *rIMPORT, *rEXPORT;
pic_sym *rDEFINE_LIBRARY;
pic_sym *rCOND_EXPAND;
pic_sym *rCONS, *rCAR, *rCDR, *rNILP;
pic_sym *rSYMBOLP, *rPAIRP;
pic_sym *rADD, *rSUB, *rMUL, *rDIV;
pic_sym *rEQ, *rLT, *rLE, *rGT, *rGE, *rNOT;
pic_sym *rVALUES, *rCALL_WITH_VALUES;
struct pic_lib *PICRIN_BASE;
struct pic_lib *PICRIN_USER;
@ -112,32 +127,31 @@ typedef struct {
pic_value features;
xhash syms; /* name to symbol */
xhash sym_names; /* symbol to name */
int sym_cnt;
int uniq_sym_cnt;
xhash globals;
xhash macros;
struct pic_dict *globals;
struct pic_dict *macros;
pic_value libs;
xhash attrs;
struct pic_reg *attrs;
struct pic_reader *reader;
bool gc_enable;
struct pic_heap *heap;
struct pic_object **arena;
size_t arena_size, arena_idx;
struct pic_reg *regs;
struct pic_port *xSTDIN, *xSTDOUT, *xSTDERR;
pic_value err;
pic_code *iseq; /* for pic_apply_trampoline */
char *native_stack_start;
} pic_state;
typedef pic_value (*pic_func_t)(pic_state *);
void *pic_alloc(pic_state *, size_t);
#define pic_malloc(pic,size) pic_alloc(pic,size) /* obsoleted */
void *pic_malloc(pic_state *, size_t);
void *pic_realloc(pic_state *, void *, size_t);
void *pic_calloc(pic_state *, size_t, size_t);
struct pic_object *pic_obj_alloc(pic_state *, size_t, enum pic_tt);
@ -156,7 +170,8 @@ void pic_gc_arena_restore(pic_state *, size_t);
pic_gc_arena_restore(pic, ai); \
} while (0)
pic_state *pic_open(int argc, char *argv[], char **envp);
pic_state *pic_open(int argc, char *argv[], char **envp, pic_allocf);
void *pic_default_allocf(void *, size_t);
void pic_close(pic_state *);
void pic_add_feature(pic_state *, const char *);
@ -175,13 +190,11 @@ bool pic_eq_p(pic_value, pic_value);
bool pic_eqv_p(pic_value, pic_value);
bool pic_equal_p(pic_state *, pic_value, pic_value);
pic_sym pic_intern(pic_state *, const char *, size_t);
pic_sym pic_intern_str(pic_state *, pic_str *);
pic_sym pic_intern_cstr(pic_state *, const char *);
const char *pic_symbol_name(pic_state *, pic_sym);
pic_sym pic_gensym(pic_state *, pic_sym);
pic_sym pic_ungensym(pic_state *, pic_sym);
bool pic_interned_p(pic_state *, pic_sym);
pic_sym *pic_intern(pic_state *, pic_str *);
pic_sym *pic_intern_cstr(pic_state *, const char *);
const char *pic_symbol_name(pic_state *, pic_sym *);
pic_sym *pic_gensym(pic_state *, pic_sym *);
bool pic_interned_p(pic_state *, pic_sym *);
pic_value pic_read(pic_state *, struct pic_port *);
pic_value pic_read_cstr(pic_state *, const char *);
@ -205,34 +218,30 @@ pic_value pic_eval(pic_state *, pic_value, struct pic_lib *);
struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *);
pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *);
void pic_in_library(pic_state *, pic_value);
struct pic_lib *pic_open_library(pic_state *, pic_value);
struct pic_lib *pic_make_library(pic_state *, pic_value);
struct pic_lib *pic_find_library(pic_state *, pic_value);
#define pic_deflibrary(pic, spec) \
pic_deflibrary_helper_(pic, PIC_GENSYM(i), PIC_GENSYM(prev_lib), spec)
#define pic_deflibrary_helper_(pic, i, prev_lib, spec) \
for (int i = 0; ! i; ) \
for (struct pic_lib *prev_lib; ! i; ) \
for ((prev_lib = pic->lib), pic_open_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib)
for (((assert(pic->prev_lib == NULL)), \
(pic->prev_lib = pic->lib), \
(pic->lib = pic_find_library(pic, pic_read_cstr(pic, (spec)))), \
(pic->lib = pic->lib \
? pic->lib \
: pic_make_library(pic, pic_read_cstr(pic, (spec))))); \
pic->prev_lib != NULL; \
((pic->lib = pic->prev_lib), \
(pic->prev_lib = NULL)))
void pic_import(pic_state *, pic_value);
void pic_import_library(pic_state *, struct pic_lib *);
void pic_export(pic_state *, pic_sym);
void pic_export(pic_state *, pic_sym *);
pic_noreturn void pic_panic(pic_state *, const char *);
pic_noreturn void pic_errorf(pic_state *, const char *, ...);
PIC_NORETURN void pic_panic(pic_state *, const char *);
PIC_NORETURN void pic_errorf(pic_state *, const char *, ...);
void pic_warnf(pic_state *, const char *, ...);
const char *pic_errmsg(pic_state *);
pic_str *pic_get_backtrace(pic_state *);
void pic_print_backtrace(pic_state *);
/* obsoleted */
static inline void pic_warn(pic_state *pic, const char *msg)
{
pic_warnf(pic, msg);
}
void pic_print_backtrace(pic_state *, xFILE *);
struct pic_dict *pic_attr(pic_state *, pic_value);
pic_value pic_attr_ref(pic_state *, pic_value, const char *);
void pic_attr_set(pic_state *, pic_value, const char *, pic_value);
@ -246,9 +255,31 @@ pic_value pic_fwrite(pic_state *, pic_value, xFILE *);
void pic_printf(pic_state *, const char *, ...);
pic_value pic_display(pic_state *, pic_value);
pic_value pic_fdisplay(pic_state *, pic_value, xFILE *);
/* obsoleted macros */
#define pic_debug(pic,obj) pic_write(pic,obj)
#define pic_fdebug(pic,obj,file) pic_fwrite(pic,obj,file)
#if DEBUG
# define pic_debug(pic,obj) pic_fwrite(pic,obj,pic->xSTDERR->file)
# define pic_fdebug(pic,obj,file) pic_fwrite(pic,obj,file)
#endif
#include "picrin/blob.h"
#include "picrin/cont.h"
#include "picrin/data.h"
#include "picrin/dict.h"
#include "picrin/error.h"
#include "picrin/gc.h"
#include "picrin/irep.h"
#include "picrin/lib.h"
#include "picrin/macro.h"
#include "picrin/pair.h"
#include "picrin/port.h"
#include "picrin/proc.h"
#include "picrin/read.h"
#include "picrin/record.h"
#include "picrin/string.h"
#include "picrin/symbol.h"
#include "picrin/read.h"
#include "picrin/vector.h"
#include "picrin/reg.h"
#if defined(__cplusplus)
}

141
extlib/benz/include/picrin/compat.h Normal file
View File

@ -0,0 +1,141 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_COMPAT_H
#define PICRIN_COMPAT_H
#if defined(__cplusplus)
extern "C" {
#endif
#if PIC_ENABLE_LIBC
#include <string.h>
#include <ctype.h>
#include <assert.h>
#include <stdlib.h>
#else
# define assert(v) 0
PIC_INLINE int
isspace(int c)
{
return c == ' ' || c == '\t' || c == '\r' || c == '\v' || c == '\f' || c == '\n';
}
PIC_INLINE int
tolower(int c)
{
return ('A' <= c && c <= 'Z') ? c - 'A' + 'a' : c;
}
PIC_INLINE int
isdigit(int c)
{
return '0' <= c && c <= '9';
}
PIC_INLINE char *
strchr(const char *s, int c)
{
do {
if (*s == c)
return (char *)s;
} while (*s++ != '\0');
return NULL;
}
PIC_INLINE size_t
strlen(const char *s)
{
size_t l = 0;
while (*s++) {
l++;
}
return l;
}
PIC_INLINE int
strcmp(const char *s1, const char *s2)
{
while (*s1 && *s1 == *s2) {
s1++;
s2++;
}
return (unsigned)*s1 - (unsigned)*s2;
}
PIC_INLINE long
strtol(const char *nptr, char **endptr, int base)
{
long l = 0;
char c;
int n;
while (1) {
c = *nptr;
if ('0' <= c && c <= '9')
n = c - '0';
else if ('a' <= c && c <= 'z')
n = c - 'a' + 10;
else if ('A' <= c && c <= 'Z')
n = c - 'A' + 10;
else
goto exit;
if (base <= n)
goto exit;
l = l * base + n;
nptr++;
}
exit:
if (endptr)
*endptr = (char *)nptr;
return l;
}
PIC_INLINE void *
memset(void *s, int n, size_t c)
{
char *p = s;
while (c-- > 0) {
*p++ = n;
}
return s;
}
PIC_INLINE void *
memcpy(void *dst, const void *src, size_t n)
{
const char *s = src;
char *d = dst;
while (n-- > 0) {
*d++ = *s++;
}
return d;
}
PIC_INLINE char *
strcpy(char *dst, const char *src)
{
char *d = dst;
while ((*dst++ = *src++) != 0);
return d;
}
#endif
#if defined(__cplusplus)
}
#endif
#endif

82
extlib/benz/include/picrin/config.h
View File

@ -8,8 +8,22 @@
/** switch internal value representation */
/* #define PIC_NAN_BOXING 1 */
/** treat false value as none */
/* #define PIC_NONE_IS_FALSE 1 */
/** enable word boxing */
/* #define PIC_WORD_BOXING 0 */
/** enable floating point number support */
/* #define PIC_ENABLE_FLOAT 1 */
/** no dependency on libc */
/* #define PIC_ENABLE_LIBC 1 */
/** custom setjmp/longjmp */
/* #define PIC_JMPBUF jmp_buf */
/* #define PIC_SETJMP(pic, buf) setjmp(buf) */
/* #define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val)) */
/** custom abort */
/* #define PIC_ABORT(pic) abort() */
/** initial memory size (to be dynamically extended if necessary) */
/* #define PIC_ARENA_SIZE 1000 */
@ -26,6 +40,8 @@
/* #define PIC_POOL_SIZE 8 */
/* #define PIC_SYMS_SIZE 32 */
/* #define PIC_ISEQ_SIZE 1024 */
/** enable all debug flags */
@ -37,24 +53,63 @@
/* #define GC_DEBUG 1 */
/* #define GC_DEBUG_DETAIL 1 */
#if __STDC_VERSION__ < 199901L
# error please activate c99 features
#endif
#ifndef PIC_DIRECT_THREADED_VM
# if defined(__GNUC__) || defined(__clang__)
# if (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1
# define PIC_DIRECT_THREADED_VM 1
# endif
#endif
#ifndef PIC_NAN_BOXING
# if __x86_64__ && __STDC_VERSION__ >= 201112L
#if PIC_NAN_BOXING && PIC_WORD_BOXING
# error cannot enable both PIC_NAN_BOXING and PIC_WORD_BOXING simultaneously
#endif
#if PIC_WORD_BOXING && PIC_ENABLE_FLOAT
# error cannot enable both PIC_WORD_BOXING and PIC_ENABLE_FLOAT simultaneously
#endif
#ifndef PIC_WORD_BOXING
# define PIC_WORD_BOXING 0
#endif
#if ! PIC_WORD_BOXING
# ifndef PIC_NAN_BOXING
# if __x86_64__ && (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1
# define PIC_NAN_BOXING 1
# endif
# endif
#endif
#ifndef PIC_NONE_IS_FALSE
# define PIC_NONE_IS_FALSE 1
#ifndef PIC_ENABLE_FLOAT
# if ! PIC_WORD_BOXING
# define PIC_ENABLE_FLOAT 1
# endif
#endif
#ifndef PIC_ENABLE_LIBC
# define PIC_ENABLE_LIBC 1
#endif
#if PIC_NAN_BOXING && defined(PIC_ENABLE_FLOAT) && ! PIC_ENABLE_FLOAT
# error cannot disable float support when nan boxing is on
#endif
#ifndef PIC_JMPBUF
# include <setjmp.h>
# define PIC_JMPBUF jmp_buf
#endif
#ifndef PIC_SETJMP
# include <setjmp.h>
# define PIC_SETJMP(pic, buf) setjmp(buf)
#endif
#ifndef PIC_LONGJMP
# include <setjmp.h>
# define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val))
#endif
#ifndef PIC_ABORT
# define PIC_ABORT(pic) abort()
#endif
#ifndef PIC_ARENA_SIZE
@ -85,11 +140,16 @@
# define PIC_POOL_SIZE 8
#endif
#ifndef PIC_SYMS_SIZE
# define PIC_SYMS_SIZE 32
#endif
#ifndef PIC_ISEQ_SIZE
# define PIC_ISEQ_SIZE 1024
#endif
#if DEBUG
# include <stdio.h>
# define GC_STRESS 0
# define VM_DEBUG 1
# define GC_DEBUG 0

20
extlib/benz/include/picrin/cont.h
View File

@ -9,12 +9,10 @@
extern "C" {
#endif
struct pic_escape {
jmp_buf jmp;
struct pic_cont {
pic_jmpbuf jmp;
bool valid;
struct pic_winder *wind;
pic_checkpoint *cp;
ptrdiff_t sp_offset;
ptrdiff_t ci_offset;
@ -23,15 +21,17 @@ struct pic_escape {
pic_code *ip;
pic_value ptable;
pic_value results;
};
void pic_save_point(pic_state *, struct pic_escape *);
void pic_load_point(pic_state *, struct pic_escape *);
void pic_save_point(pic_state *, struct pic_cont *);
void pic_load_point(pic_state *, struct pic_cont *);
struct pic_proc *pic_make_econt(pic_state *, struct pic_escape *);
struct pic_proc *pic_make_cont(pic_state *, struct pic_cont *);
void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *);
void pic_wind(pic_state *, pic_checkpoint *, pic_checkpoint *);
pic_value pic_dynamic_wind(pic_state *, struct pic_proc *, struct pic_proc *, struct pic_proc *);
pic_value pic_values0(pic_state *);
@ -44,7 +44,7 @@ pic_value pic_values_by_array(pic_state *, size_t, pic_value *);
pic_value pic_values_by_list(pic_state *, pic_value);
size_t pic_receive(pic_state *, size_t, pic_value *);
pic_value pic_escape(pic_state *, struct pic_proc *);
pic_value pic_callcc(pic_state *, struct pic_proc *);
#if defined(__cplusplus)
}

2
extlib/benz/include/picrin/data.h
View File

@ -25,7 +25,7 @@ struct pic_data {
#define pic_data_p(o) (pic_type(o) == PIC_TT_DATA)
#define pic_data_ptr(o) ((struct pic_data *)pic_ptr(o))
static inline bool pic_data_type_p(const pic_value obj, const pic_data_type *type) {
PIC_INLINE bool pic_data_type_p(const pic_value obj, const pic_data_type *type) {
return pic_data_p(obj) && pic_data_ptr(obj)->type == type;
}

12
extlib/benz/include/picrin/dict.h
View File

@ -19,11 +19,15 @@ struct pic_dict {
struct pic_dict *pic_make_dict(pic_state *);
pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym);
void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value);
void pic_dict_del(pic_state *, struct pic_dict *, pic_sym);
#define pic_dict_for_each(sym, dict, it) \
for (it = xh_begin(&(dict)->hash); it != NULL; it = xh_next(it)) \
if ((sym = xh_key(it, pic_sym *)), true)
pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym *);
void pic_dict_set(pic_state *, struct pic_dict *, pic_sym *, pic_value);
void pic_dict_del(pic_state *, struct pic_dict *, pic_sym *);
size_t pic_dict_size(pic_state *, struct pic_dict *);
bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym);
bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym *);
#if defined(__cplusplus)
}

49
extlib/benz/include/picrin/error.h
View File

@ -9,11 +9,9 @@
extern "C" {
#endif
#include "picrin/cont.h"
struct pic_error {
PIC_OBJECT_HEADER
pic_sym type;
pic_sym *type;
pic_str *msg;
pic_value irrs;
pic_str *stack;
@ -22,30 +20,43 @@ struct pic_error {
#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR)
#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v))
struct pic_error *pic_make_error(pic_state *, pic_sym, const char *, pic_list);
struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_list);
/* do not return from try block! */
#define pic_try \
pic_try_(PIC_GENSYM(escape))
#define pic_try_(escape) \
struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape)); \
pic_save_point(pic, escape); \
if (setjmp(escape->jmp) == 0) { \
pic_push_try(pic, escape); \
do
pic_try_(PIC_GENSYM(cont), PIC_GENSYM(handler))
#define pic_catch \
while (0); \
pic_pop_try(pic); \
} else
pic_catch_(PIC_GENSYM(label))
#define pic_try_(cont, handler) \
do { \
struct pic_cont *cont = pic_malloc(pic, sizeof(struct pic_cont)); \
pic_save_point(pic, cont); \
if (PIC_SETJMP(pic, cont->jmp.buf) == 0) { \
extern pic_value pic_native_exception_handler(pic_state *); \
struct pic_proc *handler; \
handler = pic_make_proc(pic, pic_native_exception_handler, "(native-exception-handler)"); \
pic_proc_env_set(pic, handler, "cont", pic_obj_value(pic_make_cont(pic, cont))); \
do { \
pic_push_handler(pic, handler);
#define pic_catch_(label) \
pic_pop_handler(pic); \
} while (0); \
pic->jmp = pic->jmp->prev; \
} else { \
pic->jmp = pic->jmp->prev; \
goto label; \
} \
} while (0); \
if (0) \
label:
void pic_push_try(pic_state *, struct pic_escape *);
void pic_pop_try(pic_state *);
void pic_push_handler(pic_state *, struct pic_proc *);
struct pic_proc *pic_pop_handler(pic_state *);
pic_value pic_raise_continuable(pic_state *, pic_value);
pic_noreturn void pic_raise(pic_state *, pic_value);
pic_noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list);
pic_noreturn void pic_error(pic_state *, const char *, pic_list);
PIC_NORETURN void pic_raise(pic_state *, pic_value);
PIC_NORETURN void pic_error(pic_state *, const char *, pic_list);
#if defined(__cplusplus)
}

4
extlib/benz/include/picrin/gc.h
View File

@ -14,8 +14,8 @@ extern "C" {
struct pic_heap;
struct pic_heap *pic_heap_open();
void pic_heap_close(struct pic_heap *);
struct pic_heap *pic_heap_open(pic_state *);
void pic_heap_close(pic_state *, struct pic_heap *);
#if defined(__cplusplus)
}

34
extlib/benz/include/picrin/irep.h
View File

@ -12,6 +12,7 @@ extern "C" {
enum pic_opcode {
OP_NOP,
OP_POP,
OP_PUSHUNDEF,
OP_PUSHNIL,
OP_PUSHTRUE,
OP_PUSHFALSE,
@ -35,8 +36,8 @@ enum pic_opcode {
OP_CAR,
OP_CDR,
OP_NILP,
OP_SYMBOL_P,
OP_PAIR_P,
OP_SYMBOLP,
OP_PAIRP,
OP_ADD,
OP_SUB,
OP_MUL,
@ -60,21 +61,29 @@ struct pic_code {
} u;
};
#define PIC_INIT_CODE_I(code, op, ival) do { \
code.insn = op; \
code.u.i = ival; \
} while (0)
struct pic_irep {
PIC_OBJECT_HEADER
pic_sym name;
pic_sym *name;
pic_code *code;
int argc, localc, capturec;
bool varg;
struct pic_irep **irep;
pic_value *pool;
size_t clen, ilen, plen;
pic_sym **syms;
size_t clen, ilen, plen, slen;
};
pic_value pic_analyze(pic_state *, pic_value);
struct pic_irep *pic_codegen(pic_state *, pic_value);
static inline void
#if DEBUG
PIC_INLINE void
pic_dump_code(pic_code c)
{
printf("[%2d] ", c.insn);
@ -85,6 +94,9 @@ pic_dump_code(pic_code c)
case OP_POP:
puts("OP_POP");
break;
case OP_PUSHUNDEF:
puts("OP_PUSHUNDEF");
break;
case OP_PUSHNIL:
puts("OP_PUSHNIL");
break;
@ -151,11 +163,11 @@ pic_dump_code(pic_code c)
case OP_NILP:
puts("OP_NILP");
break;
case OP_SYMBOL_P:
puts("OP_SYMBOL_P");
case OP_SYMBOLP:
puts("OP_SYMBOLP");
break;
case OP_PAIR_P:
puts("OP_PAIR_P");
case OP_PAIRP:
puts("OP_PAIRP");
break;
case OP_CDR:
puts("OP_CDR");
@ -190,7 +202,7 @@ pic_dump_code(pic_code c)
}
}
static inline void
PIC_INLINE void
pic_dump_irep(struct pic_irep *irep)
{
unsigned i;
@ -207,6 +219,8 @@ pic_dump_irep(struct pic_irep *irep)
}
}
#endif
#if defined(__cplusplus)
}
#endif

4
extlib/benz/include/picrin/lib.h
View File

@ -12,8 +12,8 @@ extern "C" {
struct pic_lib {
PIC_OBJECT_HEADER
pic_value name;
struct pic_senv *env;
xhash exports;
struct pic_env *env;
struct pic_dict *exports;
};
#define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o))

33
extlib/benz/include/picrin/macro.h
View File

@ -9,37 +9,24 @@
extern "C" {
#endif
struct pic_senv {
struct pic_env {
PIC_OBJECT_HEADER
xhash map;
struct pic_dict *map;
pic_value defer;
struct pic_senv *up;
struct pic_env *up;
};
struct pic_macro {
PIC_OBJECT_HEADER
struct pic_proc *proc;
struct pic_senv *senv;
};
#define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO)
#define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v))
#define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV)
#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v))
struct pic_senv *pic_null_syntactic_environment(pic_state *);
#define pic_env_p(v) (pic_type(v) == PIC_TT_ENV)
#define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v))
bool pic_identifier_p(pic_state *pic, pic_value obj);
bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym);
bool pic_identifier_eq_p(pic_state *, struct pic_env *, pic_sym *, struct pic_env *, pic_sym *);
struct pic_senv *pic_make_senv(pic_state *, struct pic_senv *);
struct pic_env *pic_make_env(pic_state *, struct pic_env *);
pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym);
bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */);
void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym);
void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym);
pic_sym *pic_add_rename(pic_state *, struct pic_env *, pic_sym *);
pic_sym *pic_find_rename(pic_state *, struct pic_env *, pic_sym *);
void pic_put_rename(pic_state *, struct pic_env *, pic_sym *, pic_sym *);
#if defined(__cplusplus)
}

13
extlib/benz/include/picrin/pair.h
View File

@ -18,7 +18,7 @@ struct pic_pair {
#define pic_pair_p(v) (pic_type(v) == PIC_TT_PAIR)
#define pic_pair_ptr(o) ((struct pic_pair *)pic_ptr(o))
static inline pic_value
PIC_INLINE pic_value
pic_car(pic_state *pic, pic_value obj)
{
struct pic_pair *pair;
@ -31,7 +31,7 @@ pic_car(pic_state *pic, pic_value obj)
return pair->car;
}
static inline pic_value
PIC_INLINE pic_value
pic_cdr(pic_state *pic, pic_value obj)
{
struct pic_pair *pair;
@ -59,12 +59,9 @@ pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic
pic_value pic_list_by_array(pic_state *, size_t, pic_value *);
pic_value pic_make_list(pic_state *, size_t, pic_value);
#define pic_for_each(var, list) \
pic_for_each_helper_(var, PIC_GENSYM(tmp), list)
#define pic_for_each_helper_(var, tmp, list) \
for (pic_value tmp = (list); \
pic_nil_p(tmp) ? false : ((var = pic_car(pic, tmp)), true); \
tmp = pic_cdr(pic, tmp))
#define pic_for_each(var, list, it) \
for (it = (list); ! pic_nil_p(it); it = pic_cdr(pic, it)) \
if ((var = pic_car(pic, it)), true)
#define pic_push(pic, item, place) (place = pic_cons(pic, item, place))
#define pic_pop(pic, place) (place = pic_cdr(pic, place))

4
extlib/benz/include/picrin/port.h
View File

@ -13,12 +13,12 @@ enum pic_port_flag {
PIC_PORT_IN = 1,
PIC_PORT_OUT = 2,
PIC_PORT_TEXT = 4,
PIC_PORT_BINARY = 8,
PIC_PORT_BINARY = 8
};
enum pic_port_status {
PIC_PORT_OPEN,
PIC_PORT_CLOSE,
PIC_PORT_CLOSE
};
struct pic_port {

46
extlib/benz/include/picrin/proc.h
View File

@ -9,46 +9,50 @@
extern "C" {
#endif
/* native C function */
struct pic_func {
pic_func_t f;
pic_sym name;
};
struct pic_env {
struct pic_context {
PIC_OBJECT_HEADER
pic_value *regs;
int regc;
struct pic_env *up;
pic_value storage[];
struct pic_context *up;
pic_value storage[1];
};
struct pic_proc {
PIC_OBJECT_HEADER
char kind;
enum {
PIC_PROC_TAG_IREP,
PIC_PROC_TAG_FUNC
} tag;
union {
struct pic_func func;
struct {
pic_func_t func;
pic_sym *name;
struct pic_dict *env;
} f;
struct {
struct pic_irep *irep;
struct pic_context *cxt;
} i;
} u;
struct pic_env *env;
};
#define PIC_PROC_KIND_FUNC 1
#define PIC_PROC_KIND_IREP 2
#define pic_proc_func_p(proc) ((proc)->kind == PIC_PROC_KIND_FUNC)
#define pic_proc_irep_p(proc) ((proc)->kind == PIC_PROC_KIND_IREP)
#define pic_proc_func_p(proc) ((proc)->tag == PIC_PROC_TAG_FUNC)
#define pic_proc_irep_p(proc) ((proc)->tag == PIC_PROC_TAG_IREP)
#define pic_proc_p(o) (pic_type(o) == PIC_TT_PROC)
#define pic_proc_ptr(o) ((struct pic_proc *)pic_ptr(o))
#define pic_env_p(o) (pic_type(o) == PIC_TT_ENV)
#define pic_env_ptr(o) ((struct pic_env *)pic_ptr(o))
#define pic_context_p(o) (pic_type(o) == PIC_TT_CXT)
#define pic_context_ptr(o) ((struct pic_context *)pic_ptr(o))
struct pic_proc *pic_make_proc(pic_state *, pic_func_t, const char *);
struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_env *);
struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_context *);
pic_sym pic_proc_name(struct pic_proc *);
pic_sym *pic_proc_name(struct pic_proc *);
struct pic_dict *pic_proc_env(pic_state *, struct pic_proc *);
bool pic_proc_env_has(pic_state *, struct pic_proc *, const char *);
pic_value pic_proc_env_ref(pic_state *, struct pic_proc *, const char *);
void pic_proc_env_set(pic_state *, struct pic_proc *, const char *, pic_value);
#if defined(__cplusplus)
}

26
extlib/benz/include/picrin/read.h
View File

@ -9,28 +9,20 @@
extern "C" {
#endif
enum pic_typecase {
PIC_CASE_DEFAULT,
PIC_CASE_FOLD,
};
struct pic_trie {
struct pic_trie *table[256];
struct pic_proc *proc;
};
typedef pic_value (*pic_reader_t)(pic_state *, struct pic_port *port, int c);
struct pic_reader {
short typecase;
enum pic_typecase {
PIC_CASE_DEFAULT,
PIC_CASE_FOLD
} typecase;
xhash labels;
struct pic_trie *trie;
pic_reader_t table[256];
pic_reader_t dispatch[256];
};
void pic_init_reader(pic_state *);
void pic_define_reader(pic_state *, const char *, pic_func_t);
struct pic_trie *pic_make_trie(pic_state *);
void pic_trie_delete(pic_state *, struct pic_trie *);
struct pic_reader *pic_reader_open(pic_state *);
void pic_reader_close(pic_state *, struct pic_reader *);
#if defined(__cplusplus)
}

6
extlib/benz/include/picrin/record.h
View File

@ -11,7 +11,7 @@ extern "C" {
struct pic_record {
PIC_OBJECT_HEADER
xhash hash;
struct pic_dict *data;
};
#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD)
@ -20,8 +20,8 @@ struct pic_record {
struct pic_record *pic_make_record(pic_state *, pic_value);
pic_value pic_record_type(pic_state *, struct pic_record *);
pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym);
void pic_record_set(pic_state *, struct pic_record *, pic_sym, pic_value);
pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym *);
void pic_record_set(pic_state *, struct pic_record *, pic_sym *, pic_value);
#if defined(__cplusplus)
}

32
extlib/benz/include/picrin/reg.h Normal file
View File

@ -0,0 +1,32 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_REG_H
#define PICRIN_REG_H
#if defined(__cplusplus)
extern "C" {
#endif
struct pic_reg {
PIC_OBJECT_HEADER
xhash hash;
struct pic_reg *prev; /* for GC */
};
#define pic_reg_p(v) (pic_type(v) == PIC_TT_REG)
#define pic_reg_ptr(v) ((struct pic_reg *)pic_ptr(v))
struct pic_reg *pic_make_reg(pic_state *);
pic_value pic_reg_ref(pic_state *, struct pic_reg *, void *);
void pic_reg_set(pic_state *, struct pic_reg *, void *, pic_value);
void pic_reg_del(pic_state *, struct pic_reg *, void *);
bool pic_reg_has(pic_state *, struct pic_reg *, void *);
#if defined(__cplusplus)
}
#endif
#endif

17
extlib/benz/include/picrin/string.h
View File

@ -11,9 +11,12 @@ extern "C" {
struct pic_string {
PIC_OBJECT_HEADER
xrope *rope;
struct pic_rope *rope;
};
void pic_rope_incref(pic_state *, struct pic_rope *);
void pic_rope_decref(pic_state *, struct pic_rope *);
#define pic_str_p(v) (pic_type(v) == PIC_TT_STRING)
#define pic_str_ptr(o) ((struct pic_string *)pic_ptr(o))
@ -21,14 +24,12 @@ pic_str *pic_make_str(pic_state *, const char * /* nullable */, size_t);
pic_str *pic_make_str_cstr(pic_state *, const char *);
pic_str *pic_make_str_fill(pic_state *, size_t, char);
size_t pic_strlen(pic_str *);
char pic_str_ref(pic_state *, pic_str *, size_t);
pic_str *pic_strcat(pic_state *, pic_str *, pic_str *);
pic_str *pic_substr(pic_state *, pic_str *, size_t, size_t);
int pic_strcmp(pic_str *, pic_str *);
const char *pic_str_cstr(pic_str *);
size_t pic_str_len(pic_str *);
pic_str *pic_str_cat(pic_state *, pic_str *, pic_str *);
pic_str *pic_str_sub(pic_state *, pic_str *, size_t, size_t);
int pic_str_cmp(pic_state *, pic_str *, pic_str *);
const char *pic_str_cstr(pic_state *, pic_str *);
pic_str *pic_format(pic_state *, const char *, ...);
pic_str *pic_vformat(pic_state *, const char *, va_list);

24
extlib/benz/include/picrin/symbol.h Normal file
View File

@ -0,0 +1,24 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_SYMBOL_H
#define PICRIN_SYMBOL_H
#if defined(__cplusplus)
extern "C" {
#endif
struct pic_symbol {
PIC_OBJECT_HEADER
pic_str *str;
};
#define pic_sym_p(v) (pic_type(v) == PIC_TT_SYMBOL)
#define pic_sym_ptr(v) ((struct pic_symbol *)pic_ptr(v))
#if defined(__cplusplus)
}
#endif
#endif

35
extlib/benz/include/picrin/util.h
View File

@ -9,17 +9,44 @@
extern "C" {
#endif
#if __STDC_VERSION__ >= 199901L
# include <stdbool.h>
#else
# define bool char
# define true 1
# define false 0
#endif
#if __STDC_VERSION__ >= 199901L
# include <stddef.h>
#elif ! defined(offsetof)
# define offsetof(s,m) ((size_t)&(((s *)NULL)->m))
#endif
#if __STDC_VERSION__ >= 201112L
# include <stdnoreturn.h>
# define pic_noreturn noreturn
# define PIC_NORETURN noreturn
#elif __GNUC__ || __clang__
# define pic_noreturn __attribute__((noreturn))
# define PIC_NORETURN __attribute__((noreturn))
#else
# define pic_noreturn
# define PIC_NORETURN
#endif
#if __STDC_VERSION__ >= 199901L
# define PIC_INLINE static inline
#elif __GNUC__ || __clang__
# define PIC_INLINE static __inline__
#else
# define PIC_INLINE static
#endif
#define PIC_FALLTHROUGH ((void)0)
#define PIC_UNUSED(v) ((void)(v))
#if __GNUC__ || __clang__
# define PIC_UNUSED(v) __attribute__((unused)) v
#else
# define PIC_UNUSED(v) v
#endif
#define PIC_GENSYM2_(x,y) PIC_G##x##_##y##_
#define PIC_GENSYM1_(x,y) PIC_GENSYM2_(x,y)

270
extlib/benz/include/picrin/value.h
View File

@ -10,14 +10,8 @@ extern "C" {
#endif
/**
* pic_sym is just an alias of int.
*/
typedef int pic_sym;
/**
* `undef` values never seen from user-end: that is,
* it's used only for repsenting internal special state
* `invalid` value will never be seen from user-end:
* it is only used for repsenting internal special state
*/
enum pic_vtype {
@ -25,9 +19,11 @@ enum pic_vtype {
PIC_VTYPE_TRUE,
PIC_VTYPE_FALSE,
PIC_VTYPE_UNDEF,
PIC_VTYPE_INVALID,
#if PIC_ENABLE_FLOAT
PIC_VTYPE_FLOAT,
#endif
PIC_VTYPE_INT,
PIC_VTYPE_SYMBOL,
PIC_VTYPE_CHAR,
PIC_VTYPE_EOF,
PIC_VTYPE_HEAP
@ -35,12 +31,13 @@ enum pic_vtype {
#if PIC_NAN_BOXING
#include <stdint.h>
/**
* value representation by nan-boxing:
* float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF
* ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP
* int : 1111111111110110 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII
* sym : 1111111111110111 0000000000000000 SSSSSSSSSSSSSSSS SSSSSSSSSSSSSSSS
* char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
*/
@ -71,15 +68,47 @@ pic_int(pic_value v)
return u.i;
}
static inline int
pic_sym(pic_value v)
#define pic_char(v) ((v) & 0xfffffffful)
#elif PIC_WORD_BOXING
typedef unsigned long pic_value;
#define pic_ptr(v) ((void *)(v))
#define pic_init_value(v,vtype) do { \
v = (vtype << 3) + 7; \
} while (0)
PIC_INLINE enum pic_vtype
pic_vtype(pic_value v)
{
union { int i; unsigned u; } u;
u.u = v & 0xfffffffful;
return u.i;
if ((v & 1) == 0) {
return PIC_VTYPE_HEAP;
}
if ((v & 2) == 0) {
return PIC_VTYPE_INT;
}
if ((v & 4) == 0) {
return PIC_VTYPE_CHAR;
}
return v >> 3;
}
#define pic_char(v) ((v) & 0xfffffffful)
PIC_INLINE int
pic_int(pic_value v)
{
v >>= 2;
if ((v & ((ULONG_MAX >> 3) + 1)) != 0) {
v |= ULONG_MAX - (ULONG_MAX >> 2);
}
return v;
}
PIC_INLINE char
pic_char(pic_value v)
{
return v >> 3;
}
#else
@ -87,9 +116,10 @@ typedef struct {
enum pic_vtype type;
union {
void *data;
#if PIC_ENABLE_FLOAT
double f;
#endif
int i;
pic_sym sym;
char c;
} u;
} pic_value;
@ -98,9 +128,10 @@ typedef struct {
#define pic_vtype(v) ((v).type)
#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL)
#define pic_float(v) ((v).u.f)
#if PIC_ENABLE_FLOAT
# define pic_float(v) ((v).u.f)
#endif
#define pic_int(v) ((v).u.i)
#define pic_sym(v) ((v).u.sym)
#define pic_char(v) ((v).u.c)
#endif
@ -109,13 +140,16 @@ enum pic_tt {
/* immediate */
PIC_TT_NIL,
PIC_TT_BOOL,
#if PIC_ENABLE_FLOAT
PIC_TT_FLOAT,
#endif
PIC_TT_INT,
PIC_TT_SYMBOL,
PIC_TT_CHAR,
PIC_TT_EOF,
PIC_TT_UNDEF,
PIC_TT_INVALID,
/* heap */
PIC_TT_SYMBOL,
PIC_TT_PAIR,
PIC_TT_STRING,
PIC_TT_VECTOR,
@ -123,14 +157,14 @@ enum pic_tt {
PIC_TT_PROC,
PIC_TT_PORT,
PIC_TT_ERROR,
PIC_TT_CXT,
PIC_TT_ENV,
PIC_TT_SENV,
PIC_TT_MACRO,
PIC_TT_LIB,
PIC_TT_IREP,
PIC_TT_DATA,
PIC_TT_DICT,
PIC_TT_RECORD,
PIC_TT_REG,
PIC_TT_RECORD
};
#define PIC_OBJECT_HEADER \
@ -140,6 +174,7 @@ struct pic_object {
PIC_OBJECT_HEADER
};
struct pic_symbol;
struct pic_pair;
struct pic_string;
struct pic_vector;
@ -151,6 +186,7 @@ struct pic_error;
/* set aliases to basic types */
typedef pic_value pic_list;
typedef struct pic_symbol pic_sym;
typedef struct pic_pair pic_pair;
typedef struct pic_string pic_str;
typedef struct pic_vector pic_vec;
@ -163,43 +199,55 @@ typedef struct pic_blob pic_blob;
#define pic_true_p(v) (pic_vtype(v) == PIC_VTYPE_TRUE)
#define pic_false_p(v) (pic_vtype(v) == PIC_VTYPE_FALSE)
#define pic_undef_p(v) (pic_vtype(v) == PIC_VTYPE_UNDEF)
#define pic_invalid_p(v) (pic_vtype(v) == PIC_VTYPE_INVALID)
#define pic_float_p(v) (pic_vtype(v) == PIC_VTYPE_FLOAT)
#define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT)
#define pic_sym_p(v) (pic_vtype(v) == PIC_VTYPE_SYMBOL)
#define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR)
#define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF)
#define pic_test(v) (! pic_false_p(v))
static inline enum pic_tt pic_type(pic_value);
static inline const char *pic_type_repr(enum pic_tt);
PIC_INLINE enum pic_tt pic_type(pic_value);
PIC_INLINE const char *pic_type_repr(enum pic_tt);
#define pic_assert_type(pic, v, type) \
if (! pic_##type##_p(v)) { \
pic_errorf(pic, "expected " #type ", but got ~s", v); \
}
static inline bool pic_valid_int(double);
#if PIC_ENABLE_FLOAT
PIC_INLINE bool
pic_valid_int(double v)
{
return INT_MIN <= v && v <= INT_MAX;
}
static inline pic_value pic_nil_value();
static inline pic_value pic_true_value();
static inline pic_value pic_false_value();
static inline pic_value pic_bool_value(bool);
static inline pic_value pic_undef_value();
static inline pic_value pic_obj_value(void *);
static inline pic_value pic_float_value(double);
static inline pic_value pic_int_value(int);
static inline pic_value pic_size_value(size_t);
static inline pic_value pic_sym_value(pic_sym);
static inline pic_value pic_char_value(char c);
static inline pic_value pic_none_value();
#else
PIC_INLINE bool
pic_valid_int(int PIC_UNUSED(v))
{
return true;
}
#endif
#define pic_symbol_value(sym) pic_sym_value(sym)
PIC_INLINE pic_value pic_nil_value();
PIC_INLINE pic_value pic_true_value();
PIC_INLINE pic_value pic_false_value();
PIC_INLINE pic_value pic_bool_value(bool);
PIC_INLINE pic_value pic_undef_value();
PIC_INLINE pic_value pic_invalid_value();
PIC_INLINE pic_value pic_obj_value(void *);
#if PIC_ENABLE_FLOAT
PIC_INLINE pic_value pic_float_value(double);
#endif
PIC_INLINE pic_value pic_int_value(int);
PIC_INLINE pic_value pic_size_value(size_t);
PIC_INLINE pic_value pic_char_value(char c);
static inline bool pic_eq_p(pic_value, pic_value);
static inline bool pic_eqv_p(pic_value, pic_value);
PIC_INLINE bool pic_eq_p(pic_value, pic_value);
PIC_INLINE bool pic_eqv_p(pic_value, pic_value);
static inline enum pic_tt
PIC_INLINE enum pic_tt
pic_type(pic_value v)
{
switch (pic_vtype(v)) {
@ -211,12 +259,14 @@ pic_type(pic_value v)
return PIC_TT_BOOL;
case PIC_VTYPE_UNDEF:
return PIC_TT_UNDEF;
case PIC_VTYPE_INVALID:
return PIC_TT_INVALID;
#if PIC_ENABLE_FLOAT
case PIC_VTYPE_FLOAT:
return PIC_TT_FLOAT;
#endif
case PIC_VTYPE_INT:
return PIC_TT_INT;
case PIC_VTYPE_SYMBOL:
return PIC_TT_SYMBOL;
case PIC_VTYPE_CHAR:
return PIC_TT_CHAR;
case PIC_VTYPE_EOF:
@ -228,7 +278,7 @@ pic_type(pic_value v)
PIC_UNREACHABLE();
}
static inline const char *
PIC_INLINE const char *
pic_type_repr(enum pic_tt tt)
{
switch (tt) {
@ -236,8 +286,10 @@ pic_type_repr(enum pic_tt tt)
return "nil";
case PIC_TT_BOOL:
return "boolean";
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT:
return "float";
#endif
case PIC_TT_INT:
return "int";
case PIC_TT_SYMBOL:
@ -248,6 +300,8 @@ pic_type_repr(enum pic_tt tt)
return "eof";
case PIC_TT_UNDEF:
return "undef";
case PIC_TT_INVALID:
return "invalid";
case PIC_TT_PAIR:
return "pair";
case PIC_TT_STRING:
@ -260,14 +314,12 @@ pic_type_repr(enum pic_tt tt)
return "port";
case PIC_TT_ERROR:
return "error";
case PIC_TT_ENV:
return "env";
case PIC_TT_CXT:
return "cxt";
case PIC_TT_PROC:
return "proc";
case PIC_TT_SENV:
return "senv";
case PIC_TT_MACRO:
return "macro";
case PIC_TT_ENV:
return "env";
case PIC_TT_LIB:
return "lib";
case PIC_TT_IREP:
@ -276,19 +328,15 @@ pic_type_repr(enum pic_tt tt)
return "data";
case PIC_TT_DICT:
return "dict";
case PIC_TT_REG:
return "reg";
case PIC_TT_RECORD:
return "record";
}
PIC_UNREACHABLE();
}
static inline bool
pic_valid_int(double v)
{
return INT_MIN <= v && v <= INT_MAX;
}
static inline pic_value
PIC_INLINE pic_value
pic_nil_value()
{
pic_value v;
@ -297,7 +345,7 @@ pic_nil_value()
return v;
}
static inline pic_value
PIC_INLINE pic_value
pic_true_value()
{
pic_value v;
@ -306,7 +354,7 @@ pic_true_value()
return v;
}
static inline pic_value
PIC_INLINE pic_value
pic_false_value()
{
pic_value v;
@ -315,7 +363,7 @@ pic_false_value()
return v;
}
static inline pic_value
PIC_INLINE pic_value
pic_bool_value(bool b)
{
pic_value v;
@ -324,20 +372,22 @@ pic_bool_value(bool b)
return v;
}
static inline pic_value
PIC_INLINE pic_value
pic_size_value(size_t s)
{
#if PIC_ENABLE_FLOAT
if (sizeof(unsigned) < sizeof(size_t)) {
if (s > (size_t)INT_MAX) {
return pic_float_value(s);
}
}
#endif
return pic_int_value((int)s);
}
#if PIC_NAN_BOXING
static inline pic_value
PIC_INLINE pic_value
pic_obj_value(void *ptr)
{
pic_value v;
@ -347,7 +397,7 @@ pic_obj_value(void *ptr)
return v;
}
static inline pic_value
PIC_INLINE pic_value
pic_float_value(double f)
{
union { double f; uint64_t i; } u;
@ -360,7 +410,7 @@ pic_float_value(double f)
}
}
static inline pic_value
PIC_INLINE pic_value
pic_int_value(int i)
{
union { int i; unsigned u; } u;
@ -373,20 +423,7 @@ pic_int_value(int i)
return v;
}
static inline pic_value
pic_symbol_value(pic_sym sym)
{
union { int i; unsigned u; } u;
pic_value v;
u.i = sym;
pic_init_value(v, PIC_VTYPE_SYMBOL);
v |= u.u;
return v;
}
static inline pic_value
PIC_INLINE pic_value
pic_char_value(char c)
{
pic_value v;
@ -396,9 +433,29 @@ pic_char_value(char c)
return v;
}
#elif PIC_WORD_BOXING
PIC_INLINE pic_value
pic_obj_value(void *ptr)
{
return (pic_value)ptr;
}
PIC_INLINE pic_value
pic_int_value(int i)
{
return (i << 2) + 1;
}
PIC_INLINE pic_value
pic_char_value(char c)
{
return (c << 3) + 3;
}
#else
static inline pic_value
PIC_INLINE pic_value
pic_obj_value(void *ptr)
{
pic_value v;
@ -408,7 +465,9 @@ pic_obj_value(void *ptr)
return v;
}
static inline pic_value
#if PIC_ENABLE_FLOAT
PIC_INLINE pic_value
pic_float_value(double f)
{
pic_value v;
@ -418,7 +477,9 @@ pic_float_value(double f)
return v;
}
static inline pic_value
#endif
PIC_INLINE pic_value
pic_int_value(int i)
{
pic_value v;
@ -428,17 +489,7 @@ pic_int_value(int i)
return v;
}
static inline pic_value
pic_symbol_value(pic_sym sym)
{
pic_value v;
pic_init_value(v, PIC_VTYPE_SYMBOL);
v.u.sym = sym;
return v;
}
static inline pic_value
PIC_INLINE pic_value
pic_char_value(char c)
{
pic_value v;
@ -450,7 +501,7 @@ pic_char_value(char c)
#endif
static inline pic_value
PIC_INLINE pic_value
pic_undef_value()
{
pic_value v;
@ -459,25 +510,24 @@ pic_undef_value()
return v;
}
static inline pic_value
pic_none_value()
PIC_INLINE pic_value
pic_invalid_value()
{
#if PIC_NONE_IS_FALSE
return pic_false_value();
#else
# error enable PIC_NONE_IS_FALSE
#endif
pic_value v;
pic_init_value(v, PIC_VTYPE_INVALID);
return v;
}
#if PIC_NAN_BOXING
#if PIC_NAN_BOXING || PIC_WORD_BOXING
static inline bool
PIC_INLINE bool
pic_eq_p(pic_value x, pic_value y)
{
return x == y;
}
static inline bool
PIC_INLINE bool
pic_eqv_p(pic_value x, pic_value y)
{
return x == y;
@ -485,7 +535,7 @@ pic_eqv_p(pic_value x, pic_value y)
#else
static inline bool
PIC_INLINE bool
pic_eq_p(pic_value x, pic_value y)
{
if (pic_type(x) != pic_type(y))
@ -496,14 +546,12 @@ pic_eq_p(pic_value x, pic_value y)
return true;
case PIC_TT_BOOL:
return pic_vtype(x) == pic_vtype(y);
case PIC_TT_SYMBOL:
return pic_sym(x) == pic_sym(y);
default:
return pic_ptr(x) == pic_ptr(y);
}
}
static inline bool
PIC_INLINE bool
pic_eqv_p(pic_value x, pic_value y)
{
if (pic_type(x) != pic_type(y))
@ -514,10 +562,10 @@ pic_eqv_p(pic_value x, pic_value y)
return true;
case PIC_TT_BOOL:
return pic_vtype(x) == pic_vtype(y);
case PIC_TT_SYMBOL:
return pic_sym(x) == pic_sym(y);
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT:
return pic_float(x) == pic_float(y);
#endif
case PIC_TT_INT:
return pic_int(x) == pic_int(y);
default:

633
extlib/benz/include/picrin/xfile.h
View File

@ -5,571 +5,104 @@
extern "C" {
#endif
#include <stdio.h>
#ifndef NULL
# define NULL 0
#endif
#ifndef EOF
# define EOF (-1)
#endif
#define XBUFSIZ 1024
#define XOPEN_MAX 1024
typedef struct {
int ungot;
int flags;
/* buffer */
char buf[1]; /* fallback buffer */
long cnt; /* characters left */
char *ptr; /* next character position */
char *base; /* location of the buffer */
/* operators */
struct {
void *cookie;
int (*read)(void *, char *, int);
int (*write)(void *, const char *, int);
long (*seek)(void *, long, int);
int (*flush)(void *);
int (*close)(void *);
} vtable;
int flag; /* mode of the file access */
} xFILE;
/* generic file constructor */
static inline xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*flush)(void *), int (*close)(void *));
extern xFILE x_iob[XOPEN_MAX];
/* resource aquisition */
static inline xFILE *xfpopen(FILE *);
static inline xFILE *xmopen();
static inline xFILE *xfopen(const char *, const char *);
static inline int xfclose(xFILE *);
#define xstdin (x_iob[0].vtable.cookie || (x_iob[0].vtable.cookie = stdin ), &x_iob[0])
#define xstdout (x_iob[1].vtable.cookie || (x_iob[1].vtable.cookie = stdout), &x_iob[1])
#define xstderr (x_iob[2].vtable.cookie || (x_iob[2].vtable.cookie = stderr), &x_iob[2])
/* buffer management */
static inline int xfflush(xFILE *);
/* direct IO with buffering */
static inline size_t xfread(void *, size_t, size_t, xFILE *);
static inline size_t xfwrite(const void *, size_t, size_t, xFILE *);
/* indicator positioning */
static inline long xfseek(xFILE *, long offset, int whence);
static inline long xftell(xFILE *);
static inline void xrewind(xFILE *);
/* stream status */
static inline void xclearerr(xFILE *);
static inline int xfeof(xFILE *);
static inline int xferror(xFILE *);
/* character IO */
static inline int xfgetc(xFILE *);
static inline char *xfgets(char *, int, xFILE *);
static inline int xfputc(int, xFILE *);
static inline int xfputs(const char *, xFILE *);
static inline int xgetc(xFILE *);
static inline int xgetchar(void);
static inline int xputc(int, xFILE *);
static inline int xputchar(int);
static inline int xputs(const char *);
static inline int xungetc(int, xFILE *);
/* formatted I/O */
static inline int xprintf(const char *, ...);
static inline int xfprintf(xFILE *, const char *, ...);
static inline int xvfprintf(xFILE *, const char *, va_list);
/* standard I/O */
#define xstdin (xstdin_())
#define xstdout (xstdout_())
#define xstderr (xstderr_())
/* private */
#define XF_EOF 1
#define XF_ERR 2
static inline xFILE *
xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*flush)(void *), int (*close)(void *))
{
xFILE *file;
file = (xFILE *)malloc(sizeof(xFILE));
if (! file) {
return NULL;
}
file->ungot = -1;
file->flags = 0;
/* set vtable */
file->vtable.cookie = cookie;
file->vtable.read = read;
file->vtable.write = write;
file->vtable.seek = seek;
file->vtable.flush = flush;
file->vtable.close = close;
return file;
}
/*
* Derieved xFILE Classes
*/
static inline int
xf_file_read(void *cookie, char *ptr, int size)
{
FILE *file = cookie;
int r;
r = (int)fread(ptr, 1, (size_t)size, file);
if (r < size && ferror(file)) {
return -1;
}
if (r == 0 && feof(file)) {
clearerr(file);
}
return r;
}
static inline int
xf_file_write(void *cookie, const char *ptr, int size)
{
FILE *file = cookie;
int r;
r = (int)fwrite(ptr, 1, (size_t)size, file);
if (r < size) {
return -1;
}
return r;
}
static inline long
xf_file_seek(void *cookie, long pos, int whence)
{
return fseek(cookie, pos, whence);
}
static inline int
xf_file_flush(void *cookie)
{
return fflush(cookie);
}
static inline int
xf_file_close(void *cookie)
{
return fclose(cookie);
}
static inline xFILE *
xfpopen(FILE *fp)
{
xFILE *file;
file = xfunopen(fp, xf_file_read, xf_file_write, xf_file_seek, xf_file_flush, xf_file_close);
if (! file) {
return NULL;
}
return file;
}
#define XF_FILE_VTABLE xf_file_read, xf_file_write, xf_file_seek, xf_file_flush, xf_file_close
static inline xFILE *
xstdin_()
{
static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } };
if (! x.vtable.cookie) {
x.vtable.cookie = stdin;
}
return &x;
}
static inline xFILE *
xstdout_()
{
static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } };
if (! x.vtable.cookie) {
x.vtable.cookie = stdout;
}
return &x;
}
static inline xFILE *
xstderr_()
{
static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } };
if (! x.vtable.cookie) {
x.vtable.cookie = stderr;
}
return &x;
}
struct xf_membuf {
char *buf;
long pos, end, capa;
enum _flags {
X_READ = 01,
X_WRITE = 02,
X_UNBUF = 04,
X_EOF = 010,
X_ERR = 020,
X_LNBUF = 040
};
static inline int
xf_mem_read(void *cookie, char *ptr, int size)
{
struct xf_membuf *mem;
mem = (struct xf_membuf *)cookie;
if (size > (int)(mem->end - mem->pos))
size = (int)(mem->end - mem->pos);
memcpy(ptr, mem->buf + mem->pos, size);
mem->pos += size;
return size;
}
static inline int
xf_mem_write(void *cookie, const char *ptr, int size)
{
struct xf_membuf *mem;
mem = (struct xf_membuf *)cookie;
if (mem->pos + size >= mem->capa) {
mem->capa = (mem->pos + size) * 2;
mem->buf = realloc(mem->buf, (size_t)mem->capa);
}
memcpy(mem->buf + mem->pos, ptr, size);
mem->pos += size;
if (mem->end < mem->pos)
mem->end = mem->pos;
return size;
}
static inline long
xf_mem_seek(void *cookie, long pos, int whence)
{
struct xf_membuf *mem;
mem = (struct xf_membuf *)cookie;
switch (whence) {
case SEEK_SET:
mem->pos = pos;
break;
case SEEK_CUR:
mem->pos += pos;
break;
case SEEK_END:
mem->pos = mem->end + pos;
break;
}
return mem->pos;
}
static inline int
xf_mem_flush(void *cookie)
{
(void)cookie;
return 0;
}
static inline int
xf_mem_close(void *cookie)
{
struct xf_membuf *mem;
mem = (struct xf_membuf *)cookie;
free(mem->buf);
free(mem);
return 0;
}
static inline xFILE *
xmopen()
{
struct xf_membuf *mem;
mem = (struct xf_membuf *)malloc(sizeof(struct xf_membuf));
mem->buf = (char *)malloc(BUFSIZ);
mem->pos = 0;
mem->end = 0;
mem->capa = BUFSIZ;
return xfunopen(mem, xf_mem_read, xf_mem_write, xf_mem_seek, xf_mem_flush, xf_mem_close);
}
#undef XF_FILE_VTABLE
static inline xFILE *
xfopen(const char *filename, const char *mode)
{
FILE *fp;
xFILE *file;
fp = fopen(filename, mode);
if (! fp) {
return NULL;
}
file = xfpopen(fp);
if (! file) {
return NULL;
}
return file;
}
static inline int
xfclose(xFILE *file)
{
int r;
r = file->vtable.close(file->vtable.cookie);
if (r == EOF) {
return -1;
}
free(file);
return 0;
}
static inline int
xfflush(xFILE *file)
{
return file->vtable.flush(file->vtable.cookie);
}
static inline size_t
xfread(void *ptr, size_t block, size_t nitems, xFILE *file)
{
char *dst = (char *)ptr;
char buf[block];
size_t i, offset;
int n;
for (i = 0; i < nitems; ++i) {
offset = 0;
if (file->ungot != -1 && block > 0) {
buf[0] = (char)file->ungot;
offset += 1;
file->ungot = -1;
}
while (offset < block) {
n = file->vtable.read(file->vtable.cookie, buf + offset, (int)(block - offset));
if (n < 0) {
file->flags |= XF_ERR;
goto exit;
}
if (n == 0) {
file->flags |= XF_EOF;
goto exit;
}
offset += (unsigned)n;
}
memcpy(dst, buf, block);
dst += block;
}
exit:
return i;
}
static inline size_t
xfwrite(const void *ptr, size_t block, size_t nitems, xFILE *file)
{
char *dst = (char *)ptr;
size_t i, offset;
int n;
for (i = 0; i < nitems; ++i) {
offset = 0;
while (offset < block) {
n = file->vtable.write(file->vtable.cookie, dst + offset, (int)(block - offset));
if (n < 0) {
file->flags |= XF_ERR;
goto exit;
}
offset += (unsigned)n;
}
dst += block;
}
exit:
return i;
}
static inline long
xfseek(xFILE *file, long offset, int whence)
{
file->ungot = -1;
return file->vtable.seek(file->vtable.cookie, offset, whence);
}
static inline long
xftell(xFILE *file)
{
return xfseek(file, 0, SEEK_CUR);
}
static inline void
xrewind(xFILE *file)
{
xfseek(file, 0, SEEK_SET);
}
static inline void
xclearerr(xFILE *file)
{
file->flags = 0;
}
static inline int
xfeof(xFILE *file)
{
return file->flags & XF_EOF;
}
static inline int
xferror(xFILE *file)
{
return file->flags & XF_ERR;
}
static inline int
xfgetc(xFILE *file)
{
char buf[1];
xfread(buf, 1, 1, file);
if (xfeof(file) || xferror(file)) {
return EOF;
}
return buf[0];
}
static inline int
xgetc(xFILE *file)
{
return xfgetc(file);
}
static inline char *
xfgets(char *str, int size, xFILE *file)
{
int c = EOF, i;
for (i = 0; i < size - 1 && c != '\n'; ++i) {
if ((c = xfgetc(file)) == EOF) {
break;
}
str[i] = (char)c;
}
if (i == 0 && c == EOF) {
return NULL;
}
if (xferror(file)) {
return NULL;
}
str[i] = '\0';
return str;
}
static inline int
xungetc(int c, xFILE *file)
{
file->ungot = c;
if (c != EOF) {
file->flags &= ~XF_EOF;
}
return c;
}
static inline int
xgetchar(void)
{
return xfgetc(xstdin);
}
static inline int
xfputc(int c, xFILE *file)
{
char buf[1];
buf[0] = (char)c;
xfwrite(buf, 1, 1, file);
if (xferror(file)) {
return EOF;
}
return buf[0];
}
static inline int
xputc(int c, xFILE *file)
{
return xfputc(c, file);
}
static inline int
xputchar(int c)
{
return xfputc(c, xstdout);
}
static inline int
xfputs(const char *str, xFILE *file)
{
size_t len;
len = strlen(str);
xfwrite(str, len, 1, file);
if (xferror(file)) {
return EOF;
}
return 0;
}
static inline int
xputs(const char *s)
{
return xfputs(s, xstdout);
}
static inline int
xprintf(const char *fmt, ...)
{
va_list ap;
int n;
va_start(ap, fmt);
n = xvfprintf(xstdout, fmt, ap);
va_end(ap);
return n;
}
static inline int
xfprintf(xFILE *stream, const char *fmt, ...)
{
va_list ap;
int n;
va_start(ap, fmt);
n = xvfprintf(stream, fmt, ap);
va_end(ap);
return n;
}
static inline int
xvfprintf(xFILE *stream, const char *fmt, va_list ap)
{
va_list ap2;
va_copy(ap2, ap);
{
char buf[vsnprintf(NULL, 0, fmt, ap2)];
vsnprintf(buf, sizeof buf + 1, fmt, ap);
if (xfwrite(buf, sizeof buf, 1, stream) < 1) {
return -1;
}
va_end(ap2);
return (int)(sizeof buf);
}
}
#define xclearerr(p) ((p)->flag &= ~(X_EOF | X_ERR))
#define xfeof(p) (((p)->flag & X_EOF) != 0)
#define xferror(p) (((p)->flag & X_ERR) != 0)
#define xfileno(p) ((p)->fd)
#define xgetc(p) \
((--(p)->cnt >= 0) \
? (unsigned char) *(p)->ptr++ \
: x_fillbuf(p))
#define xputc(x, p) \
((--(p)->cnt >= 0 && !(((p)->flag & X_LNBUF) && (x) == '\n')) \
? *(p)->ptr++ = (x) \
: x_flushbuf(x, (p)))
#define xgetchar() xgetc(xstdin)
#define xputchar(x) xputc((x), xstdout)
/* resource aquisition */
xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*close)(void *));
xFILE *xfopen(const char *, const char *);
int xfclose(xFILE *);
/* buffer management */
int x_fillbuf(xFILE *);
int x_flushbuf(int, xFILE *);
int xfflush(xFILE *);
/* direct IO */
size_t xfread(void *, size_t, size_t, xFILE *);
size_t xfwrite(const void *, size_t, size_t, xFILE *);
enum {
XSEEK_CUR,
XSEEK_END,
XSEEK_SET
};
/* indicator positioning */
long xfseek(xFILE *, long, int);
long xftell(xFILE *);
void xrewind(xFILE *);
/* character IO */
int xfputc(int, xFILE *);
int xfgetc(xFILE *);
int xfputs(const char *, xFILE *);
char *xfgets(char *, int, xFILE *);
int xputs(const char *);
int xungetc(int, xFILE *);
/* formatted I/O */
int xprintf(const char *, ...);
int xfprintf(xFILE *, const char *, ...);
int xvfprintf(xFILE *, const char *, va_list);
#if defined(__cplusplus)
}

141
extlib/benz/include/picrin/xhash.h
View File

@ -9,10 +9,12 @@
extern "C" {
#endif
#define XHASH_ALLOCATOR pic->allocf
/* simple object to object hash table */
#define XHASH_INIT_SIZE 11
#define XHASH_RESIZE_RATIO 0.75
#define XHASH_RESIZE_RATIO(x) ((x) * 3 / 4)
#define XHASH_ALIGNMENT 3 /* quad word alignment */
#define XHASH_MASK (~(size_t)((1 << XHASH_ALIGNMENT) - 1))
@ -31,8 +33,10 @@ typedef struct xh_entry {
typedef int (*xh_hashf)(const void *, void *);
typedef int (*xh_equalf)(const void *, const void *, void *);
typedef void *(*xh_allocf)(void *, size_t);
typedef struct xhash {
xh_allocf allocf;
xh_entry **buckets;
size_t size, count, kwidth, vwidth;
size_t koffset, voffset;
@ -50,42 +54,40 @@ typedef struct xhash {
*/
/* string map */
static inline void xh_init_str(xhash *x, size_t width);
static inline xh_entry *xh_get_str(xhash *x, const char *key);
static inline xh_entry *xh_put_str(xhash *x, const char *key, void *);
static inline void xh_del_str(xhash *x, const char *key);
PIC_INLINE xh_entry *xh_get_str(xhash *x, const char *key);
PIC_INLINE xh_entry *xh_put_str(xhash *x, const char *key, void *);
PIC_INLINE void xh_del_str(xhash *x, const char *key);
/* object map */
static inline void xh_init_ptr(xhash *x, size_t width);
static inline xh_entry *xh_get_ptr(xhash *x, const void *key);
static inline xh_entry *xh_put_ptr(xhash *x, const void *key, void *);
static inline void xh_del_ptr(xhash *x, const void *key);
PIC_INLINE xh_entry *xh_get_ptr(xhash *x, const void *key);
PIC_INLINE xh_entry *xh_put_ptr(xhash *x, const void *key, void *);
PIC_INLINE void xh_del_ptr(xhash *x, const void *key);
/* int map */
static inline void xh_init_int(xhash *x, size_t width);
static inline xh_entry *xh_get_int(xhash *x, int key);
static inline xh_entry *xh_put_int(xhash *x, int key, void *);
static inline void xh_del_int(xhash *x, int key);
PIC_INLINE xh_entry *xh_get_int(xhash *x, int key);
PIC_INLINE xh_entry *xh_put_int(xhash *x, int key, void *);
PIC_INLINE void xh_del_int(xhash *x, int key);
static inline size_t xh_size(xhash *x);
static inline void xh_clear(xhash *x);
static inline void xh_destroy(xhash *x);
PIC_INLINE size_t xh_size(xhash *x);
PIC_INLINE void xh_clear(xhash *x);
PIC_INLINE void xh_destroy(xhash *x);
static inline xh_entry *xh_begin(xhash *x);
static inline xh_entry *xh_next(xh_entry *e);
PIC_INLINE xh_entry *xh_begin(xhash *x);
PIC_INLINE xh_entry *xh_next(xh_entry *e);
static inline void
xh_bucket_realloc(xhash *x, size_t newsize)
PIC_INLINE void
xh_bucket_alloc(xhash *x, size_t newsize)
{
x->size = newsize;
x->buckets = realloc(x->buckets, (x->size + 1) * sizeof(xh_entry *));
x->buckets = x->allocf(NULL, (x->size + 1) * sizeof(xh_entry *));
memset(x->buckets, 0, (x->size + 1) * sizeof(xh_entry *));
}
static inline void
xh_init_(xhash *x, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equalf, void *data)
PIC_INLINE void
xh_init_(xhash *x, xh_allocf allocf, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equalf, void *data)
{
x->allocf = allocf;
x->size = 0;
x->buckets = NULL;
x->count = 0;
@ -99,10 +101,10 @@ xh_init_(xhash *x, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equal
x->tail = NULL;
x->data = data;
xh_bucket_realloc(x, XHASH_INIT_SIZE);
xh_bucket_alloc(x, XHASH_INIT_SIZE);
}
static inline xh_entry *
PIC_INLINE xh_entry *
xh_get_(xhash *x, const void *key)
{
int hash;
@ -118,15 +120,15 @@ xh_get_(xhash *x, const void *key)
return e;
}
static inline void
PIC_INLINE void
xh_resize_(xhash *x, size_t newsize)
{
xhash y;
xh_entry *it;
size_t idx;
xh_init_(&y, x->kwidth, x->vwidth, x->hashf, x->equalf, x->data);
xh_bucket_realloc(&y, newsize);
xh_init_(&y, x->allocf, x->kwidth, x->vwidth, x->hashf, x->equalf, x->data);
xh_bucket_alloc(&y, newsize);
for (it = xh_begin(x); it != NULL; it = xh_next(it)) {
idx = ((unsigned)it->hash) % y.size;
@ -139,13 +141,13 @@ xh_resize_(xhash *x, size_t newsize)
y.head = x->head;
y.tail = x->tail;
free(x->buckets);
x->allocf(x->buckets, 0);
/* copy all members from y to x */
memcpy(x, &y, sizeof(xhash));
}
static inline xh_entry *
PIC_INLINE xh_entry *
xh_put_(xhash *x, const void *key, void *val)
{
int hash;
@ -157,13 +159,13 @@ xh_put_(xhash *x, const void *key, void *val)
return e;
}
if (x->count + 1 > x->size * XHASH_RESIZE_RATIO) {
if (x->count + 1 > XHASH_RESIZE_RATIO(x->size)) {
xh_resize_(x, x->size * 2 + 1);
}
hash = x->hashf(key, x->data);
idx = ((unsigned)hash) % x->size;
e = malloc(x->voffset + x->vwidth);
e = x->allocf(NULL, x->voffset + x->vwidth);
e->next = x->buckets[idx];
e->hash = hash;
e->key = ((char *)e) + x->koffset;
@ -186,7 +188,7 @@ xh_put_(xhash *x, const void *key, void *val)
return x->buckets[idx] = e;
}
static inline void
PIC_INLINE void
xh_del_(xhash *x, const void *key)
{
int hash;
@ -208,7 +210,7 @@ xh_del_(xhash *x, const void *key)
q->bw->fw = q->fw;
}
r = q->next;
free(q);
x->allocf(q, 0);
x->buckets[idx] = r;
}
else {
@ -228,20 +230,20 @@ xh_del_(xhash *x, const void *key)
q->bw->fw = q->fw;
}
r = q->next;
free(q);
x->allocf(q, 0);
p->next = r;
}
x->count--;
}
static inline size_t
PIC_INLINE size_t
xh_size(xhash *x)
{
return x->count;
}
static inline void
PIC_INLINE void
xh_clear(xhash *x)
{
size_t i;
@ -251,7 +253,7 @@ xh_clear(xhash *x)
e = x->buckets[i];
while (e) {
d = e->next;
free(e);
x->allocf(e, 0);
e = d;
}
x->buckets[i] = NULL;
@ -261,16 +263,16 @@ xh_clear(xhash *x)
x->count = 0;
}
static inline void
PIC_INLINE void
xh_destroy(xhash *x)
{
xh_clear(x);
free(x->buckets);
x->allocf(x->buckets, 0);
}
/* string map */
static inline int
PIC_INLINE int
xh_str_hash(const void *key, void *data)
{
const char *str = *(const char **)key;
@ -284,33 +286,32 @@ xh_str_hash(const void *key, void *data)
return hash;
}
static inline int
PIC_INLINE int
xh_str_equal(const void *key1, const void *key2, void *data)
{
const char *s1 = *(const char **)key1, *s2 = *(const char **)key2;
(void)data;
return strcmp(*(const char **)key1, *(const char **)key2) == 0;
return strcmp(s1, s2) == 0;
}
static inline void
xh_init_str(xhash *x, size_t width)
{
xh_init_(x, sizeof(const char *), width, xh_str_hash, xh_str_equal, NULL);
}
#define xh_init_str(x, width) \
xh_init_(x, XHASH_ALLOCATOR, sizeof(const char *), width, xh_str_hash, xh_str_equal, NULL);
static inline xh_entry *
PIC_INLINE xh_entry *
xh_get_str(xhash *x, const char *key)
{
return xh_get_(x, &key);
}
static inline xh_entry *
PIC_INLINE xh_entry *
xh_put_str(xhash *x, const char *key, void *val)
{
return xh_put_(x, &key, val);
}
static inline void
PIC_INLINE void
xh_del_str(xhash *x, const char *key)
{
xh_del_(x, &key);
@ -318,7 +319,7 @@ xh_del_str(xhash *x, const char *key)
/* object map */
static inline int
PIC_INLINE int
xh_ptr_hash(const void *key, void *data)
{
(void)data;
@ -326,7 +327,7 @@ xh_ptr_hash(const void *key, void *data)
return (int)(size_t)*(const void **)key;
}
static inline int
PIC_INLINE int
xh_ptr_equal(const void *key1, const void *key2, void *data)
{
(void) data;
@ -334,25 +335,22 @@ xh_ptr_equal(const void *key1, const void *key2, void *data)
return *(const void **)key1 == *(const void **)key2;
}
static inline void
xh_init_ptr(xhash *x, size_t width)
{
xh_init_(x, sizeof(const void *), width, xh_ptr_hash, xh_ptr_equal, NULL);
}
#define xh_init_ptr(x, width) \
xh_init_(x, XHASH_ALLOCATOR, sizeof(const void *), width, xh_ptr_hash, xh_ptr_equal, NULL);
static inline xh_entry *
PIC_INLINE xh_entry *
xh_get_ptr(xhash *x, const void *key)
{
return xh_get_(x, &key);
}
static inline xh_entry *
PIC_INLINE xh_entry *
xh_put_ptr(xhash *x, const void *key, void *val)
{
return xh_put_(x, &key, val);
}
static inline void
PIC_INLINE void
xh_del_ptr(xhash *x, const void *key)
{
xh_del_(x, &key);
@ -360,7 +358,7 @@ xh_del_ptr(xhash *x, const void *key)
/* int map */
static inline int
PIC_INLINE int
xh_int_hash(const void *key, void *data)
{
(void)data;
@ -368,7 +366,7 @@ xh_int_hash(const void *key, void *data)
return *(int *)key;
}
static inline int
PIC_INLINE int
xh_int_equal(const void *key1, const void *key2, void *data)
{
(void)data;
@ -376,25 +374,22 @@ xh_int_equal(const void *key1, const void *key2, void *data)
return *(int *)key1 == *(int *)key2;
}
static inline void
xh_init_int(xhash *x, size_t width)
{
xh_init_(x, sizeof(int), width, xh_int_hash, xh_int_equal, NULL);
}
#define xh_init_int(x, width) \
xh_init_(x, XHASH_ALLOCATOR, sizeof(int), width, xh_int_hash, xh_int_equal, NULL);
static inline xh_entry *
PIC_INLINE xh_entry *
xh_get_int(xhash *x, int key)
{
return xh_get_(x, &key);
}
static inline xh_entry *
PIC_INLINE xh_entry *
xh_put_int(xhash *x, int key, void *val)
{
return xh_put_(x, &key, val);
}
static inline void
PIC_INLINE void
xh_del_int(xhash *x, int key)
{
xh_del_(x, &key);
@ -402,13 +397,13 @@ xh_del_int(xhash *x, int key)
/** iteration */
static inline xh_entry *
PIC_INLINE xh_entry *
xh_begin(xhash *x)
{
return x->head;
}
static inline xh_entry *
PIC_INLINE xh_entry *
xh_next(xh_entry *e)
{
return e->bw;

324
extlib/benz/include/picrin/xrope.h
View File

@ -1,324 +0,0 @@
#ifndef XROPE_H__
#define XROPE_H__
#if defined(__cplusplus)
extern "C" {
#endif
/* public APIs */
typedef struct xrope xrope;
/**
* | name | frees buffer? | end with NULL? | complexity | misc
* | ---- | ---- | ---- | ---- | ---
* | xr_new_cstr | no | yes | O(1) | xr_new(_lit)
* | xr_new_imbed | no | no | O(1) |
* | xr_new_move | yes | yes | O(1) |
* | xr_new_copy | yes | no | O(n) |
*/
#define xr_new(cstr) xr_new_cstr(cstr, strlen(cstr))
#define xr_new_lit(cstr) xr_new_cstr(cstr, sizeof(cstr) - 1)
static inline xrope *xr_new_cstr(const char *, size_t);
static inline xrope *xr_new_imbed(const char *, size_t);
static inline xrope *xr_new_move(const char *, size_t);
static inline xrope *xr_new_copy(const char *, size_t);
static inline void XROPE_INCREF(xrope *);
static inline void XROPE_DECREF(xrope *);
static inline size_t xr_len(xrope *);
static inline char xr_at(xrope *, size_t);
static inline xrope *xr_cat(xrope *, xrope *);
static inline xrope *xr_sub(xrope *, size_t, size_t);
static inline const char *xr_cstr(xrope *); /* returns NULL-terminated string */
/* impl */
typedef struct {
char *str;
int refcnt;
size_t len;
char autofree, zeroterm;
} xr_chunk;
#define XR_CHUNK_INCREF(c) do { \
(c)->refcnt++; \
} while (0)
#define XR_CHUNK_DECREF(c) do { \
xr_chunk *c__ = (c); \
if (! --c__->refcnt) { \
if (c__->autofree) \
free(c__->str); \
free(c__); \
} \
} while (0)
struct xrope {
int refcnt;
size_t weight;
xr_chunk *chunk;
size_t offset;
struct xrope *left, *right;
};
static inline void
XROPE_INCREF(xrope *x) {
x->refcnt++;
}
static inline void
XROPE_DECREF(xrope *x) {
if (! --x->refcnt) {
if (x->chunk) {
XR_CHUNK_DECREF(x->chunk);
free(x);
return;
}
XROPE_DECREF(x->left);
XROPE_DECREF(x->right);
free(x);
}
}
static inline xrope *
xr_new_cstr(const char *cstr, size_t len)
{
xr_chunk *c;
xrope *x;
c = (xr_chunk *)malloc(sizeof(xr_chunk));
c->refcnt = 1;
c->str = (char *)cstr;
c->len = len;
c->autofree = 0;
c->zeroterm = 1;
x = (xrope *)malloc(sizeof(xrope));
x->refcnt = 1;
x->left = NULL;
x->right = NULL;
x->weight = c->len;
x->offset = 0;
x->chunk = c;
return x;
}
static inline xrope *
xr_new_imbed(const char *str, size_t len)
{
xr_chunk *c;
xrope *x;
c = (xr_chunk *)malloc(sizeof(xr_chunk));
c->refcnt = 1;
c->str = (char *)str;
c->len = len;
c->autofree = 0;
c->zeroterm = 0;
x = (xrope *)malloc(sizeof(xrope));
x->refcnt = 1;
x->left = NULL;
x->right = NULL;
x->weight = c->len;
x->offset = 0;
x->chunk = c;
return x;
}
static inline xrope *
xr_new_move(const char *cstr, size_t len)
{
xr_chunk *c;
xrope *x;
c = (xr_chunk *)malloc(sizeof(xr_chunk));
c->refcnt = 1;
c->str = (char *)cstr;
c->len = len;
c->autofree = 1;
c->zeroterm = 1;
x = (xrope *)malloc(sizeof(xrope));
x->refcnt = 1;
x->left = NULL;
x->right = NULL;
x->weight = c->len;
x->offset = 0;
x->chunk = c;
return x;
}
static inline xrope *
xr_new_copy(const char *str, size_t len)
{
char *buf;
xr_chunk *c;
xrope *x;
buf = (char *)malloc(len + 1);
buf[len] = '\0';
memcpy(buf, str, len);
c = (xr_chunk *)malloc(sizeof(xr_chunk));
c->refcnt = 1;
c->str = buf;
c->len = len;
c->autofree = 1;
c->zeroterm = 1;
x = (xrope *)malloc(sizeof(xrope));
x->refcnt = 1;
x->left = NULL;
x->right = NULL;
x->weight = c->len;
x->offset = 0;
x->chunk = c;
return x;
}
static inline size_t
xr_len(xrope *x)
{
return x->weight;
}
static inline char
xr_at(xrope *x, size_t i)
{
if (x->weight <= i) {
return -1;
}
if (x->chunk) {
return x->chunk->str[x->offset + i];
}
return (i < x->left->weight)
? xr_at(x->left, i)
: xr_at(x->right, i - x->left->weight);
}
static inline xrope *
xr_cat(xrope *x, xrope *y)
{
xrope *z;
z = (xrope *)malloc(sizeof(xrope));
z->refcnt = 1;
z->left = x;
z->right = y;
z->weight = x->weight + y->weight;
z->offset = 0;
z->chunk = NULL;
XROPE_INCREF(x);
XROPE_INCREF(y);
return z;
}
static inline struct xrope *
xr_sub(xrope *x, size_t i, size_t j)
{
assert(i <= j);
assert(j <= x->weight);
if (i == 0 && x->weight == j) {
XROPE_INCREF(x);
return x;
}
if (x->chunk) {
xrope *y;
y = (xrope *)malloc(sizeof(xrope));
y->refcnt = 1;
y->left = NULL;
y->right = NULL;
y->weight = j - i;
y->offset = x->offset + i;
y->chunk = x->chunk;
XR_CHUNK_INCREF(x->chunk);
return y;
}
if (j <= x->left->weight) {
return xr_sub(x->left, i, j);
}
else if (x->left->weight <= i) {
return xr_sub(x->right, i - x->left->weight, j - x->left->weight);
}
else {
xrope *r, *l;
l = xr_sub(x->left, i, x->left->weight);
r = xr_sub(x->right, 0, j - x->left->weight);
x = xr_cat(l, r);
XROPE_DECREF(l);
XROPE_DECREF(r);
return x;
}
}
static inline void
xr_fold(xrope *x, xr_chunk *c, size_t offset)
{
if (x->chunk) {
memcpy(c->str + offset, x->chunk->str + x->offset, x->weight);
XR_CHUNK_DECREF(x->chunk);
x->chunk = c;
x->offset = offset;
XR_CHUNK_INCREF(c);
return;
}
xr_fold(x->left, c, offset);
xr_fold(x->right, c, offset + x->left->weight);
XROPE_DECREF(x->left);
XROPE_DECREF(x->right);
x->left = x->right = NULL;
x->chunk = c;
x->offset = offset;
XR_CHUNK_INCREF(c);
}
static inline const char *
xr_cstr(xrope *x)
{
xr_chunk *c;
if (x->chunk && x->offset == 0 && x->weight == x->chunk->len && x->chunk->zeroterm) {
return x->chunk->str; /* reuse cached chunk */
}
c = (xr_chunk *)malloc(sizeof(xr_chunk));
c->refcnt = 1;
c->len = x->weight;
c->autofree = 1;
c->zeroterm = 1;
c->str = (char *)malloc(c->len + 1);
c->str[c->len] = '\0';
xr_fold(x, c, 0);
XR_CHUNK_DECREF(c);
return c->str;
}
#if defined(__cplusplus)
}
#endif
#endif

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