diff --git a/.gitignore b/.gitignore index d13a2485..c799dc45 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,9 @@ -build/* +*.o +bin/ +lib/ src/load_piclib.c src/init_contrib.c +docs/contrib.rst .dir-locals.el GPATH GRTAGS diff --git a/.travis.yml b/.travis.yml index 61058537..3d9ab350 100644 --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/CMakeLists.txt b/CMakeLists.txt deleted file mode 100644 index 41bfb13e..00000000 --- a/CMakeLists.txt +++ /dev/null @@ -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}) diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..ea71bca4 --- /dev/null +++ b/Makefile @@ -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) diff --git a/README.md b/README.md index dc81124d..5b5fddf2 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,20 @@ -[![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. +Just type `make` in the project root directory. You will find an executable binary newly created at bin/ directory. -- cmake (>= 2.6) + $ make +When you are building picrin on x86_64 system, PIC_NAN_BOXING flag is automatically turned on (see include/picrin/config.h for detail). -### Generate Makefile +## Install -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/. - - $ 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). - -### 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 install prefix=/path/to/dir - $ 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 .. - ## 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 diff --git a/build/.gitkeep b/bin/.gitkeep similarity index 100% rename from build/.gitkeep rename to bin/.gitkeep diff --git a/cmake/FindPYTHON.cmake b/cmake/FindPYTHON.cmake deleted file mode 100644 index 3268da79..00000000 --- a/cmake/FindPYTHON.cmake +++ /dev/null @@ -1,193 +0,0 @@ -############################################################################## -# @file FindPythonInterp.cmake -# @brief Find Python interpreter. -# -# @par Input variables: -# -# -# @tp @b Python_ADDITIONAL_VERSIONS @endtp -# -# -#
List of version numbers that should be taken into account when -# searching for Python.
-# -# @par Output variables: -# -# -# @tp @b PYTHONINTERP_FOUND @endtp -# -# -# -# @tp @b PYTHON_EXECUTABLE @endtp -# -# -# -# @tp @b PYTHON_VERSION_STRING @endtp -# -# -# -# @tp @b PYTHON_VERSION_MAJOR @endtp -# -# -# -# @tp @b PYTHON_VERSION_MINOR @endtp -# -# -# -# @tp @b PYTHON_VERSION_PATCH @endtp -# -# -#
Was the Python executable found.
Path to the Python interpreter.
Python version found e.g. 2.5.2.
Python major version found e.g. 2.
Python minor version found e.g. 5.
Python patch version found e.g. 2.
-# -# @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 -# Copyright 2012 Rolf Eike Beer -# -# 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) diff --git a/contrib/03.callcc/CMakeLists.txt b/contrib/03.callcc/CMakeLists.txt deleted file mode 100644 index 55a73452..00000000 --- a/contrib/03.callcc/CMakeLists.txt +++ /dev/null @@ -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}) diff --git a/contrib/03.callcc/callcc.c b/contrib/03.callcc/callcc.c index eb519331..7b6b9609 100644 --- a/contrib/03.callcc/callcc.c +++ b/contrib/03.callcc/callcc.c @@ -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_redefun(pic, pic->PICRIN_BASE, "call-with-current-continuation", pic_callcc_callcc); - pic_redefun(pic, pic->PICRIN_BASE, "call/cc", pic_callcc_callcc); + 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); + } } diff --git a/contrib/03.callcc/nitro.mk b/contrib/03.callcc/nitro.mk new file mode 100644 index 00000000..60dbe96b --- /dev/null +++ b/contrib/03.callcc/nitro.mk @@ -0,0 +1,2 @@ +CONTRIB_INITS += callcc +CONTRIB_SRCS += $(wildcard contrib/03.callcc/*.c) diff --git a/contrib/03.file/CMakeLists.txt b/contrib/03.file/CMakeLists.txt deleted file mode 100644 index 22987e3e..00000000 --- a/contrib/03.file/CMakeLists.txt +++ /dev/null @@ -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}) diff --git a/contrib/03.load/CMakeLists.txt b/contrib/03.load/CMakeLists.txt deleted file mode 100644 index bb0d6a3d..00000000 --- a/contrib/03.load/CMakeLists.txt +++ /dev/null @@ -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}) diff --git a/contrib/03.mutable-string/CMakeLists.txt b/contrib/03.mutable-string/CMakeLists.txt deleted file mode 100644 index faa8402b..00000000 --- a/contrib/03.mutable-string/CMakeLists.txt +++ /dev/null @@ -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}) diff --git a/contrib/03.system/CMakeLists.txt b/contrib/03.system/CMakeLists.txt deleted file mode 100644 index c18f3266..00000000 --- a/contrib/03.system/CMakeLists.txt +++ /dev/null @@ -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}) diff --git a/contrib/03.time/CMakeLists.txt b/contrib/03.time/CMakeLists.txt deleted file mode 100644 index dc69714a..00000000 --- a/contrib/03.time/CMakeLists.txt +++ /dev/null @@ -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}) diff --git a/contrib/05.r7rs/CMakeLists.txt b/contrib/05.r7rs/CMakeLists.txt deleted file mode 100644 index 814d80c2..00000000 --- a/contrib/05.r7rs/CMakeLists.txt +++ /dev/null @@ -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 - ) diff --git a/contrib/05.r7rs/nitro.mk b/contrib/05.r7rs/nitro.mk new file mode 100644 index 00000000..56bf8f2f --- /dev/null +++ b/contrib/05.r7rs/nitro.mk @@ -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 diff --git a/contrib/03.file/src/file.c b/contrib/05.r7rs/src/file.c similarity index 93% rename from contrib/03.file/src/file.c rename to contrib/05.r7rs/src/file.c index e3aa1739..ce9cb1b2 100644 --- a/contrib/03.file/src/file.c +++ b/contrib/05.r7rs/src/file.c @@ -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 diff --git a/contrib/03.load/src/load.c b/contrib/05.r7rs/src/load.c similarity index 88% rename from contrib/03.load/src/load.c rename to contrib/05.r7rs/src/load.c index 93f832c6..c887a1b2 100644 --- a/contrib/03.load/src/load.c +++ b/contrib/05.r7rs/src/load.c @@ -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 diff --git a/contrib/03.mutable-string/mutable-string.c b/contrib/05.r7rs/src/mutable-string.c similarity index 75% rename from contrib/03.mutable-string/mutable-string.c rename to contrib/05.r7rs/src/mutable-string.c index de3ab2bc..85db9be0 100644 --- a/contrib/03.mutable-string/mutable-string.c +++ b/contrib/05.r7rs/src/mutable-string.c @@ -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 diff --git a/contrib/05.r7rs/src/r7rs.c b/contrib/05.r7rs/src/r7rs.c new file mode 100644 index 00000000..ad3090aa --- /dev/null +++ b/contrib/05.r7rs/src/r7rs.c @@ -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); +} diff --git a/contrib/03.system/src/system.c b/contrib/05.r7rs/src/system.c similarity index 94% rename from contrib/03.system/src/system.c rename to contrib/05.r7rs/src/system.c index c46173b6..3265d876 100644 --- a/contrib/03.system/src/system.c +++ b/contrib/05.r7rs/src/system.c @@ -5,9 +5,6 @@ #include #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); diff --git a/contrib/03.time/src/time.c b/contrib/05.r7rs/src/time.c similarity index 100% rename from contrib/03.time/src/time.c rename to contrib/05.r7rs/src/time.c diff --git a/contrib/10.optional/CMakeLists.txt b/contrib/10.optional/CMakeLists.txt deleted file mode 100644 index c6a60a8a..00000000 --- a/contrib/10.optional/CMakeLists.txt +++ /dev/null @@ -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) diff --git a/contrib/10.optional/nitro.mk b/contrib/10.optional/nitro.mk new file mode 100644 index 00000000..9048a19f --- /dev/null +++ b/contrib/10.optional/nitro.mk @@ -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 diff --git a/contrib/10.partcont/CMakeLists.txt b/contrib/10.partcont/CMakeLists.txt deleted file mode 100644 index 65f16fb2..00000000 --- a/contrib/10.partcont/CMakeLists.txt +++ /dev/null @@ -1,2 +0,0 @@ -file(GLOB PARTCONT_FILES ${PROJECT_SOURCE_DIR}/contrib/10.partcont/piclib/*.scm) -list(APPEND PICLIB_CONTRIB_LIBS ${PARTCONT_FILES}) diff --git a/contrib/10.partcont/docs/doc.rst b/contrib/10.partcont/docs/doc.rst index 08355948..d1b1decc 100644 --- a/contrib/10.partcont/docs/doc.rst +++ b/contrib/10.partcont/docs/doc.rst @@ -6,3 +6,7 @@ Delimited control operators. - **(reset h)** - **(shift k)** +Escape Continuation + +- **(escape f)** + diff --git a/contrib/10.partcont/nitro.mk b/contrib/10.partcont/nitro.mk new file mode 100644 index 00000000..454bd39d --- /dev/null +++ b/contrib/10.partcont/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += $(wildcard contrib/10.partcont/piclib/*.scm) diff --git a/contrib/10.pretty-print/CMakeLists.txt b/contrib/10.pretty-print/CMakeLists.txt deleted file mode 100644 index cf0327da..00000000 --- a/contrib/10.pretty-print/CMakeLists.txt +++ /dev/null @@ -1 +0,0 @@ -list(APPEND PICLIB_CONTRIB_LIBS ${PROJECT_SOURCE_DIR}/contrib/10.pretty-print/pretty-print.scm) diff --git a/contrib/10.pretty-print/nitro.mk b/contrib/10.pretty-print/nitro.mk new file mode 100644 index 00000000..28070d61 --- /dev/null +++ b/contrib/10.pretty-print/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += contrib/10.pretty-print/pretty-print.scm diff --git a/contrib/10.random/CMakeLists.txt b/contrib/10.random/CMakeLists.txt deleted file mode 100644 index 224686b9..00000000 --- a/contrib/10.random/CMakeLists.txt +++ /dev/null @@ -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) diff --git a/contrib/10.random/nitro.mk b/contrib/10.random/nitro.mk new file mode 100644 index 00000000..e7ba691d --- /dev/null +++ b/contrib/10.random/nitro.mk @@ -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 diff --git a/contrib/10.readline/CMakeLists.txt b/contrib/10.readline/CMakeLists.txt deleted file mode 100644 index 413e8c19..00000000 --- a/contrib/10.readline/CMakeLists.txt +++ /dev/null @@ -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) diff --git a/contrib/10.readline/cmake/FindLibedit.cmake b/contrib/10.readline/cmake/FindLibedit.cmake deleted file mode 100644 index 9a771988..00000000 --- a/contrib/10.readline/cmake/FindLibedit.cmake +++ /dev/null @@ -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 -# Copyright (c) 2008 Andreas Schneider -# Modified for other libraries by Lasse Kärkkäinen -# -# 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) diff --git a/contrib/10.readline/nitro.mk b/contrib/10.readline/nitro.mk new file mode 100644 index 00000000..51d296ea --- /dev/null +++ b/contrib/10.readline/nitro.mk @@ -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 diff --git a/contrib/10.readline/src/readline.c b/contrib/10.readline/src/readline.c index b516cb6c..84d3f37f 100644 --- a/contrib/10.readline/src/readline.c +++ b/contrib/10.readline/src/readline.c @@ -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 -#include -#else #include -#include -#endif static pic_value pic_rl_readline(pic_state *pic) diff --git a/contrib/10.regexp/CMakeLists.txt b/contrib/10.regexp/CMakeLists.txt deleted file mode 100644 index c13c76d3..00000000 --- a/contrib/10.regexp/CMakeLists.txt +++ /dev/null @@ -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() diff --git a/contrib/10.regexp/cmake/FindREGEX.cmake b/contrib/10.regexp/cmake/FindREGEX.cmake deleted file mode 100644 index f7b88113..00000000 --- a/contrib/10.regexp/cmake/FindREGEX.cmake +++ /dev/null @@ -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 . -# -# @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) diff --git a/contrib/10.regexp/nitro.mk b/contrib/10.regexp/nitro.mk new file mode 100644 index 00000000..9fe45e2f --- /dev/null +++ b/contrib/10.regexp/nitro.mk @@ -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 diff --git a/contrib/10.regexp/src/regexp.c b/contrib/10.regexp/src/regexp.c index 8c98bb2b..ce54d65e 100644 --- a/contrib/10.regexp/src/regexp.c +++ b/contrib/10.regexp/src/regexp.c @@ -1,8 +1,4 @@ #include "picrin.h" -#include "picrin/data.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/cont.h" #include @@ -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, ptrn, cflags)) != 0) { - char errbuf[regerror(err, ®->reg, NULL, 0)]; + char errbuf[256]; regerror(err, ®->reg, errbuf, sizeof errbuf); regexp_dtor(pic, ®->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); } diff --git a/contrib/10.regexp/t/test.scm b/contrib/10.regexp/t/test.scm index 3c90493f..45da3bcf 100644 --- a/contrib/10.regexp/t/test.scm +++ b/contrib/10.regexp/t/test.scm @@ -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 " " ")) diff --git a/contrib/10.srfi/CMakeLists.txt b/contrib/10.srfi/CMakeLists.txt deleted file mode 100644 index 1cabb620..00000000 --- a/contrib/10.srfi/CMakeLists.txt +++ /dev/null @@ -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 - ) diff --git a/contrib/10.srfi/nitro.mk b/contrib/10.srfi/nitro.mk new file mode 100644 index 00000000..d8ac54ab --- /dev/null +++ b/contrib/10.srfi/nitro.mk @@ -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 diff --git a/contrib/10.srfi/srfi/17.scm b/contrib/10.srfi/srfi/17.scm index c1bed0d0..0a7bdbad 100644 --- a/contrib/10.srfi/srfi/17.scm +++ b/contrib/10.srfi/srfi/17.scm @@ -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)))) diff --git a/contrib/10.srfi/srfi/43.scm b/contrib/10.srfi/srfi/43.scm index 88ebc083..13e5341c 100644 --- a/contrib/10.srfi/srfi/43.scm +++ b/contrib/10.srfi/srfi/43.scm @@ -1,5 +1,5 @@ (define-library (srfi 43) - (import (scheme base) + (import (except (scheme base) vector-map) (srfi 8)) ;; # Constructors @@ -92,16 +92,28 @@ (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)) - vects))) + (apply f count (map (lambda (v) (vector-ref v count)) + vects))) (rec (+ 1 count))))))) (define (vector-count pred? vec . vects) diff --git a/contrib/20.for/CMakeLists.txt b/contrib/20.for/CMakeLists.txt deleted file mode 100644 index 5e109d90..00000000 --- a/contrib/20.for/CMakeLists.txt +++ /dev/null @@ -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) diff --git a/contrib/20.for/nitro.mk b/contrib/20.for/nitro.mk new file mode 100644 index 00000000..b2c2cbad --- /dev/null +++ b/contrib/20.for/nitro.mk @@ -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 diff --git a/contrib/20.repl/CMakeLists.txt b/contrib/20.repl/CMakeLists.txt deleted file mode 100644 index 7fc3bf06..00000000 --- a/contrib/20.repl/CMakeLists.txt +++ /dev/null @@ -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) diff --git a/contrib/20.repl/nitro.mk b/contrib/20.repl/nitro.mk new file mode 100644 index 00000000..f03e4ad7 --- /dev/null +++ b/contrib/20.repl/nitro.mk @@ -0,0 +1,3 @@ +CONTRIB_LIBS += contrib/20.repl/repl.scm +CONTRIB_SRCS += contrib/20.repl/repl.c +CONTRIB_INITS += repl diff --git a/contrib/20.repl/repl.scm b/contrib/20.repl/repl.scm index f745ce4e..3afd70c8 100644 --- a/contrib/20.repl/repl.scm +++ b/contrib/20.repl/repl.scm @@ -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)) diff --git a/contrib/30.main/CMakeLists.txt b/contrib/30.main/CMakeLists.txt deleted file mode 100644 index ceef792f..00000000 --- a/contrib/30.main/CMakeLists.txt +++ /dev/null @@ -1 +0,0 @@ -list(APPEND PICLIB_CONTRIB_LIBS ${PROJECT_SOURCE_DIR}/contrib/30.main/main.scm) diff --git a/contrib/30.main/nitro.mk b/contrib/30.main/nitro.mk new file mode 100644 index 00000000..a425fdc0 --- /dev/null +++ b/contrib/30.main/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += contrib/30.main/main.scm diff --git a/contrib/40.class/CMakeLists.txt b/contrib/40.class/CMakeLists.txt deleted file mode 100644 index 5281edcd..00000000 --- a/contrib/40.class/CMakeLists.txt +++ /dev/null @@ -1,2 +0,0 @@ -file(GLOB CLASS_FILES ${PROJECT_SOURCE_DIR}/contrib/40.class/piclib/picrin/*.scm) -list(APPEND PICLIB_CONTRIB_LIBS ${CLASS_FILES}) diff --git a/contrib/40.class/nitro.mk b/contrib/40.class/nitro.mk new file mode 100644 index 00000000..cec300c1 --- /dev/null +++ b/contrib/40.class/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += $(wildcard contrib/40.class/piclib/picrin/*.scm) diff --git a/contrib/50.protocol/CMakeLists.txt b/contrib/50.protocol/CMakeLists.txt deleted file mode 100644 index 41b4df2f..00000000 --- a/contrib/50.protocol/CMakeLists.txt +++ /dev/null @@ -1,2 +0,0 @@ -file(GLOB PROTOCOL_FILES ${PROJECT_SOURCE_DIR}/contrib/50.protocol/piclib/picrin/*.scm) -list(APPEND PICLIB_CONTRIB_LIBS ${PROTOCOL_FILES}) diff --git a/contrib/50.protocol/nitro.mk b/contrib/50.protocol/nitro.mk new file mode 100644 index 00000000..2db1bf31 --- /dev/null +++ b/contrib/50.protocol/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += $(wildcard contrib/50.protocol/piclib/picrin/*.scm) diff --git a/contrib/CMakeLists.txt b/contrib/CMakeLists.txt deleted file mode 100644 index 11050d90..00000000 --- a/contrib/CMakeLists.txt +++ /dev/null @@ -1,5 +0,0 @@ -file(GLOB CONTRIBS ${PROJECT_SOURCE_DIR}/contrib/*/CMakeLists.txt) -list(SORT CONTRIBS) -foreach(contrib ${CONTRIBS}) - include(${contrib}) -endforeach() diff --git a/docs/CMakeLists.txt b/docs/CMakeLists.txt deleted file mode 100644 index a468e943..00000000 --- a/docs/CMakeLists.txt +++ /dev/null @@ -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}/ - ) \ No newline at end of file diff --git a/docs/capi.rst b/docs/capi.rst index c4464114..a2c31320 100644 --- a/docs/capi.rst +++ b/docs/capi.rst @@ -51,7 +51,6 @@ When you use dynamic memory allocation inside C APIs, you must be caseful about /** foo.c **/ #include #include "picrin.h" - #include "picrin/data.h" /* * C-side API diff --git a/docs/contrib.rst b/docs/contrib.rst deleted file mode 100644 index be9e7ef4..00000000 --- a/docs/contrib.rst +++ /dev/null @@ -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) - `_ - - List library. - -- `(srfi 8) - `_ - - ``receive`` macro. - -- `(srfi 17) - `_ - - Generalized set! - -- `(srfi 26) - `_ - - Cut/cute macros. - -- `(srfi 43) - `_ - - Vector library. - -- `(srfi 60) - `_ - - Bitwise operations. - -- `(srfi 95) - `_ - - Sorting and Marging. - -- `(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. - - diff --git a/docs/deploy.rst b/docs/deploy.rst index 7a4a9330..7bb36135 100644 --- a/docs/deploy.rst +++ b/docs/deploy.rst @@ -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 + $ 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 + $ 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. diff --git a/docs/intro.rst b/docs/intro.rst index 429bc045..fa72e69c 100644 --- a/docs/intro.rst +++ b/docs/intro.rst @@ -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 -------- diff --git a/docs/libs.rst b/docs/libs.rst index b67ea145..232dcdaa 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -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)** diff --git a/etc/mkloader.pl b/etc/mkloader.pl index afbd88f2..3f5bcb41 100755 --- a/etc/mkloader.pl +++ b/etc/mkloader.pl @@ -12,24 +12,27 @@ print <) { - chomp; + local $/ = undef; + my $src = ; + 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 <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 diff --git a/extlib/benz/blob.c b/extlib/benz/blob.c index cd5be767..c2775ea3 100644 --- a/extlib/benz/blob.c +++ b/extlib/benz/blob.c @@ -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) diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index b102f9de..33b6d0bf 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -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); } diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 6fb9bff3..59eb736b 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -14,31 +14,31 @@ 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 - value - (begin - (define val (f sym)) - (dictionary-set! cache sym val) - val)))))) + (define value (dictionary-ref cache sym)) + (if (not (undefined? value)) + value + (begin + (define val (f sym)) + (dictionary-set! cache sym val) + val)))) (define (er-macro-transformer f) - (lambda (expr use-env mac-env) + (lambda (mac-env) + (lambda (expr use-env) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? use-env x use-env y)))) + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #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 <)\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: diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 39b4bfc4..79d4126c 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -3,17 +3,10 @@ */ #include "picrin.h" -#include "picrin/pair.h" -#include "picrin/irep.h" -#include "picrin/proc.h" -#include "picrin/lib.h" -#include "picrin/macro.h" -#if PIC_NONE_IS_FALSE -# define OP_PUSHNONE OP_PUSHFALSE -#else -# error enable PIC_NONE_IS_FALSE -#endif +typedef xvect_t(pic_sym *) xvect; + +#define xv_push_sym(v, x) xv_push(pic_sym *, (v), (x)) /** * scope object @@ -34,76 +27,27 @@ typedef struct analyze_scope { typedef struct analyze_state { pic_state *pic; analyze_scope *scope; - pic_sym rCONS, rCAR, rCDR, rNILP; - pic_sym rSYMBOL_P, rPAIR_P; - pic_sym rADD, rSUB, rMUL, rDIV; - pic_sym rEQ, rLT, rLE, rGT, rGE, rNOT; - pic_sym rVALUES, rCALL_WITH_VALUES; - pic_sym sCALL, sTAILCALL, sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES; - pic_sym sGREF, sLREF, sCREF, sRETURN; } analyze_state; static bool push_scope(analyze_state *, pic_value); static void pop_scope(analyze_state *); -#define register_symbol(pic, state, slot, name) do { \ - state->slot = pic_intern_cstr(pic, name); \ - } while (0) - -#define register_renamed_symbol(pic, state, slot, lib, id) do { \ - pic_sym sym, gsym; \ - sym = pic_intern_cstr(pic, id); \ - if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \ - pic_errorf(pic, "internal error! native VM procedure not found: %s", id); \ - } \ - state->slot = gsym; \ - } while (0) - static analyze_state * new_analyze_state(pic_state *pic) { analyze_state *state; + pic_sym *sym; xh_entry *it; - state = pic_alloc(pic, sizeof(analyze_state)); + state = pic_malloc(pic, sizeof(analyze_state)); state->pic = pic; state->scope = NULL; - /* native VM procedures */ - register_renamed_symbol(pic, state, rCONS, pic->PICRIN_BASE, "cons"); - register_renamed_symbol(pic, state, rCAR, pic->PICRIN_BASE, "car"); - register_renamed_symbol(pic, state, rCDR, pic->PICRIN_BASE, "cdr"); - register_renamed_symbol(pic, state, rNILP, pic->PICRIN_BASE, "null?"); - register_renamed_symbol(pic, state, rSYMBOL_P, pic->PICRIN_BASE, "symbol?"); - register_renamed_symbol(pic, state, rPAIR_P, pic->PICRIN_BASE, "pair?"); - register_renamed_symbol(pic, state, rADD, pic->PICRIN_BASE, "+"); - register_renamed_symbol(pic, state, rSUB, pic->PICRIN_BASE, "-"); - register_renamed_symbol(pic, state, rMUL, pic->PICRIN_BASE, "*"); - register_renamed_symbol(pic, state, rDIV, pic->PICRIN_BASE, "/"); - register_renamed_symbol(pic, state, rEQ, pic->PICRIN_BASE, "="); - register_renamed_symbol(pic, state, rLT, pic->PICRIN_BASE, "<"); - register_renamed_symbol(pic, state, rLE, pic->PICRIN_BASE, "<="); - register_renamed_symbol(pic, state, rGT, pic->PICRIN_BASE, ">"); - register_renamed_symbol(pic, state, rGE, pic->PICRIN_BASE, ">="); - register_renamed_symbol(pic, state, rNOT, pic->PICRIN_BASE, "not"); - register_renamed_symbol(pic, state, rVALUES, pic->PICRIN_BASE, "values"); - register_renamed_symbol(pic, state, rCALL_WITH_VALUES, pic->PICRIN_BASE, "call-with-values"); - - register_symbol(pic, state, sCALL, "call"); - register_symbol(pic, state, sTAILCALL, "tail-call"); - register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values"); - register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values"); - register_symbol(pic, state, sGREF, "gref"); - register_symbol(pic, state, sLREF, "lref"); - register_symbol(pic, state, sCREF, "cref"); - register_symbol(pic, state, sRETURN, "return"); - /* push initial scope */ push_scope(state, pic_nil_value()); - for (it = xh_begin(&pic->globals); it != NULL; it = xh_next(it)) { - pic_sym sym = xh_key(it, pic_sym); - xv_push(&state->scope->locals, &sym); + pic_dict_for_each (sym, pic->globals, it) { + xv_push_sym(state->scope->locals, sym); } return state; @@ -120,23 +64,23 @@ static bool analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) { pic_value v, t; - pic_sym sym; + pic_sym *sym; for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { t = pic_car(pic, v); if (! pic_sym_p(t)) { return false; } - sym = pic_sym(t); - xv_push(args, &sym); + sym = pic_sym_ptr(t); + xv_push_sym(*args, sym); } if (pic_nil_p(v)) { *varg = false; } else if (pic_sym_p(v)) { *varg = true; - sym = pic_sym(v); - xv_push(locals, &sym); + sym = pic_sym_ptr(v); + xv_push_sym(*locals, sym); } else { return false; @@ -149,22 +93,17 @@ static bool push_scope(analyze_state *state, pic_value formals) { pic_state *pic = state->pic; - analyze_scope *scope; + analyze_scope *scope = pic_malloc(pic, sizeof(analyze_scope)); bool varg; - xvect args, locals, captures; - xv_init(&args, sizeof(pic_sym)); - xv_init(&locals, sizeof(pic_sym)); - xv_init(&captures, sizeof(pic_sym)); + xv_init(scope->args); + xv_init(scope->locals); + xv_init(scope->captures); - if (analyze_args(pic, formals, &varg, &args, &locals)) { - scope = pic_alloc(pic, sizeof(analyze_scope)); + if (analyze_args(pic, formals, &varg, &scope->args, &scope->locals)) { scope->up = state->scope; scope->depth = scope->up ? scope->up->depth + 1 : 0; scope->varg = varg; - scope->args = args; - scope->locals = locals; - scope->captures = captures; scope->defer = pic_nil_value(); state->scope = scope; @@ -172,8 +111,10 @@ push_scope(analyze_state *state, pic_value formals) return true; } else { - xv_destroy(&args); - xv_destroy(&locals); + xv_destroy(scope->args); + xv_destroy(scope->locals); + xv_destroy(scope->captures); + pic_free(pic, scope); return false; } } @@ -181,12 +122,13 @@ push_scope(analyze_state *state, pic_value formals) static void pop_scope(analyze_state *state) { + pic_state *pic = state->pic; analyze_scope *scope; scope = state->scope; - xv_destroy(&scope->args); - xv_destroy(&scope->locals); - xv_destroy(&scope->captures); + xv_destroy(scope->args); + xv_destroy(scope->locals); + xv_destroy(scope->captures); scope = scope->up; pic_free(state->pic, state->scope); @@ -194,45 +136,40 @@ pop_scope(analyze_state *state) } static bool -lookup_scope(analyze_scope *scope, pic_sym sym) +lookup_scope(analyze_scope *scope, pic_sym *sym) { - pic_sym *arg, *local; size_t i; /* args */ - for (i = 0; i < xv_size(&scope->args); ++i) { - arg = xv_get(&scope->args, i); - if (*arg == sym) + for (i = 0; i < xv_size(scope->args); ++i) { + if (xv_A(scope->args, i) == sym) return true; } /* locals */ - for (i = 0; i < xv_size(&scope->locals); ++i) { - local = xv_get(&scope->locals, i); - if (*local == sym) + for (i = 0; i < xv_size(scope->locals); ++i) { + if (xv_A(scope->locals, i) == sym) return true; } return false; } static void -capture_var(analyze_scope *scope, pic_sym sym) +capture_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { - pic_sym *var; size_t i; - for (i = 0; i < xv_size(&scope->captures); ++i) { - var = xv_get(&scope->captures, i); - if (*var == sym) { + for (i = 0; i < xv_size(scope->captures); ++i) { + if (xv_A(scope->captures, i) == sym) { break; } } - if (i == xv_size(&scope->captures)) { - xv_push(&scope->captures, &sym); + if (i == xv_size(scope->captures)) { + xv_push_sym(scope->captures, sym); } } static int -find_var(analyze_state *state, pic_sym sym) +find_var(analyze_state *state, pic_sym *sym) { analyze_scope *scope = state->scope; int depth = 0; @@ -240,7 +177,7 @@ find_var(analyze_state *state, pic_sym sym) while (scope) { if (lookup_scope(scope, sym)) { if (depth > 0) { - capture_var(scope, sym); + capture_var(state->pic, scope, sym); } return depth; } @@ -251,17 +188,17 @@ find_var(analyze_state *state, pic_sym sym) } static void -define_var(analyze_state *state, pic_sym sym) +define_var(analyze_state *state, pic_sym *sym) { pic_state *pic = state->pic; analyze_scope *scope = state->scope; if (lookup_scope(scope, sym)) { - pic_warnf(pic, "redefining variable: ~s", pic_sym_value(sym)); + pic_warnf(pic, "redefining variable: ~s", pic_obj_value(sym)); return; } - xv_push(&scope->locals, &sym); + xv_push_sym(scope->locals, sym); } static pic_value analyze_node(analyze_state *, pic_value, bool); @@ -273,17 +210,17 @@ analyze(analyze_state *state, pic_value obj, bool tailpos) pic_state *pic = state->pic; size_t ai = pic_gc_arena_preserve(pic); pic_value res; - pic_sym tag; + pic_sym *tag; res = analyze_node(state, obj, tailpos); - tag = pic_sym(pic_car(pic, res)); + tag = pic_sym_ptr(pic_car(pic, res)); if (tailpos) { - if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sTAILCALL_WITH_VALUES || tag == state->sRETURN) { + if (tag == pic->sIF || tag == pic->sBEGIN || tag == pic->sTAILCALL || tag == pic->sTAILCALL_WITH_VALUES || tag == pic->sRETURN) { /* pass through */ } else { - res = pic_list2(pic, pic_symbol_value(state->sRETURN), res); + res = pic_list2(pic, pic_obj_value(pic->sRETURN), res); } } @@ -294,31 +231,31 @@ analyze(analyze_state *state, pic_value obj, bool tailpos) } static pic_value -analyze_global_var(analyze_state *state, pic_sym sym) +analyze_global_var(analyze_state *state, pic_sym *sym) { pic_state *pic = state->pic; - return pic_list2(pic, pic_symbol_value(state->sGREF), pic_sym_value(sym)); + return pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sym)); } static pic_value -analyze_local_var(analyze_state *state, pic_sym sym) +analyze_local_var(analyze_state *state, pic_sym *sym) { pic_state *pic = state->pic; - return pic_list2(pic, pic_symbol_value(state->sLREF), pic_sym_value(sym)); + return pic_list2(pic, pic_obj_value(pic->sLREF), pic_obj_value(sym)); } static pic_value -analyze_free_var(analyze_state *state, pic_sym sym, int depth) +analyze_free_var(analyze_state *state, pic_sym *sym, int depth) { pic_state *pic = state->pic; - return pic_list3(pic, pic_symbol_value(state->sCREF), pic_int_value(depth), pic_sym_value(sym)); + return pic_list3(pic, pic_obj_value(pic->sCREF), pic_int_value(depth), pic_obj_value(sym)); } static pic_value -analyze_var(analyze_state *state, pic_sym sym) +analyze_var(analyze_state *state, pic_sym *sym) { pic_state *pic = state->pic; int depth; @@ -340,10 +277,10 @@ static pic_value analyze_defer(analyze_state *state, pic_value name, pic_value formal, pic_value body) { pic_state *pic = state->pic; - const pic_sym sNOWHERE = pic_intern_cstr(pic, " nowhere "); + pic_sym *sNOWHERE = pic_intern_cstr(pic, "<>"); pic_value skel; - skel = pic_list2(pic, pic_sym_value(state->sGREF), pic_sym_value(sNOWHERE)); + skel = pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sNOWHERE)); pic_push(pic, pic_list4(pic, name, formal, body, skel), state->scope->defer); @@ -354,9 +291,9 @@ static void analyze_deferred(analyze_state *state) { pic_state *pic = state->pic; - pic_value defer, val, name, formal, body, dst; + pic_value defer, val, name, formal, body, dst, it; - pic_for_each (defer, pic_reverse(pic, state->scope->defer)) { + pic_for_each (defer, pic_reverse(pic, state->scope->defer), it) { name = pic_list_ref(pic, defer, 0); formal = pic_list_ref(pic, defer, 1); body = pic_list_ref(pic, defer, 2); @@ -382,13 +319,11 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v if (push_scope(state, formals)) { analyze_scope *scope = state->scope; - pic_sym *var; size_t i; args = pic_nil_value(); - for (i = xv_size(&scope->args); i > 0; --i) { - var = xv_get(&scope->args, i - 1); - pic_push(pic, pic_sym_value(*var), args); + for (i = xv_size(scope->args); i > 0; --i) { + pic_push(pic, pic_obj_value(xv_A(scope->args, i - 1)), args); } varg = scope->varg @@ -396,29 +331,27 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v : pic_false_value(); /* To know what kind of local variables are defined, analyze body at first. */ - body = analyze(state, pic_cons(pic, pic_sym_value(pic->rBEGIN), body_exprs), true); + body = analyze(state, pic_cons(pic, pic_obj_value(pic->rBEGIN), body_exprs), true); analyze_deferred(state); locals = pic_nil_value(); - for (i = xv_size(&scope->locals); i > 0; --i) { - var = xv_get(&scope->locals, i - 1); - pic_push(pic, pic_sym_value(*var), locals); + for (i = xv_size(scope->locals); i > 0; --i) { + pic_push(pic, pic_obj_value(xv_A(scope->locals, i - 1)), locals); } captures = pic_nil_value(); - for (i = xv_size(&scope->captures); i > 0; --i) { - var = xv_get(&scope->captures, i - 1); - pic_push(pic, pic_sym_value(*var), captures); + for (i = xv_size(scope->captures); i > 0; --i) { + pic_push(pic, pic_obj_value(xv_A(scope->captures, i - 1)), captures); } pop_scope(state); } else { - pic_errorf(pic, "invalid formal syntax: ~s", args); + pic_errorf(pic, "invalid formal syntax: ~s", formals); } - return pic_list7(pic, pic_sym_value(pic->sLAMBDA), name, args, locals, varg, captures, body); + return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, args, locals, varg, captures, body); } static pic_value @@ -438,7 +371,7 @@ analyze_lambda(analyze_state *state, pic_value obj) } static pic_value -analyze_declare(analyze_state *state, pic_sym var) +analyze_declare(analyze_state *state, pic_sym *var) { define_var(state, var); @@ -450,7 +383,7 @@ analyze_define(analyze_state *state, pic_value obj) { pic_state *pic = state->pic; pic_value var, val; - pic_sym sym; + pic_sym *sym; if (pic_length(pic, obj) != 3) { pic_errorf(pic, "syntax error"); @@ -460,19 +393,19 @@ analyze_define(analyze_state *state, pic_value obj) if (! pic_sym_p(var)) { pic_errorf(pic, "syntax error"); } else { - sym = pic_sym(var); + sym = pic_sym_ptr(var); } var = analyze_declare(state, sym); if (pic_pair_p(pic_list_ref(pic, obj, 2)) && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) - && pic_sym(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { + && pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { pic_value formals, body_exprs; formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2); - val = analyze_defer(state, pic_sym_value(sym), formals, body_exprs); + val = analyze_defer(state, pic_obj_value(sym), formals, body_exprs); } else { if (pic_length(pic, obj) != 3) { pic_errorf(pic, "syntax error"); @@ -480,7 +413,7 @@ analyze_define(analyze_state *state, pic_value obj) val = analyze(state, pic_list_ref(pic, obj, 2), false); } - return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); + return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val); } static pic_value @@ -489,7 +422,7 @@ analyze_if(analyze_state *state, pic_value obj, bool tailpos) pic_state *pic = state->pic; pic_value cond, if_true, if_false; - if_false = pic_none_value(); + if_false = pic_undef_value(); switch (pic_length(pic, obj)) { default: pic_errorf(pic, "syntax error"); @@ -505,7 +438,7 @@ analyze_if(analyze_state *state, pic_value obj, bool tailpos) if_true = analyze(state, if_true, tailpos); if_false = analyze(state, if_false, tailpos); - return pic_list4(pic, pic_symbol_value(pic->sIF), cond, if_true, if_false); + return pic_list4(pic, pic_obj_value(pic->sIF), cond, if_true, if_false); } static pic_value @@ -517,11 +450,11 @@ analyze_begin(analyze_state *state, pic_value obj, bool tailpos) switch (pic_length(pic, obj)) { case 1: - return analyze(state, pic_none_value(), tailpos); + return analyze(state, pic_undef_value(), tailpos); case 2: return analyze(state, pic_list_ref(pic, obj, 1), tailpos); default: - seq = pic_list1(pic, pic_symbol_value(pic->sBEGIN)); + seq = pic_list1(pic, pic_obj_value(pic->sBEGIN)); for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) { if (pic_nil_p(pic_cdr(pic, obj))) { tail = tailpos; @@ -554,7 +487,7 @@ analyze_set(analyze_state *state, pic_value obj) var = analyze(state, var, false); val = analyze(state, val, false); - return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); + return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val); } static pic_value @@ -565,33 +498,36 @@ analyze_quote(analyze_state *state, pic_value obj) if (pic_length(pic, obj) != 2) { pic_errorf(pic, "syntax error"); } - return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); + return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); } -#define ARGC_ASSERT_GE(n) do { \ - if (pic_length(pic, obj) < (n) + 1) { \ - pic_errorf(pic, "wrong number of arguments"); \ - } \ - } while (0) +#define ARGC_ASSERT_GE(n, name) do { \ + if (pic_length(pic, obj) < (n) + 1) { \ + pic_errorf(pic, \ + #name ": wrong number of arguments (%d for at least %d)", \ + pic_length(pic, obj) - 1, \ + n); \ + } \ + } while (0) -#define FOLD_ARGS(sym) do { \ - obj = analyze(state, pic_car(pic, args), false); \ - pic_for_each (arg, pic_cdr(pic, args)) { \ - obj = pic_list3(pic, pic_symbol_value(sym), obj, \ - analyze(state, arg, false)); \ - } \ - } while (0) +#define FOLD_ARGS(sym) do { \ + obj = analyze(state, pic_car(pic, args), false); \ + pic_for_each (arg, pic_cdr(pic, args), it) { \ + obj = pic_list3(pic, pic_obj_value(sym), obj, \ + analyze(state, arg, false)); \ + } \ + } while (0) static pic_value analyze_add(analyze_state *state, pic_value obj, bool tailpos) { pic_state *pic = state->pic; - pic_value args, arg; + pic_value args, arg, it; - ARGC_ASSERT_GE(0); + ARGC_ASSERT_GE(0, "+"); switch (pic_length(pic, obj)) { case 1: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(0)); + return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_int_value(0)); case 2: return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); default: @@ -605,12 +541,12 @@ static pic_value analyze_sub(analyze_state *state, pic_value obj) { pic_state *pic = state->pic; - pic_value args, arg; + pic_value args, arg, it; - ARGC_ASSERT_GE(1); + ARGC_ASSERT_GE(1, "-"); switch (pic_length(pic, obj)) { case 2: - return pic_list2(pic, pic_symbol_value(pic->sMINUS), + return pic_list2(pic, pic_obj_value(pic->sMINUS), analyze(state, pic_car(pic, pic_cdr(pic, obj)), false)); default: args = pic_cdr(pic, obj); @@ -623,12 +559,12 @@ static pic_value analyze_mul(analyze_state *state, pic_value obj, bool tailpos) { pic_state *pic = state->pic; - pic_value args, arg; + pic_value args, arg, it; - ARGC_ASSERT_GE(0); + ARGC_ASSERT_GE(0, "*"); switch (pic_length(pic, obj)) { case 1: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(1)); + return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_int_value(1)); case 2: return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); default: @@ -642,13 +578,17 @@ static pic_value analyze_div(analyze_state *state, pic_value obj) { pic_state *pic = state->pic; - pic_value args, arg; + pic_value args, arg, it; - ARGC_ASSERT_GE(1); + ARGC_ASSERT_GE(1, "/"); switch (pic_length(pic, obj)) { case 2: args = pic_cdr(pic, obj); +#if PIC_ENABLE_FLOAT obj = pic_list3(pic, pic_car(pic, obj), pic_float_value(1), pic_car(pic, args)); +#else + obj = pic_list3(pic, pic_car(pic, obj), pic_int_value(1), pic_car(pic, args)); +#endif return analyze(state, obj, false); default: args = pic_cdr(pic, obj); @@ -661,16 +601,16 @@ static pic_value analyze_call(analyze_state *state, pic_value obj, bool tailpos) { pic_state *pic = state->pic; - pic_value seq, elt; - pic_sym call; + pic_value seq, elt, it; + pic_sym *call; if (! tailpos) { - call = state->sCALL; + call = pic->sCALL; } else { - call = state->sTAILCALL; + call = pic->sTAILCALL; } - seq = pic_list1(pic, pic_symbol_value(call)); - pic_for_each (elt, obj) { + seq = pic_list1(pic, pic_obj_value(call)); + pic_for_each (elt, obj, it) { seq = pic_cons(pic, analyze(state, elt, false), seq); } return pic_reverse(pic, seq); @@ -680,14 +620,14 @@ static pic_value analyze_values(analyze_state *state, pic_value obj, bool tailpos) { pic_state *pic = state->pic; - pic_value v, seq; + pic_value v, seq, it; if (! tailpos) { return analyze_call(state, obj, false); } - seq = pic_list1(pic, pic_symbol_value(state->sRETURN)); - pic_for_each (v, pic_cdr(pic, obj)) { + seq = pic_list1(pic, pic_obj_value(pic->sRETURN)); + pic_for_each (v, pic_cdr(pic, obj), it) { seq = pic_cons(pic, analyze(state, v, false), seq); } return pic_reverse(pic, seq); @@ -698,44 +638,45 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) { pic_state *pic = state->pic; pic_value prod, cnsm; - pic_sym call; + pic_sym *call; if (pic_length(pic, obj) != 3) { - pic_errorf(pic, "wrong number of arguments"); + pic_errorf(pic, "call-with-values: wrong number of arguments (%d for 2)", pic_length(pic, obj) - 1); } if (! tailpos) { - call = state->sCALL_WITH_VALUES; + call = pic->sCALL_WITH_VALUES; } else { - call = state->sTAILCALL_WITH_VALUES; + call = pic->sTAILCALL_WITH_VALUES; } prod = analyze(state, pic_list_ref(pic, obj, 1), false); cnsm = analyze(state, pic_list_ref(pic, obj, 2), false); - return pic_list3(pic, pic_symbol_value(call), prod, cnsm); + return pic_list3(pic, pic_obj_value(call), prod, cnsm); } -#define ARGC_ASSERT(n) do { \ - if (pic_length(pic, obj) != (n) + 1) { \ - pic_errorf(pic, "wrong number of arguments"); \ - } \ - } while (0) +#define ARGC_ASSERT(n, name) do { \ + if (pic_length(pic, obj) != (n) + 1) { \ + pic_errorf(pic, #name ": wrong number of arguments (%d for %d)", \ + pic_length(pic, obj) - 1, n); \ + } \ + } while (0) -#define ARGC_ASSERT_WITH_FALLBACK(n) do { \ - if (pic_length(pic, obj) != (n) + 1) { \ - goto fallback; \ - } \ - } while (0) +#define ARGC_ASSERT_WITH_FALLBACK(n) do { \ + if (pic_length(pic, obj) != (n) + 1) { \ + goto fallback; \ + } \ + } while (0) -#define CONSTRUCT_OP1(op) \ - pic_list2(pic, \ - pic_symbol_value(op), \ - analyze(state, pic_list_ref(pic, obj, 1), false)) +#define CONSTRUCT_OP1(op) \ + pic_list2(pic, \ + pic_obj_value(op), \ + analyze(state, pic_list_ref(pic, obj, 1), false)) -#define CONSTRUCT_OP2(op) \ - pic_list3(pic, \ - pic_symbol_value(op), \ - analyze(state, pic_list_ref(pic, obj, 1), false), \ - analyze(state, pic_list_ref(pic, obj, 2), false)) +#define CONSTRUCT_OP2(op) \ + pic_list3(pic, \ + pic_obj_value(op), \ + analyze(state, pic_list_ref(pic, obj, 1), false), \ + analyze(state, pic_list_ref(pic, obj, 2), false)) static pic_value analyze_node(analyze_state *state, pic_value obj, bool tailpos) @@ -744,7 +685,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) switch (pic_type(obj)) { case PIC_TT_SYMBOL: { - return analyze_var(state, pic_sym(obj)); + return analyze_var(state, pic_sym_ptr(obj)); } case PIC_TT_PAIR: { pic_value proc; @@ -755,7 +696,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) proc = pic_list_ref(pic, obj, 0); if (pic_sym_p(proc)) { - pic_sym sym = pic_sym(proc); + pic_sym *sym = pic_sym_ptr(proc); if (sym == pic->rDEFINE) { return analyze_define(state, obj); @@ -775,79 +716,79 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) else if (sym == pic->rQUOTE) { return analyze_quote(state, obj); } - else if (sym == state->rCONS) { - ARGC_ASSERT(2); + else if (sym == pic->rCONS) { + ARGC_ASSERT(2, "cons"); return CONSTRUCT_OP2(pic->sCONS); } - else if (sym == state->rCAR) { - ARGC_ASSERT(1); + else if (sym == pic->rCAR) { + ARGC_ASSERT(1, "car"); return CONSTRUCT_OP1(pic->sCAR); } - else if (sym == state->rCDR) { - ARGC_ASSERT(1); + else if (sym == pic->rCDR) { + ARGC_ASSERT(1, "cdr"); return CONSTRUCT_OP1(pic->sCDR); } - else if (sym == state->rNILP) { - ARGC_ASSERT(1); + else if (sym == pic->rNILP) { + ARGC_ASSERT(1, "nil?"); return CONSTRUCT_OP1(pic->sNILP); } - else if (sym == state->rSYMBOL_P) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sSYMBOL_P); + else if (sym == pic->rSYMBOLP) { + ARGC_ASSERT(1, "symbol?"); + return CONSTRUCT_OP1(pic->sSYMBOLP); } - else if (sym == state->rPAIR_P) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sPAIR_P); + else if (sym == pic->rPAIRP) { + ARGC_ASSERT(1, "pair?"); + return CONSTRUCT_OP1(pic->sPAIRP); } - else if (sym == state->rADD) { + else if (sym == pic->rADD) { return analyze_add(state, obj, tailpos); } - else if (sym == state->rSUB) { + else if (sym == pic->rSUB) { return analyze_sub(state, obj); } - else if (sym == state->rMUL) { + else if (sym == pic->rMUL) { return analyze_mul(state, obj, tailpos); } - else if (sym == state->rDIV) { + else if (sym == pic->rDIV) { return analyze_div(state, obj); } - else if (sym == state->rEQ) { + else if (sym == pic->rEQ) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sEQ); } - else if (sym == state->rLT) { + else if (sym == pic->rLT) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLT); } - else if (sym == state->rLE) { + else if (sym == pic->rLE) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLE); } - else if (sym == state->rGT) { + else if (sym == pic->rGT) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGT); } - else if (sym == state->rGE) { + else if (sym == pic->rGE) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGE); } - else if (sym == state->rNOT) { - ARGC_ASSERT(1); + else if (sym == pic->rNOT) { + ARGC_ASSERT(1, "not"); return CONSTRUCT_OP1(pic->sNOT); } - else if (sym == state->rVALUES) { + else if (sym == pic->rVALUES) { return analyze_values(state, obj, tailpos); } - else if (sym == state->rCALL_WITH_VALUES) { + else if (sym == pic->rCALL_WITH_VALUES) { return analyze_call_with_values(state, obj, tailpos); } } - fallback: + fallback: return analyze_call(state, obj, tailpos); } default: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), obj); + return pic_list2(pic, pic_obj_value(pic->sQUOTE), obj); } } @@ -871,7 +812,7 @@ pic_analyze(pic_state *pic, pic_value obj) */ typedef struct codegen_context { - pic_sym name; + pic_sym *name; /* rest args variable is counted as a local */ bool varg; xvect args, locals, captures; @@ -884,6 +825,9 @@ typedef struct codegen_context { /* constant object pool */ pic_value *pool; size_t plen, pcapa; + /* symbol pool */ + pic_sym **syms; + size_t slen, scapa; struct codegen_context *up; } codegen_context; @@ -895,9 +839,6 @@ typedef struct codegen_context { typedef struct codegen_state { pic_state *pic; codegen_context *cxt; - pic_sym sGREF, sCREF, sLREF; - pic_sym sCALL, sTAILCALL, sRETURN; - pic_sym sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES; } codegen_state; static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value); @@ -908,19 +849,10 @@ new_codegen_state(pic_state *pic) { codegen_state *state; - state = pic_alloc(pic, sizeof(codegen_state)); + state = pic_malloc(pic, sizeof(codegen_state)); state->pic = pic; state->cxt = NULL; - register_symbol(pic, state, sCALL, "call"); - register_symbol(pic, state, sTAILCALL, "tail-call"); - register_symbol(pic, state, sGREF, "gref"); - register_symbol(pic, state, sLREF, "lref"); - register_symbol(pic, state, sCREF, "cref"); - register_symbol(pic, state, sRETURN, "return"); - register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values"); - register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values"); - push_codegen_context(state, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value()); return state; @@ -939,39 +871,95 @@ destroy_codegen_state(codegen_state *state) } static void -create_activation(codegen_context *cxt) +emit_n(codegen_state *state, enum pic_opcode insn) { + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + + if (cxt->clen >= cxt->ccapa) { + cxt->ccapa *= 2; + cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); + } + cxt->code[cxt->clen].insn = insn; + cxt->clen++; +} + +static void +emit_i(codegen_state *state, enum pic_opcode insn, int i) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + + if (cxt->clen >= cxt->ccapa) { + cxt->ccapa *= 2; + cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); + } + cxt->code[cxt->clen].insn = insn; + cxt->code[cxt->clen].u.i = i; + cxt->clen++; +} + +static void +emit_c(codegen_state *state, enum pic_opcode insn, char c) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + + if (cxt->clen >= cxt->ccapa) { + cxt->ccapa *= 2; + cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); + } + cxt->code[cxt->clen].insn = insn; + cxt->code[cxt->clen].u.c = c; + cxt->clen++; +} + +static void +emit_r(codegen_state *state, enum pic_opcode insn, int d, int i) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + + if (cxt->clen >= cxt->ccapa) { + cxt->ccapa *= 2; + cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); + } + cxt->code[cxt->clen].insn = insn; + cxt->code[cxt->clen].u.r.depth = d; + cxt->code[cxt->clen].u.r.idx = i; + cxt->clen++; +} + +static void +create_activation(codegen_state *state) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; size_t i, n; xhash regs; - pic_sym *var; size_t offset; - xh_init_int(®s, sizeof(size_t)); + xh_init_ptr(®s, sizeof(size_t)); offset = 1; - for (i = 0; i < xv_size(&cxt->args); ++i) { - var = xv_get(&cxt->args, i); + for (i = 0; i < xv_size(cxt->args); ++i) { n = i + offset; - xh_put_int(®s, *var, &n); + xh_put_ptr(®s, xv_A(cxt->args, i), &n); } offset += i; - for (i = 0; i < xv_size(&cxt->locals); ++i) { - var = xv_get(&cxt->locals, i); + for (i = 0; i < xv_size(cxt->locals); ++i) { n = i + offset; - xh_put_int(®s, *var, &n); + xh_put_ptr(®s, xv_A(cxt->locals, i), &n); } - for (i = 0; i < xv_size(&cxt->captures); ++i) { - var = xv_get(&cxt->captures, i); - if ((n = xh_val(xh_get_int(®s, *var), size_t)) <= xv_size(&cxt->args) || (cxt->varg && n == xv_size(&cxt->args) + 1)) { + for (i = 0; i < xv_size(cxt->captures); ++i) { + n = xh_val(xh_get_ptr(®s, xv_A(cxt->captures, i)), size_t); + if (n <= xv_size(cxt->args) || (cxt->varg && n == xv_size(cxt->args) + 1)) { /* copy arguments to capture variable area */ - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = (int)n; - cxt->clen++; + emit_i(state, OP_LREF, (int)n); } else { /* otherwise, just extend the stack */ - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; + emit_n(state, OP_PUSHUNDEF); } } @@ -983,33 +971,29 @@ push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_v { pic_state *pic = state->pic; codegen_context *cxt; - pic_value var; - pic_sym sym; + pic_value var, it; assert(pic_sym_p(name) || pic_false_p(name)); - cxt = pic_alloc(pic, sizeof(codegen_context)); + cxt = pic_malloc(pic, sizeof(codegen_context)); cxt->up = state->cxt; cxt->name = pic_false_p(name) ? pic_intern_cstr(pic, "(anonymous lambda)") - : pic_sym(name); + : pic_sym_ptr(name); cxt->varg = varg; - xv_init(&cxt->args, sizeof(pic_sym)); - xv_init(&cxt->locals, sizeof(pic_sym)); - xv_init(&cxt->captures, sizeof(pic_sym)); + xv_init(cxt->args); + xv_init(cxt->locals); + xv_init(cxt->captures); - pic_for_each (var, args) { - sym = pic_sym(var); - xv_push(&cxt->args, &sym); + pic_for_each (var, args, it) { + xv_push_sym(cxt->args, pic_sym_ptr(var)); } - pic_for_each (var, locals) { - sym = pic_sym(var); - xv_push(&cxt->locals, &sym); + pic_for_each (var, locals, it) { + xv_push_sym(cxt->locals, pic_sym_ptr(var)); } - pic_for_each (var, captures) { - sym = pic_sym(var); - xv_push(&cxt->captures, &sym); + pic_for_each (var, captures, it) { + xv_push_sym(cxt->captures, pic_sym_ptr(var)); } cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); @@ -1024,9 +1008,13 @@ push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_v cxt->plen = 0; cxt->pcapa = PIC_POOL_SIZE; + cxt->syms = pic_calloc(pic, PIC_SYMS_SIZE, sizeof(pic_sym *)); + cxt->slen = 0; + cxt->scapa = PIC_SYMS_SIZE; + state->cxt = cxt; - create_activation(cxt); + create_activation(state); } static struct pic_irep * @@ -1040,20 +1028,22 @@ pop_codegen_context(codegen_state *state) irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_IREP); irep->name = state->cxt->name; irep->varg = state->cxt->varg; - irep->argc = (int)xv_size(&state->cxt->args) + 1; - irep->localc = (int)xv_size(&state->cxt->locals); - irep->capturec = (int)xv_size(&state->cxt->captures); + irep->argc = (int)xv_size(state->cxt->args) + 1; + irep->localc = (int)xv_size(state->cxt->locals); + irep->capturec = (int)xv_size(state->cxt->captures); irep->code = pic_realloc(pic, state->cxt->code, sizeof(pic_code) * state->cxt->clen); irep->clen = state->cxt->clen; irep->irep = pic_realloc(pic, state->cxt->irep, sizeof(struct pic_irep *) * state->cxt->ilen); irep->ilen = state->cxt->ilen; irep->pool = pic_realloc(pic, state->cxt->pool, sizeof(pic_value) * state->cxt->plen); irep->plen = state->cxt->plen; + irep->syms = pic_realloc(pic, state->cxt->syms, sizeof(pic_sym *) * state->cxt->slen); + irep->slen = state->cxt->slen; /* finalize */ - xv_destroy(&cxt->args); - xv_destroy(&cxt->locals); - xv_destroy(&cxt->captures); + xv_destroy(cxt->args); + xv_destroy(cxt->locals); + xv_destroy(cxt->captures); /* destroy context */ cxt = cxt->up; @@ -1064,46 +1054,61 @@ pop_codegen_context(codegen_state *state) } static int -index_capture(codegen_state *state, pic_sym sym, int depth) +index_capture(codegen_state *state, pic_sym *sym, int depth) { codegen_context *cxt = state->cxt; size_t i; - pic_sym *var; while (depth-- > 0) { cxt = cxt->up; } - for (i = 0; i < xv_size(&cxt->captures); ++i) { - var = xv_get(&cxt->captures, i); - if (*var == sym) + for (i = 0; i < xv_size(cxt->captures); ++i) { + if (xv_A(cxt->captures, i) == sym) return (int)i; } return -1; } static int -index_local(codegen_state *state, pic_sym sym) +index_local(codegen_state *state, pic_sym *sym) { codegen_context *cxt = state->cxt; size_t i, offset; - pic_sym *var; offset = 1; - for (i = 0; i < xv_size(&cxt->args); ++i) { - var = xv_get(&cxt->args, i); - if (*var == sym) + for (i = 0; i < xv_size(cxt->args); ++i) { + if (xv_A(cxt->args, i) == sym) return (int)(i + offset); } offset += i; - for (i = 0; i < xv_size(&cxt->locals); ++i) { - var = xv_get(&cxt->locals, i); - if (*var == sym) + for (i = 0; i < xv_size(cxt->locals); ++i) { + if (xv_A(cxt->locals, i) == sym) return (int)(i + offset); } return -1; } +static int +index_symbol(codegen_state *state, pic_sym *sym) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + size_t i; + + for (i = 0; i < cxt->slen; ++i) { + if (cxt->syms[i] == sym) { + return i; + } + } + if (cxt->slen >= cxt->scapa) { + cxt->scapa *= 2; + cxt->syms = pic_realloc(pic, cxt->syms, sizeof(pic_sym *) * cxt->scapa); + } + cxt->syms[cxt->slen++] = sym; + return i; +} + static struct pic_irep *codegen_lambda(codegen_state *, pic_value); static void @@ -1111,89 +1116,67 @@ codegen(codegen_state *state, pic_value obj) { pic_state *pic = state->pic; codegen_context *cxt = state->cxt; - pic_sym sym; + pic_sym *sym; - sym = pic_sym(pic_car(pic, obj)); - if (sym == state->sGREF) { - cxt->code[cxt->clen].insn = OP_GREF; - cxt->code[cxt->clen].u.i = pic_sym(pic_list_ref(pic, obj, 1)); - cxt->clen++; + sym = pic_sym_ptr(pic_car(pic, obj)); + if (sym == pic->sGREF) { + emit_i(state, OP_GREF, index_symbol(state, pic_sym_ptr(pic_list_ref(pic, obj, 1)))); return; - } else if (sym == state->sCREF) { - pic_sym name; + } else if (sym == pic->sCREF) { + pic_sym *name; int depth; depth = pic_int(pic_list_ref(pic, obj, 1)); - name = pic_sym(pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_CREF; - cxt->code[cxt->clen].u.r.depth = depth; - cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); - cxt->clen++; + name = pic_sym_ptr(pic_list_ref(pic, obj, 2)); + emit_r(state, OP_CREF, depth, index_capture(state, name, depth)); return; - } else if (sym == state->sLREF) { - pic_sym name; + } else if (sym == pic->sLREF) { + pic_sym *name; int i; - name = pic_sym(pic_list_ref(pic, obj, 1)); + name = pic_sym_ptr(pic_list_ref(pic, obj, 1)); if ((i = index_capture(state, name, 0)) != -1) { - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1; - cxt->clen++; + emit_i(state, OP_LREF, i + (int)xv_size(cxt->args) + (int)xv_size(cxt->locals) + 1); return; } - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = index_local(state, name); - cxt->clen++; + emit_i(state, OP_LREF, index_local(state, name)); return; } else if (sym == pic->sSETBANG) { pic_value var, val; - pic_sym type; + pic_sym *type; val = pic_list_ref(pic, obj, 2); codegen(state, val); var = pic_list_ref(pic, obj, 1); - type = pic_sym(pic_list_ref(pic, var, 0)); - if (type == state->sGREF) { - cxt->code[cxt->clen].insn = OP_GSET; - cxt->code[cxt->clen].u.i = pic_int(pic_list_ref(pic, var, 1)); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; + type = pic_sym_ptr(pic_list_ref(pic, var, 0)); + if (type == pic->sGREF) { + emit_i(state, OP_GSET, index_symbol(state, pic_sym_ptr(pic_list_ref(pic, var, 1)))); + emit_n(state, OP_PUSHUNDEF); return; } - else if (type == state->sCREF) { - pic_sym name; + else if (type == pic->sCREF) { + pic_sym *name; int depth; depth = pic_int(pic_list_ref(pic, var, 1)); - name = pic_sym(pic_list_ref(pic, var, 2)); - cxt->code[cxt->clen].insn = OP_CSET; - cxt->code[cxt->clen].u.r.depth = depth; - cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; + name = pic_sym_ptr(pic_list_ref(pic, var, 2)); + emit_r(state, OP_CSET, depth, index_capture(state, name, depth)); + emit_n(state, OP_PUSHUNDEF); return; } - else if (type == state->sLREF) { - pic_sym name; + else if (type == pic->sLREF) { + pic_sym *name; int i; - name = pic_sym(pic_list_ref(pic, var, 1)); + name = pic_sym_ptr(pic_list_ref(pic, var, 1)); if ((i = index_capture(state, name, 0)) != -1) { - cxt->code[cxt->clen].insn = OP_LSET; - cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1; - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; + emit_i(state, OP_LSET, i + (int)xv_size(cxt->args) + (int)xv_size(cxt->locals) + 1); + emit_n(state, OP_PUSHUNDEF); return; } - cxt->code[cxt->clen].insn = OP_LSET; - cxt->code[cxt->clen].u.i = index_local(state, name); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; + emit_i(state, OP_LSET, index_local(state, name)); + emit_n(state, OP_PUSHUNDEF); return; } } @@ -1205,9 +1188,7 @@ codegen(codegen_state *state, pic_value obj) cxt->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->icapa); } k = (int)cxt->ilen++; - cxt->code[cxt->clen].insn = OP_LAMBDA; - cxt->code[cxt->clen].u.i = k; - cxt->clen++; + emit_i(state, OP_LAMBDA, k); cxt->irep[k] = codegen_lambda(state, obj); return; @@ -1217,13 +1198,16 @@ codegen(codegen_state *state, pic_value obj) codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_JMPIF; - s = (int)cxt->clen++; + s = (int)cxt->clen; + + emit_n(state, OP_JMPIF); /* if false branch */ codegen(state, pic_list_ref(pic, obj, 3)); - cxt->code[cxt->clen].insn = OP_JMP; - t = (int)cxt->clen++; + + t = (int)cxt->clen; + + emit_n(state, OP_JMP); cxt->code[s].u.i = (int)cxt->clen - s; @@ -1233,13 +1217,12 @@ codegen(codegen_state *state, pic_value obj) return; } else if (sym == pic->sBEGIN) { - pic_value elt; + pic_value elt, it; int i = 0; - pic_for_each (elt, pic_cdr(pic, obj)) { + pic_for_each (elt, pic_cdr(pic, obj), it) { if (i++ != 0) { - cxt->code[cxt->clen].insn = OP_POP; - cxt->clen++; + emit_n(state, OP_POP); } codegen(state, elt); } @@ -1251,26 +1234,16 @@ codegen(codegen_state *state, pic_value obj) obj = pic_list_ref(pic, obj, 1); switch (pic_type(obj)) { case PIC_TT_BOOL: - if (pic_true_p(obj)) { - cxt->code[cxt->clen].insn = OP_PUSHTRUE; - } else { - cxt->code[cxt->clen].insn = OP_PUSHFALSE; - } - cxt->clen++; + emit_n(state, (pic_true_p(obj) ? OP_PUSHTRUE : OP_PUSHFALSE)); return; case PIC_TT_INT: - cxt->code[cxt->clen].insn = OP_PUSHINT; - cxt->code[cxt->clen].u.i = pic_int(obj); - cxt->clen++; + emit_i(state, OP_PUSHINT, pic_int(obj)); return; case PIC_TT_NIL: - cxt->code[cxt->clen].insn = OP_PUSHNIL; - cxt->clen++; + emit_n(state, OP_PUSHNIL); return; case PIC_TT_CHAR: - cxt->code[cxt->clen].insn = OP_PUSHCHAR; - cxt->code[cxt->clen].u.c = pic_char(obj); - cxt->clen++; + emit_c(state, OP_PUSHCHAR, pic_char(obj)); return; default: if (cxt->plen >= cxt->pcapa) { @@ -1279,163 +1252,136 @@ codegen(codegen_state *state, pic_value obj) } pidx = (int)cxt->plen++; cxt->pool[pidx] = obj; - cxt->code[cxt->clen].insn = OP_PUSHCONST; - cxt->code[cxt->clen].u.i = pidx; - cxt->clen++; + emit_i(state, OP_PUSHCONST, pidx); return; } } else if (sym == pic->sCONS) { codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_CONS; - cxt->clen++; + emit_n(state, OP_CONS); return; } else if (sym == pic->sCAR) { codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_CAR; - cxt->clen++; + emit_n(state, OP_CAR); return; } else if (sym == pic->sCDR) { codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_CDR; - cxt->clen++; + emit_n(state, OP_CDR); return; } else if (sym == pic->sNILP) { codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_NILP; - cxt->clen++; + emit_n(state, OP_NILP); return; } - else if (sym == pic->sSYMBOL_P) { + else if (sym == pic->sSYMBOLP) { codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_SYMBOL_P; - cxt->clen++; + emit_n(state, OP_SYMBOLP); return; } - else if (sym == pic->sPAIR_P) { + else if (sym == pic->sPAIRP) { codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_PAIR_P; - cxt->clen++; + emit_n(state, OP_PAIRP); return; } else if (sym == pic->sADD) { codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_ADD; - cxt->clen++; + emit_n(state, OP_ADD); return; } else if (sym == pic->sSUB) { codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_SUB; - cxt->clen++; + emit_n(state, OP_SUB); return; } else if (sym == pic->sMUL) { codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_MUL; - cxt->clen++; + emit_n(state, OP_MUL); return; } else if (sym == pic->sDIV) { codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_DIV; - cxt->clen++; + emit_n(state, OP_DIV); return; } else if (sym == pic->sMINUS) { codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_MINUS; - cxt->clen++; + emit_n(state, OP_MINUS); return; } else if (sym == pic->sEQ) { codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_EQ; - cxt->clen++; + emit_n(state, OP_EQ); return; } else if (sym == pic->sLT) { codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_LT; - cxt->clen++; + emit_n(state, OP_LT); return; } else if (sym == pic->sLE) { codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_LE; - cxt->clen++; + emit_n(state, OP_LE); return; } else if (sym == pic->sGT) { codegen(state, pic_list_ref(pic, obj, 2)); codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_LT; - cxt->clen++; + emit_n(state, OP_LT); return; } else if (sym == pic->sGE) { codegen(state, pic_list_ref(pic, obj, 2)); codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_LE; - cxt->clen++; + emit_n(state, OP_LE); return; } else if (sym == pic->sNOT) { codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_NOT; - cxt->clen++; + emit_n(state, OP_NOT); return; } - else if (sym == state->sCALL || sym == state->sTAILCALL) { + else if (sym == pic->sCALL || sym == pic->sTAILCALL) { int len = (int)pic_length(pic, obj); - pic_value elt; + pic_value elt, it; - pic_for_each (elt, pic_cdr(pic, obj)) { + pic_for_each (elt, pic_cdr(pic, obj), it) { codegen(state, elt); } - cxt->code[cxt->clen].insn = (sym == state->sCALL) ? OP_CALL : OP_TAILCALL; - cxt->code[cxt->clen].u.i = len - 1; - cxt->clen++; + emit_i(state, (sym == pic->sCALL ? OP_CALL : OP_TAILCALL), len - 1); return; } - else if (sym == state->sCALL_WITH_VALUES || sym == state->sTAILCALL_WITH_VALUES) { + else if (sym == pic->sCALL_WITH_VALUES || sym == pic->sTAILCALL_WITH_VALUES) { /* stack consumer at first */ codegen(state, pic_list_ref(pic, obj, 2)); codegen(state, pic_list_ref(pic, obj, 1)); /* call producer */ - cxt->code[cxt->clen].insn = OP_CALL; - cxt->code[cxt->clen].u.i = 1; - cxt->clen++; + emit_i(state, OP_CALL, 1); /* call consumer */ - cxt->code[cxt->clen].insn = (sym == state->sCALL_WITH_VALUES) ? OP_CALL : OP_TAILCALL; - cxt->code[cxt->clen].u.i = -1; - cxt->clen++; + emit_i(state, (sym == pic->sCALL_WITH_VALUES ? OP_CALL : OP_TAILCALL), -1); return; } - else if (sym == state->sRETURN) { + else if (sym == pic->sRETURN) { int len = (int)pic_length(pic, obj); - pic_value elt; + pic_value elt, it; - pic_for_each (elt, pic_cdr(pic, obj)) { + pic_for_each (elt, pic_cdr(pic, obj), it) { codegen(state, elt); } - cxt->code[cxt->clen].insn = OP_RET; - cxt->code[cxt->clen].u.i = len - 1; - cxt->clen++; + emit_i(state, OP_RET, len - 1); return; } - pic_errorf(pic, "codegen: unknown AST type"); + pic_errorf(pic, "codegen: unknown AST type ~s", obj); } static struct pic_irep * diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 2678fb0b..4b213f52 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -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, ""); + c = pic_make_proc(pic, cont_call, ""); - 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); } diff --git a/extlib/benz/data.c b/extlib/benz/data.c index 5d586c56..00042286 100644 --- a/extlib/benz/data.c +++ b/extlib/benz/data.c @@ -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) diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c index bb9f711d..d61e9380 100644 --- a/extlib/benz/debug.c +++ b/extlib/benz/debug.c @@ -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); } diff --git a/extlib/benz/dict.c b/extlib/benz/dict.c index 19e80176..ca5d042d 100644 --- a/extlib/benz/dict.c +++ b/extlib/benz/dict.c @@ -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); - - pic_dict_del(pic, dict, key); - - return pic_none_value(); + if (pic_undef_p(val)) { + if (pic_dict_has(pic, dict, key)) { + pic_dict_del(pic, dict, key); + } + } + 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); diff --git a/extlib/benz/error.c b/extlib/benz/error.c index 1d950359..6fa5309d 100644 --- a/extlib/benz/error.c +++ b/extlib/benz/error.c @@ -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 diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c index d8712760..1006df50 100644 --- a/extlib/benz/eval.c +++ b/extlib/benz/eval.c @@ -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) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index c09765fd..93650e52 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -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(®->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(®->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 diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 418cff2c..5b1bd3f3 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -29,52 +29,57 @@ extern "C" { #endif #include -#include -#include #include #include -#include -#include -#include -#include -#include -#include -#include +#include "picrin/config.h" +#include "picrin/util.h" +#include "picrin/compat.h" + +#if PIC_ENABLE_FLOAT +# include +#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) } diff --git a/extlib/benz/include/picrin/compat.h b/extlib/benz/include/picrin/compat.h new file mode 100644 index 00000000..cca83d95 --- /dev/null +++ b/extlib/benz/include/picrin/compat.h @@ -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 +#include +#include +#include + +#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 diff --git a/extlib/benz/include/picrin/config.h b/extlib/benz/include/picrin/config.h index 889e268b..b30bc398 100644 --- a/extlib/benz/include/picrin/config.h +++ b/extlib/benz/include/picrin/config.h @@ -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 -# define PIC_NAN_BOXING 1 +#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 +# define PIC_JMPBUF jmp_buf +#endif + +#ifndef PIC_SETJMP +# include +# define PIC_SETJMP(pic, buf) setjmp(buf) +#endif + +#ifndef PIC_LONGJMP +# include +# 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 # define GC_STRESS 0 # define VM_DEBUG 1 # define GC_DEBUG 0 diff --git a/extlib/benz/include/picrin/cont.h b/extlib/benz/include/picrin/cont.h index 645e6d9c..303ea0f9 100644 --- a/extlib/benz/include/picrin/cont.h +++ b/extlib/benz/include/picrin/cont.h @@ -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) } diff --git a/extlib/benz/include/picrin/data.h b/extlib/benz/include/picrin/data.h index fec4cd7d..38a20c3d 100644 --- a/extlib/benz/include/picrin/data.h +++ b/extlib/benz/include/picrin/data.h @@ -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; } diff --git a/extlib/benz/include/picrin/dict.h b/extlib/benz/include/picrin/dict.h index 8d6077af..4a3bd7ce 100644 --- a/extlib/benz/include/picrin/dict.h +++ b/extlib/benz/include/picrin/dict.h @@ -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) } diff --git a/extlib/benz/include/picrin/error.h b/extlib/benz/include/picrin/error.h index e4cc630a..1435faa3 100644 --- a/extlib/benz/include/picrin/error.h +++ b/extlib/benz/include/picrin/error.h @@ -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 -#define pic_catch \ - while (0); \ - pic_pop_try(pic); \ - } else + pic_try_(PIC_GENSYM(cont), PIC_GENSYM(handler)) +#define pic_catch \ + 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) } diff --git a/extlib/benz/include/picrin/gc.h b/extlib/benz/include/picrin/gc.h index 9f165d80..c7ed0426 100644 --- a/extlib/benz/include/picrin/gc.h +++ b/extlib/benz/include/picrin/gc.h @@ -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) } diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h index 5b10628a..319d1b31 100644 --- a/extlib/benz/include/picrin/irep.h +++ b/extlib/benz/include/picrin/irep.h @@ -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 diff --git a/extlib/benz/include/picrin/lib.h b/extlib/benz/include/picrin/lib.h index 98ab3ae8..c2d0b420 100644 --- a/extlib/benz/include/picrin/lib.h +++ b/extlib/benz/include/picrin/lib.h @@ -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)) diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index 79148e51..7d150777 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -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) } diff --git a/extlib/benz/include/picrin/pair.h b/extlib/benz/include/picrin/pair.h index 11859482..a05b23b6 100644 --- a/extlib/benz/include/picrin/pair.h +++ b/extlib/benz/include/picrin/pair.h @@ -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)) diff --git a/extlib/benz/include/picrin/port.h b/extlib/benz/include/picrin/port.h index 4f763902..98dcff83 100644 --- a/extlib/benz/include/picrin/port.h +++ b/extlib/benz/include/picrin/port.h @@ -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 { diff --git a/extlib/benz/include/picrin/proc.h b/extlib/benz/include/picrin/proc.h index e64cd6fc..bf1a0a4e 100644 --- a/extlib/benz/include/picrin/proc.h +++ b/extlib/benz/include/picrin/proc.h @@ -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_irep *irep; + 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) } diff --git a/extlib/benz/include/picrin/read.h b/extlib/benz/include/picrin/read.h index 18d46ff7..a3f01100 100644 --- a/extlib/benz/include/picrin/read.h +++ b/extlib/benz/include/picrin/read.h @@ -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) } diff --git a/extlib/benz/include/picrin/record.h b/extlib/benz/include/picrin/record.h index d2944c06..e3edcd01 100644 --- a/extlib/benz/include/picrin/record.h +++ b/extlib/benz/include/picrin/record.h @@ -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) } diff --git a/extlib/benz/include/picrin/reg.h b/extlib/benz/include/picrin/reg.h new file mode 100644 index 00000000..d9622c06 --- /dev/null +++ b/extlib/benz/include/picrin/reg.h @@ -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 diff --git a/extlib/benz/include/picrin/string.h b/extlib/benz/include/picrin/string.h index 2701e162..2728e97b 100644 --- a/extlib/benz/include/picrin/string.h +++ b/extlib/benz/include/picrin/string.h @@ -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); diff --git a/extlib/benz/include/picrin/symbol.h b/extlib/benz/include/picrin/symbol.h new file mode 100644 index 00000000..bb588d0d --- /dev/null +++ b/extlib/benz/include/picrin/symbol.h @@ -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 diff --git a/extlib/benz/include/picrin/util.h b/extlib/benz/include/picrin/util.h index 6f39b759..5c831bad 100644 --- a/extlib/benz/include/picrin/util.h +++ b/extlib/benz/include/picrin/util.h @@ -9,17 +9,44 @@ extern "C" { #endif +#if __STDC_VERSION__ >= 199901L +# include +#else +# define bool char +# define true 1 +# define false 0 +#endif + +#if __STDC_VERSION__ >= 199901L +# include +#elif ! defined(offsetof) +# define offsetof(s,m) ((size_t)&(((s *)NULL)->m)) +#endif + #if __STDC_VERSION__ >= 201112L # include -# 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) diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h index d21a8418..d69eaf59 100644 --- a/extlib/benz/include/picrin/value.h +++ b/extlib/benz/include/picrin/value.h @@ -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 + /** * 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: diff --git a/extlib/benz/include/picrin/xfile.h b/extlib/benz/include/picrin/xfile.h index 4c96a9f8..eff7d269 100644 --- a/extlib/benz/include/picrin/xfile.h +++ b/extlib/benz/include/picrin/xfile.h @@ -5,571 +5,104 @@ extern "C" { #endif +#include + +#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) } diff --git a/extlib/benz/include/picrin/xhash.h b/extlib/benz/include/picrin/xhash.h index 1dadc7ff..253c25f2 100644 --- a/extlib/benz/include/picrin/xhash.h +++ b/extlib/benz/include/picrin/xhash.h @@ -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; diff --git a/extlib/benz/include/picrin/xrope.h b/extlib/benz/include/picrin/xrope.h deleted file mode 100644 index 20199b85..00000000 --- a/extlib/benz/include/picrin/xrope.h +++ /dev/null @@ -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 diff --git a/extlib/benz/include/picrin/xvect.h b/extlib/benz/include/picrin/xvect.h index a04d227a..44db4d8e 100644 --- a/extlib/benz/include/picrin/xvect.h +++ b/extlib/benz/include/picrin/xvect.h @@ -1,202 +1,76 @@ #ifndef XVECT_H__ #define XVECT_H__ -/* - * Copyright (c) 2014 by Yuichi Nishiwaki - */ +/* The MIT License -#if defined(__cplusplus) -extern "C" { -#endif + Copyright (c) 2008, by Attractive Chaos + Copyright (c) 2014, by Yuichi Nishiwaki -typedef struct xvect { - char *data; - size_t size, mask, head, tail, width; -} xvect; + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: -static inline void xv_init(xvect *, size_t); -static inline void xv_destroy(xvect *); + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. -static inline size_t xv_size(xvect *); + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. +*/ -static inline void xv_reserve(xvect *, size_t); -static inline void xv_shrink(xvect *, size_t); +#define xv_realloc(P,Z) pic_realloc(pic,P,Z) +#define xv_free(P) pic_free(pic,P) -static inline void *xv_get(xvect *, size_t); -static inline void xv_set(xvect *, size_t, void *); +#define xv_roundup32(x) \ + (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x)) -static inline void xv_push(xvect *, void *); -static inline void *xv_pop(xvect *); +#define xvect_t(type) struct { size_t n, m; type *a; } +#define xv_init(v) ((v).n = (v).m = 0, (v).a = 0) +#define xv_destroy(v) xv_free((v).a) +#define xv_A(v, i) ((v).a[(i)]) +#define xv_pop(v) ((v).a[--(v).n]) +#define xv_size(v) ((v).n) +#define xv_max(v) ((v).m) -static inline void *xv_shift(xvect *); -static inline void xv_unshift(xvect *, void *); +#define xv_resize(type, v, s) \ + ((v).m = (s), (v).a = (type*)xv_realloc((v).a, sizeof(type) * (v).m)) -static inline void xv_splice(xvect *, size_t, size_t); -static inline void xv_insert(xvect *, size_t, void *); +#define xv_copy(type, v1, v0) \ + do { \ + if ((v1).m < (v0).n) xv_resize(type, v1, (v0).n); \ + (v1).n = (v0).n; \ + memcpy((v1).a, (v0).a, sizeof(type) * (v0).n); \ + } while (0) \ -static inline void -xv_init(xvect *x, size_t width) -{ - x->data = NULL; - x->width = width; - x->size = 0; - x->mask = (size_t)-1; - x->head = 0; - x->tail = 0; -} +#define xv_push(type, v, x) \ + do { \ + if ((v).n == (v).m) { \ + (v).m = (v).m? (v).m<<1 : (size_t)2; \ + (v).a = (type*)xv_realloc((v).a, sizeof(type) * (v).m); \ + } \ + (v).a[(v).n++] = (x); \ + } while (0) -static inline void -xv_destroy(xvect *x) -{ - free(x->data); -} +#define xv_pushp(type, v) \ + (((v).n == (v).m)? \ + ((v).m = ((v).m? (v).m<<1 : (size_t)2), \ + (v).a = (type*)xv_realloc((v).a, sizeof(type) * (v).m), 0) \ + : 0), ((v).a + ((v).n++)) -static inline size_t -xv_size(xvect *x) -{ - return x->tail < x->head - ? x->tail + x->size - x->head - : x->tail - x->head; -} - -static inline size_t -xv_round2(size_t x) -{ - x -= 1; - x |= (x >> 1); - x |= (x >> 2); - x |= (x >> 4); - x |= (x >> 8); - x |= (x >> 16); - x |= (x >> 32); - x++; - return x; -} - -static inline void -xv_rotate(xvect *x) -{ - if (x->tail < x->head) { - char buf[x->size * x->width]; - - /* perform rotation */ - memcpy(buf, x->data, sizeof buf); - memcpy(x->data, buf + x->head * x->width, (x->size - x->head) * x->width); - memcpy(x->data + (x->size - x->head) * x->width, buf, x->tail * x->width); - x->tail = x->size - x->head + x->tail; - x->head = 0; - } -} - -static inline void -xv_adjust(xvect *x, size_t size) -{ - size = xv_round2(size); - if (size != x->size) { - xv_rotate(x); - x->data = realloc(x->data, size * x->width); - x->size = size; - x->mask = size - 1; - } -} - -static inline void -xv_reserve(xvect *x, size_t mincapa) -{ - if (x->size < mincapa + 1) { - xv_adjust(x, mincapa + 1); /* capa == size - 1 */ - } -} - -static inline void -xv_shrink(xvect *x, size_t maxcapa) -{ - if (x->size > maxcapa + 1) { - xv_adjust(x, maxcapa + 1); /* capa == size - 1 */ - } -} - -static inline void * -xv_get(xvect *x, size_t i) -{ - assert(i < xv_size(x)); - - return x->data + ((x->head + i) & x->mask) * x->width; -} - -static inline void -xv_set(xvect *x, size_t i, void *src) -{ - memcpy(xv_get(x, i), src, x->width); -} - -static inline void -xv_push(xvect *x, void *src) -{ - xv_reserve(x, xv_size(x) + 1); - x->tail = (x->tail + 1) & x->mask; - xv_set(x, xv_size(x) - 1, src); -} - -static inline void * -xv_pop(xvect *x) -{ - void *dat; - - assert(xv_size(x) >= 1); - - dat = xv_get(x, xv_size(x) - 1); - x->tail = (x->tail - 1) & x->mask; - return dat; -} - -static inline void * -xv_shift(xvect *x) -{ - void *dat; - - assert(xv_size(x) >= 1); - - dat = xv_get(x, 0); - x->head = (x->head + 1) & x->mask; - return dat; -} - -static inline void -xv_unshift(xvect *x, void *src) -{ - xv_reserve(x, xv_size(x) + 1); - x->head = (x->head - 1) & x->mask; - xv_set(x, 0, src); -} - -static inline void -xv_splice(xvect *x, size_t i, size_t j) -{ - assert(i <= j && j < xv_size(x)); - - xv_rotate(x); - memmove(xv_get(x, i), xv_get(x, j), (xv_size(x) - j) * x->width); - x->tail = (x->tail - j + i) & x->mask; -} - -static inline void -xv_insert(xvect *x, size_t i, void *src) -{ - assert(i <= xv_size(x)); - - xv_reserve(x, xv_size(x) + 1); - xv_rotate(x); - x->tail = (x->tail + 1) & x->mask; - - if (xv_size(x) - 1 != i) { - memmove(xv_get(x, i + 1), xv_get(x, i), (xv_size(x) - 1 - i) * x->width); - } - xv_set(x, i, src); -} - -#if defined(__cplusplus) -} -#endif +#define xv_a(type, v, i) \ + (((v).m <= (size_t)(i)? \ + ((v).m = (v).n = (i) + 1, xv_roundup32((v).m), \ + (v).a = (type*)xv_realloc((v).a, sizeof(type) * (v).m), 0) \ + : (v).n <= (size_t)(i)? (v).n = (i) + 1 \ + : (size_t)0), (v).a[(i)]) #endif diff --git a/extlib/benz/init.c b/extlib/benz/init.c deleted file mode 100644 index 6a1e05a3..00000000 --- a/extlib/benz/init.c +++ /dev/null @@ -1,140 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/lib.h" -#include "picrin/macro.h" -#include "picrin/error.h" - -void -pic_add_feature(pic_state *pic, const char *feature) -{ - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, feature)), pic->features); -} - -void pic_init_bool(pic_state *); -void pic_init_pair(pic_state *); -void pic_init_port(pic_state *); -void pic_init_number(pic_state *); -void pic_init_proc(pic_state *); -void pic_init_symbol(pic_state *); -void pic_init_vector(pic_state *); -void pic_init_blob(pic_state *); -void pic_init_cont(pic_state *); -void pic_init_char(pic_state *); -void pic_init_error(pic_state *); -void pic_init_str(pic_state *); -void pic_init_macro(pic_state *); -void pic_init_var(pic_state *); -void pic_init_write(pic_state *); -void pic_init_read(pic_state *); -void pic_init_dict(pic_state *); -void pic_init_record(pic_state *); -void pic_init_eval(pic_state *); -void pic_init_lib(pic_state *); -void pic_init_attr(pic_state *); - -extern const char pic_boot[]; - -static void -pic_init_features(pic_state *pic) -{ - pic_add_feature(pic, "picrin"); - pic_add_feature(pic, "ieee-float"); - -#if _POSIX_SOURCE - pic_add_feature(pic, "posix"); -#endif - -#if _WIN32 - pic_add_feature(pic, "windows"); -#endif - -#if __unix__ - pic_add_feature(pic, "unix"); -#endif -#if __gnu_linux__ - pic_add_feature(pic, "gnu-linux"); -#endif -#if __FreeBSD__ - pic_add_feature(pic, "freebsd"); -#endif - -#if __i386__ - pic_add_feature(pic, "i386"); -#elif __x86_64__ - pic_add_feature(pic, "x86-64"); -#elif __ppc__ - pic_add_feature(pic, "ppc"); -#elif __sparc__ - pic_add_feature(pic, "sparc"); -#endif - -#if __ILP32__ - pic_add_feature(pic, "ilp32"); -#elif __LP64__ - pic_add_feature(pic, "lp64"); -#endif - -#if defined(__BYTE_ORDER__) -# if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ - pic_add_feature(pic, "little-endian"); -# elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ - pic_add_feature(pic, "big-endian"); -# endif -#else -# if __LITTLE_ENDIAN__ - pic_add_feature(pic, "little-endian"); -# elif __BIG_ENDIAN__ - pic_add_feature(pic, "big-endian"); -# endif -#endif -} - -#define DONE pic_gc_arena_restore(pic, ai); - -void -pic_init_core(pic_state *pic) -{ - size_t ai = pic_gc_arena_preserve(pic); - - pic_init_features(pic); - - pic_deflibrary (pic, "(picrin base)") { - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); - - pic_init_bool(pic); DONE; - pic_init_pair(pic); DONE; - pic_init_port(pic); DONE; - pic_init_number(pic); DONE; - pic_init_proc(pic); DONE; - pic_init_symbol(pic); DONE; - pic_init_vector(pic); DONE; - pic_init_blob(pic); DONE; - pic_init_cont(pic); DONE; - pic_init_char(pic); DONE; - pic_init_error(pic); DONE; - pic_init_str(pic); DONE; - pic_init_macro(pic); DONE; - pic_init_var(pic); DONE; - pic_init_write(pic); DONE; - pic_init_read(pic); DONE; - pic_init_dict(pic); DONE; - pic_init_record(pic); DONE; - pic_init_eval(pic); DONE; - pic_init_lib(pic); DONE; - pic_init_attr(pic); DONE; - - pic_load_cstr(pic, pic_boot); - } - - pic_import_library(pic, pic->PICRIN_BASE); -} diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 37cba2bd..8e6516ad 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -3,36 +3,38 @@ */ #include "picrin.h" -#include "picrin/lib.h" -#include "picrin/pair.h" -#include "picrin/macro.h" -#include "picrin/error.h" -#include "picrin/string.h" -#include "picrin/proc.h" + +static void +setup_default_env(pic_state *pic, struct pic_env *env) +{ + void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *); + + pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); + pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->rIMPORT); + pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->rEXPORT); + pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->rCOND_EXPAND); +} struct pic_lib * -pic_open_library(pic_state *pic, pic_value name) +pic_make_library(pic_state *pic, pic_value name) { struct pic_lib *lib; - struct pic_senv *senv; + struct pic_env *env; + struct pic_dict *exports; if ((lib = pic_find_library(pic, name)) != NULL) { - -#if DEBUG - printf("* reopen library: "); - pic_debug(pic, name); - puts(""); -#endif - - return lib; + pic_errorf(pic, "library name already in use: ~s", name); } - senv = pic_null_syntactic_environment(pic); + env = pic_make_env(pic, NULL); + exports = pic_make_dict(pic); + + setup_default_env(pic, env); lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); - lib->env = senv; lib->name = name; - xh_init_int(&lib->exports, sizeof(pic_sym)); + lib->env = env; + lib->exports = exports; /* register! */ pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs); @@ -40,18 +42,6 @@ pic_open_library(pic_state *pic, pic_value name) return lib; } -void -pic_in_library(pic_state *pic, pic_value spec) -{ - struct pic_lib *lib; - - lib = pic_find_library(pic, spec); - if (! lib) { - pic_errorf(pic, "library not found: ~a", spec); - } - pic->lib = lib; -} - struct pic_lib * pic_find_library(pic_state *pic, pic_value spec) { @@ -65,93 +55,93 @@ pic_find_library(pic_state *pic, pic_value spec) } static void -import_table(pic_state *pic, pic_value spec, xhash *imports) +import_table(pic_state *pic, pic_value spec, struct pic_dict *imports) { struct pic_lib *lib; - xhash table; - pic_value val; - pic_sym sym, id, tag; - xh_entry *it; + struct pic_dict *table; + pic_value val, tmp, prefix, it; + pic_sym *sym, *id, *tag, *nick; + xh_entry *iter; - xh_init_int(&table, sizeof(pic_sym)); + table = pic_make_dict(pic); if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) { - tag = pic_sym(pic_car(pic, spec)); + tag = pic_sym_ptr(pic_car(pic, spec)); if (tag == pic->sONLY) { - import_table(pic, pic_cadr(pic, spec), &table); - pic_for_each (val, pic_cddr(pic, spec)) { - xh_put_int(imports, pic_sym(val), &xh_val(xh_get_int(&table, pic_sym(val)), pic_sym)); + import_table(pic, pic_cadr(pic, spec), table); + + pic_for_each (val, pic_cddr(pic, spec), it) { + pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val))); } - goto exit; + return; } if (tag == pic->sRENAME) { import_table(pic, pic_cadr(pic, spec), imports); - pic_for_each (val, pic_cddr(pic, spec)) { - id = xh_val(xh_get_int(imports, pic_sym(pic_car(pic, val))), pic_sym); - xh_del_int(imports, pic_sym(pic_car(pic, val))); - xh_put_int(imports, pic_sym(pic_cadr(pic, val)), &id); + + pic_for_each (val, pic_cddr(pic, spec), it) { + tmp = pic_dict_ref(pic, imports, pic_sym_ptr(pic_car(pic, val))); + pic_dict_del(pic, imports, pic_sym_ptr(pic_car(pic, val))); + pic_dict_set(pic, imports, pic_sym_ptr(pic_cadr(pic, val)), tmp); } - goto exit; + return; } if (tag == pic->sPREFIX) { - import_table(pic, pic_cadr(pic, spec), &table); - for (it = xh_begin(&table); it != NULL; it = xh_next(it)) { - val = pic_list_ref(pic, spec, 2); - sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, pic_sym_value(xh_key(it, pic_sym)))); - xh_put_int(imports, sym, &xh_val(it, pic_sym)); + import_table(pic, pic_cadr(pic, spec), table); + + prefix = pic_list_ref(pic, spec, 2); + pic_dict_for_each (sym, table, iter) { + id = pic_intern(pic, pic_format(pic, "~s~s", prefix, pic_obj_value(sym))); + pic_dict_set(pic, imports, id, pic_dict_ref(pic, table, sym)); } - goto exit; + return; } if (tag == pic->sEXCEPT) { import_table(pic, pic_cadr(pic, spec), imports); - pic_for_each (val, pic_cddr(pic, spec)) { - xh_del_int(imports, pic_sym(val)); + pic_for_each (val, pic_cddr(pic, spec), it) { + pic_dict_del(pic, imports, pic_sym_ptr(val)); } - goto exit; + return; } } lib = pic_find_library(pic, spec); if (! lib) { pic_errorf(pic, "library not found: ~a", spec); } - for (it = xh_begin(&lib->exports); it != NULL; it = xh_next(it)) { - xh_put_int(imports, xh_key(it, pic_sym), &xh_val(it, pic_sym)); - } + pic_dict_for_each (nick, lib->exports, iter) { + pic_sym *realname, *rename; - exit: - xh_destroy(&table); + realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick)); + + if ((rename = pic_find_rename(pic, lib->env, realname)) == NULL) { + pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); + } + pic_dict_set(pic, imports, nick, pic_obj_value(rename)); + } } static void import(pic_state *pic, pic_value spec) { - xhash imports; + struct pic_dict *imports; + pic_sym *sym; xh_entry *it; - xh_init_int(&imports, sizeof(pic_sym)); /* pic_sym to pic_sym */ + imports = pic_make_dict(pic); - import_table(pic, spec, &imports); + import_table(pic, spec, imports); - for (it = xh_begin(&imports); it != NULL; it = xh_next(it)) { - -#if DEBUG - printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it, pic_sym)), pic_symbol_name(pic, xh_val(it, pic_sym))); -#endif - - pic_put_rename(pic, pic->lib->env, xh_key(it, pic_sym), xh_val(it, pic_sym)); + pic_dict_for_each (sym, imports, it) { + pic_put_rename(pic, pic->lib->env, sym, pic_sym_ptr(pic_dict_ref(pic, imports, sym))); } - - xh_destroy(&imports); } static void export(pic_state *pic, pic_value spec) { - const pic_sym sRENAME = pic_intern_cstr(pic, "rename"); + pic_sym *sRENAME = pic_intern_cstr(pic, "rename"); pic_value a, b; - pic_sym rename; if (pic_sym_p(spec)) { /* (export a) */ a = b = spec; @@ -160,7 +150,7 @@ export(pic_state *pic, pic_value spec) goto fail; if (! (pic_length(pic, spec) == 3)) goto fail; - if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) + if (! pic_eq_p(pic_car(pic, spec), pic_obj_value(sRENAME))) goto fail; if (! pic_sym_p(a = pic_list_ref(pic, spec, 1))) goto fail; @@ -168,15 +158,11 @@ export(pic_state *pic, pic_value spec) goto fail; } - if (! pic_find_rename(pic, pic->lib->env, pic_sym(a), &rename)) { - pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym(a))); - } - #if DEBUG - printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym(b)), pic_symbol_name(pic, rename)); + printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym_ptr(b)), pic_symbol_name(pic, pic_sym_ptr(a))); #endif - xh_put_int(&pic->lib->exports, pic_sym(b), &rename); + pic_dict_set(pic, pic->lib->exports, pic_sym_ptr(b), a); return; @@ -197,22 +183,22 @@ pic_import_library(pic_state *pic, struct pic_lib *lib) } void -pic_export(pic_state *pic, pic_sym sym) +pic_export(pic_state *pic, pic_sym *sym) { - export(pic, pic_sym_value(sym)); + export(pic, pic_obj_value(sym)); } static bool condexpand(pic_state *pic, pic_value clause) { - pic_sym tag; - pic_value c, feature; + pic_sym *tag; + pic_value c, feature, it; - if (pic_eq_p(clause, pic_sym_value(pic->sELSE))) { + if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) { return true; } if (pic_sym_p(clause)) { - pic_for_each (feature, pic->features) { + pic_for_each (feature, pic->features, it) { if(pic_eq_p(feature, clause)) return true; } @@ -222,7 +208,7 @@ condexpand(pic_state *pic, pic_value clause) if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) { pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause); } else { - tag = pic_sym(pic_car(pic, clause)); + tag = pic_sym_ptr(pic_car(pic, clause)); } if (tag == pic->sLIBRARY) { @@ -232,14 +218,14 @@ condexpand(pic_state *pic, pic_value clause) return ! condexpand(pic, pic_list_ref(pic, clause, 1)); } if (tag == pic->sAND) { - pic_for_each (c, pic_cdr(pic, clause)) { + pic_for_each (c, pic_cdr(pic, clause), it) { if (! condexpand(pic, c)) return false; } return true; } if (tag == pic->sOR) { - pic_for_each (c, pic_cdr(pic, clause)) { + pic_for_each (c, pic_cdr(pic, clause), it) { if (condexpand(pic, c)) return true; } @@ -259,11 +245,11 @@ pic_lib_condexpand(pic_state *pic) for (i = 0; i < argc; i++) { if (condexpand(pic, pic_car(pic, clauses[i]))) { - return pic_cons(pic, pic_sym_value(pic->rBEGIN), pic_cdr(pic, clauses[i])); + return pic_cons(pic, pic_obj_value(pic->rBEGIN), pic_cdr(pic, clauses[i])); } } - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -278,7 +264,7 @@ pic_lib_import(pic_state *pic) import(pic, argv[i]); } - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -293,57 +279,46 @@ pic_lib_export(pic_state *pic) export(pic, argv[i]); } - return pic_none_value(); + return pic_undef_value(); } static pic_value pic_lib_define_library(pic_state *pic) { - struct pic_lib *prev = pic->lib; + struct pic_lib *lib, *prev = pic->lib; size_t argc, i; pic_value spec, *argv; pic_get_args(pic, "o*", &spec, &argc, &argv); - pic_open_library(pic, spec); + if ((lib = pic_find_library(pic, spec)) == NULL) { + lib = pic_make_library(pic, spec); + } pic_try { - pic_in_library(pic, spec); + pic->lib = lib; for (i = 0; i < argc; ++i) { pic_void(pic_eval(pic, argv[i], pic->lib)); } - pic_in_library(pic, prev->name); + pic->lib = prev; } pic_catch { - pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */ + pic->lib = prev; /* restores pic->lib even if an error occured */ pic_raise(pic, pic->err); } - return pic_none_value(); -} - -static pic_value -pic_lib_in_library(pic_state *pic) -{ - pic_value spec; - - pic_get_args(pic, "o", &spec); - - pic_in_library(pic, spec); - - return pic_none_value(); + return pic_undef_value(); } void pic_init_lib(pic_state *pic) { - void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t); + void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand); pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import); pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export); pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library); - pic_defmacro(pic, pic->sIN_LIBRARY, pic->rIN_LIBRARY, pic_lib_in_library); } diff --git a/extlib/benz/load.c b/extlib/benz/load.c index a6f2eb8d..53220101 100644 --- a/extlib/benz/load.c +++ b/extlib/benz/load.c @@ -3,8 +3,6 @@ */ #include "picrin.h" -#include "picrin/port.h" -#include "picrin/error.h" void pic_load_port(pic_state *pic, struct pic_port *port) diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index eb811253..a36a8c8c 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -3,84 +3,59 @@ */ #include "picrin.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/proc.h" -#include "picrin/macro.h" -#include "picrin/lib.h" -#include "picrin/error.h" -#include "picrin/dict.h" -#include "picrin/cont.h" -pic_sym -pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) +pic_sym * +pic_add_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) { - pic_sym rename; + pic_sym *rename = pic_gensym(pic, sym); + + pic_put_rename(pic, env, sym, rename); - rename = pic_gensym(pic, sym); - pic_put_rename(pic, senv, sym, rename); return rename; } void -pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename) +pic_put_rename(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rename) { - PIC_UNUSED(pic); - - xh_put_int(&senv->map, sym, &rename); + pic_dict_set(pic, env->map, sym, pic_obj_value(rename)); } -bool -pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename) +pic_sym * +pic_find_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) { - xh_entry *e; - - PIC_UNUSED(pic); - - if ((e = xh_get_int(&senv->map, sym)) == NULL) { - return false; + if (! pic_dict_has(pic, env->map, sym)) { + return NULL; } - if (rename != NULL) { - *rename = xh_val(e, pic_sym); - } - return true; + return pic_sym_ptr(pic_dict_ref(pic, env->map, sym)); } static void -define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) +define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac) { - struct pic_macro *mac; - - mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO); - mac->senv = senv; - mac->proc = proc; - - xh_put_int(&pic->macros, rename, &mac); + pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac)); } -static struct pic_macro * -find_macro(pic_state *pic, pic_sym rename) +static struct pic_proc * +find_macro(pic_state *pic, pic_sym *rename) { - xh_entry *e; - - if ((e = xh_get_int(&pic->macros, rename)) == NULL) { + if (! pic_dict_has(pic, pic->macros, rename)) { return NULL; } - return xh_val(e, struct pic_macro *); + return pic_proc_ptr(pic_dict_ref(pic, pic->macros, rename)); } -static pic_sym -make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) +static pic_sym * +make_identifier(pic_state *pic, pic_sym *sym, struct pic_env *env) { - pic_sym rename; + pic_sym *rename; while (true) { - if (pic_find_rename(pic, senv, sym, &rename)) { + if ((rename = pic_find_rename(pic, env, sym)) != NULL) { return rename; } - if (! senv->up) + if (! env->up) break; - senv = senv->up; + env = env->up; } if (! pic_interned_p(pic, sym)) { return sym; @@ -90,33 +65,33 @@ make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) } } -static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); -static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_senv *); +static pic_value macroexpand(pic_state *, pic_value, struct pic_env *); +static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_env *); static pic_value -macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) +macroexpand_symbol(pic_state *pic, pic_sym *sym, struct pic_env *env) { - return pic_sym_value(make_identifier(pic, sym, senv)); + return pic_obj_value(make_identifier(pic, sym, env)); } static pic_value macroexpand_quote(pic_state *pic, pic_value expr) { - return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); + return pic_cons(pic, pic_obj_value(pic->rQUOTE), pic_cdr(pic, expr)); } static pic_value -macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv) +macroexpand_list(pic_state *pic, pic_value obj, struct pic_env *env) { size_t ai = pic_gc_arena_preserve(pic); pic_value x, head, tail; if (pic_pair_p(obj)) { - head = macroexpand(pic, pic_car(pic, obj), senv); - tail = macroexpand_list(pic, pic_cdr(pic, obj), senv); + head = macroexpand(pic, pic_car(pic, obj), env); + tail = macroexpand_list(pic, pic_cdr(pic, obj), env); x = pic_cons(pic, head, tail); } else { - x = macroexpand(pic, obj, senv); + x = macroexpand(pic, obj, env); } pic_gc_arena_restore(pic, ai); @@ -125,46 +100,46 @@ macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv) } static pic_value -macroexpand_defer(pic_state *pic, pic_value expr, struct pic_senv *senv) +macroexpand_defer(pic_state *pic, pic_value expr, struct pic_env *env) { - pic_value skel = pic_list1(pic, pic_none_value()); /* (#) */ + pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#) */ - pic_push(pic, pic_cons(pic, expr, skel), senv->defer); + pic_push(pic, pic_cons(pic, expr, skel), env->defer); return skel; } static void -macroexpand_deferred(pic_state *pic, struct pic_senv *senv) +macroexpand_deferred(pic_state *pic, struct pic_env *env) { - pic_value defer, val, src, dst; + pic_value defer, val, src, dst, it; - pic_for_each (defer, pic_reverse(pic, senv->defer)) { + pic_for_each (defer, pic_reverse(pic, env->defer), it) { src = pic_car(pic, defer); dst = pic_cdr(pic, defer); - val = macroexpand_lambda(pic, src, senv); + val = macroexpand_lambda(pic, src, env); /* copy */ pic_pair_ptr(dst)->car = pic_car(pic, val); pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); } - senv->defer = pic_nil_value(); + env->defer = pic_nil_value(); } static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) +macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value formal, body; - struct pic_senv *in; + struct pic_env *in; pic_value a; if (pic_length(pic, expr) < 2) { pic_errorf(pic, "syntax error"); } - in = pic_make_senv(pic, senv); + in = pic_make_env(pic, env); for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { pic_value v = pic_car(pic, a); @@ -172,10 +147,10 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) if (! pic_sym_p(v)) { pic_errorf(pic, "syntax error"); } - pic_add_rename(pic, in, pic_sym(v)); + pic_add_rename(pic, in, pic_sym_ptr(v)); } if (pic_sym_p(a)) { - pic_add_rename(pic, in, pic_sym(a)); + pic_add_rename(pic, in, pic_sym_ptr(a)); } else if (! pic_nil_p(a)) { pic_errorf(pic, "syntax error"); @@ -186,20 +161,20 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) macroexpand_deferred(pic, in); - return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); + return pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, formal, body)); } static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) +macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) { - pic_sym sym, rename; + pic_sym *sym, *rename; pic_value var, val; while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) { var = pic_car(pic, pic_cadr(pic, expr)); val = pic_cdr(pic, pic_cadr(pic, expr)); - expr = pic_list3(pic, pic_sym_value(pic->rDEFINE), var, pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); + expr = pic_list3(pic, pic_obj_value(pic->rDEFINE), var, pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); } if (pic_length(pic, expr) != 3) { @@ -210,20 +185,20 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) if (! pic_sym_p(var)) { pic_errorf(pic, "binding to non-symbol object"); } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); + sym = pic_sym_ptr(var); + if ((rename = pic_find_rename(pic, env, sym)) == NULL) { + rename = pic_add_rename(pic, env, sym); } - val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv); + val = macroexpand(pic, pic_list_ref(pic, expr, 2), env); - return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val); + return pic_list3(pic, pic_obj_value(pic->rDEFINE), pic_obj_value(rename), val); } static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) +macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value var, val; - pic_sym sym, rename; + pic_sym *sym, *rename; if (pic_length(pic, expr) != 3) { pic_errorf(pic, "syntax error"); @@ -233,11 +208,11 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) if (! pic_sym_p(var)) { pic_errorf(pic, "binding to non-symbol object"); } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); + sym = pic_sym_ptr(var); + if ((rename = pic_find_rename(pic, env, sym)) == NULL) { + rename = pic_add_rename(pic, env, sym); } else { - pic_warnf(pic, "redefining syntax variable: ~s", pic_sym_value(sym)); + pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(sym)); } val = pic_cadr(pic, pic_cdr(pic, expr)); @@ -252,13 +227,19 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); } - define_macro(pic, rename, pic_proc_ptr(val), senv); + val = pic_apply1(pic, pic_proc_ptr(val), pic_obj_value(env)); - return pic_none_value(); + if (! pic_proc_p(val)) { + pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); + } + + define_macro(pic, rename, pic_proc_ptr(val)); + + return pic_undef_value(); } static pic_value -macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv) +macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) { pic_value v, args; @@ -268,14 +249,10 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct puts(""); #endif - if (mac->senv == NULL) { /* legacy macro */ - args = pic_cdr(pic, expr); - } else { - args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); - } + args = pic_list2(pic, expr, pic_obj_value(env)); pic_try { - v = pic_apply(pic, mac->proc, args); + v = pic_apply(pic, mac, args); } pic_catch { pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); } @@ -290,43 +267,43 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct } static pic_value -macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) +macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) { switch (pic_type(expr)) { case PIC_TT_SYMBOL: { - return macroexpand_symbol(pic, pic_sym(expr), senv); + return macroexpand_symbol(pic, pic_sym_ptr(expr), env); } case PIC_TT_PAIR: { pic_value car; - struct pic_macro *mac; + struct pic_proc *mac; if (! pic_list_p(expr)) { pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); } - car = macroexpand(pic, pic_car(pic, expr), senv); + car = macroexpand(pic, pic_car(pic, expr), env); if (pic_sym_p(car)) { - pic_sym tag = pic_sym(car); + pic_sym *tag = pic_sym_ptr(car); if (tag == pic->rDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, senv); + return macroexpand_defsyntax(pic, expr, env); } else if (tag == pic->rLAMBDA) { - return macroexpand_defer(pic, expr, senv); + return macroexpand_defer(pic, expr, env); } else if (tag == pic->rDEFINE) { - return macroexpand_define(pic, expr, senv); + return macroexpand_define(pic, expr, env); } else if (tag == pic->rQUOTE) { return macroexpand_quote(pic, expr); } if ((mac = find_macro(pic, tag)) != NULL) { - return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, senv), senv); + return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env); } } - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv)); + return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), env)); } default: return expr; @@ -334,7 +311,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) } static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) +macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) { size_t ai = pic_gc_arena_preserve(pic); pic_value v; @@ -345,7 +322,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) puts(""); #endif - v = macroexpand_node(pic, expr, senv); + v = macroexpand_node(pic, expr, env); pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, v); @@ -385,52 +362,49 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) return v; } -struct pic_senv * -pic_make_senv(pic_state *pic, struct pic_senv *up) +struct pic_env * +pic_make_env(pic_state *pic, struct pic_env *up) { - struct pic_senv *senv; + struct pic_env *env; + struct pic_dict *map; - senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); - senv->up = up; - senv->defer = pic_nil_value(); - xh_init_int(&senv->map, sizeof(pic_sym)); + map = pic_make_dict(pic); - return senv; + env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); + env->up = up; + env->defer = pic_nil_value(); + env->map = map; + + return env; } -struct pic_senv * -pic_null_syntactic_environment(pic_state *pic) +static pic_value +defmacro_call(pic_state *pic) { - struct pic_senv *senv; + struct pic_proc *self = pic_get_proc(pic); + pic_value args, tmp, proc; - senv = pic_make_senv(pic, NULL); + pic_get_args(pic, "oo", &args, &tmp); - pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); - pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT); - pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT); - pic_define_syntactic_keyword(pic, senv, pic->sIN_LIBRARY, pic->rIN_LIBRARY); - pic_define_syntactic_keyword(pic, senv, pic->sCOND_EXPAND, pic->rCOND_EXPAND); + proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer"); - return senv; + return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args)); } void -pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) +pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) { - pic_put_rename(pic, senv, sym, rsym); + struct pic_proc *proc, *trans; - if (pic->lib && pic->lib->env == senv) { - pic_export(pic, sym); - } -} + trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); -void -pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func) -{ pic_put_rename(pic, pic->lib->env, name, id); + proc = pic_make_proc(pic, defmacro_call, "defmacro_call"); + pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans)); + /* symbol registration */ - define_macro(pic, id, pic_make_proc(pic, func, pic_symbol_name(pic, name)), NULL); + define_macro(pic, id, proc); /* auto export! */ pic_export(pic, name); @@ -439,13 +413,13 @@ pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func) bool pic_identifier_p(pic_state *pic, pic_value obj) { - return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj)); + return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym_ptr(obj)); } bool -pic_identifier_eq_p(pic_state *pic, struct pic_senv *env1, pic_sym sym1, struct pic_senv *env2, pic_sym sym2) +pic_identifier_eq_p(pic_state *pic, struct pic_env *env1, pic_sym *sym1, struct pic_env *env2, pic_sym *sym2) { - pic_sym a, b; + pic_sym *a, *b; a = make_identifier(pic, sym1, env1); if (a != make_identifier(pic, sym1, env1)) { @@ -457,7 +431,7 @@ pic_identifier_eq_p(pic_state *pic, struct pic_senv *env1, pic_sym sym1, struct b = sym2; } - return pic_eq_p(pic_sym_value(a), pic_sym_value(b)); + return pic_eq_p(pic_obj_value(a), pic_obj_value(b)); } static pic_value @@ -474,27 +448,27 @@ static pic_value pic_macro_make_identifier(pic_state *pic) { pic_value obj; - pic_sym sym; + pic_sym *sym; pic_get_args(pic, "mo", &sym, &obj); - pic_assert_type(pic, obj, senv); + pic_assert_type(pic, obj, env); - return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj))); + return pic_obj_value(make_identifier(pic, sym, pic_env_ptr(obj))); } static pic_value pic_macro_identifier_eq_p(pic_state *pic) { - pic_sym sym1, sym2; + pic_sym *sym1, *sym2; pic_value env1, env2; pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2); - pic_assert_type(pic, env1, senv); - pic_assert_type(pic, env2, senv); + pic_assert_type(pic, env1, env); + pic_assert_type(pic, env2, env); - return pic_bool_value(pic_identifier_eq_p(pic, pic_senv_ptr(env1), sym1, pic_senv_ptr(env2), sym2)); + return pic_bool_value(pic_identifier_eq_p(pic, pic_env_ptr(env1), sym1, pic_env_ptr(env2), sym2)); } void diff --git a/extlib/benz/number.c b/extlib/benz/number.c index 6e84dadf..80c7fab9 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -3,8 +3,18 @@ */ #include "picrin.h" -#include "picrin/string.h" -#include "picrin/cont.h" + +#if ! PIC_ENABLE_FLOAT +static pic_value +pic_number_id(pic_state *pic) +{ + int i; + + pic_get_args(pic, "i", &i); + + return pic_int_value(i); +} +#endif /** * Returns the length of string representing val. @@ -14,13 +24,13 @@ static int number_string_length(int val, int radix) { - long long v = val; /* in case val == INT_MIN */ + unsigned long v = val; /* in case val == INT_MIN */ int count = 0; if (val == 0) { return 1; } if (val < 0) { - v = - v; + v = -val; count = 1; } while (v > 0) { @@ -39,7 +49,7 @@ number_string_length(int val, int radix) static void number_string(int val, int radix, int length, char *buffer) { const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz"; - long long v = val; + unsigned long v = val; int i; if (val == 0) { buffer[0] = '0'; @@ -48,7 +58,7 @@ number_string(int val, int radix, int length, char *buffer) { } if (val < 0) { buffer[0] = '-'; - v = -v; + v = -val; } for(i = length - 1; v > 0; --i) { @@ -66,7 +76,11 @@ pic_number_real_p(pic_state *pic) pic_get_args(pic, "o", &v); +#if PIC_ENABLE_FLOAT return pic_bool_value(pic_float_p(v) || pic_int_p(v)); +#else + return pic_bool_value(pic_int_p(v)); +#endif } static pic_value @@ -79,6 +93,7 @@ pic_number_integer_p(pic_state *pic) if (pic_int_p(v)) { return pic_true_value(); } +#if PIC_ENABLE_FLOAT if (pic_float_p(v)) { double f = pic_float(v); @@ -90,6 +105,7 @@ pic_number_integer_p(pic_state *pic) return pic_true_value(); } } +#endif return pic_false_value(); } @@ -110,48 +126,11 @@ pic_number_inexact_p(pic_state *pic) pic_get_args(pic, "o", &v); +#if PIC_ENABLE_FLOAT return pic_bool_value(pic_float_p(v)); -} - -static pic_value -pic_number_finite_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_int_p(v)) - return pic_true_value(); - if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v)))) - return pic_true_value(); - else - return pic_false_value(); -} - -static pic_value -pic_number_infinite_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_float_p(v) && isinf(pic_float(v))) - return pic_true_value(); - else - return pic_false_value(); -} - -static pic_value -pic_number_nan_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_float_p(v) && isnan(pic_float(v))) - return pic_true_value(); - else - return pic_false_value(); +#else + return pic_false_value(); +#endif } #define DEFINE_ARITH_CMP(op, name) \ @@ -183,11 +162,46 @@ pic_number_nan_p(pic_state *pic) return pic_true_value(); \ } +#define DEFINE_ARITH_CMP2(op, name) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + int f,g; \ + \ + pic_get_args(pic, "ii*", &f, &g, &argc, &argv); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + \ + for (i = 0; i < argc; ++i) { \ + f = g; \ + if (pic_int_p(argv[i])) \ + g = pic_int(argv[i]); \ + else \ + pic_errorf(pic, #op ": number required"); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + } \ + \ + return pic_true_value(); \ + } + +#if PIC_ENABLE_FLOAT DEFINE_ARITH_CMP(==, eq) DEFINE_ARITH_CMP(<, lt) DEFINE_ARITH_CMP(>, gt) DEFINE_ARITH_CMP(<=, le) DEFINE_ARITH_CMP(>=, ge) +#else +DEFINE_ARITH_CMP2(==, eq) +DEFINE_ARITH_CMP2(<, lt) +DEFINE_ARITH_CMP2(>, gt) +DEFINE_ARITH_CMP2(<=, le) +DEFINE_ARITH_CMP2(>=, ge) +#endif #define DEFINE_ARITH_OP(op, name, unit) \ static pic_value \ @@ -217,63 +231,170 @@ DEFINE_ARITH_CMP(>=, ge) return e ? pic_int_value((int)f) : pic_float_value(f); \ } +#define DEFINE_ARITH_OP2(op, name, unit) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + int f; \ + \ + pic_get_args(pic, "*", &argc, &argv); \ + \ + f = unit; \ + for (i = 0; i < argc; ++i) { \ + if (pic_int_p(argv[i])) { \ + f op##= pic_int(argv[i]); \ + } \ + else { \ + pic_errorf(pic, #op ": number required"); \ + } \ + } \ + \ + return pic_int_value(f); \ + } + +#if PIC_ENABLE_FLOAT DEFINE_ARITH_OP(+, add, 0) DEFINE_ARITH_OP(*, mul, 1) +#else +DEFINE_ARITH_OP2(+, add, 0) +DEFINE_ARITH_OP2(*, mul, 1) +#endif #define DEFINE_ARITH_INV_OP(op, name, unit, exact) \ static pic_value \ pic_number_##name(pic_state *pic) \ { \ size_t argc, i; \ - pic_value *argv; \ - double f; \ - bool e; \ + pic_value *argv; \ + double f; \ + bool e = true; \ \ - pic_get_args(pic, "F*", &f, &e, &argc, &argv); \ + pic_get_args(pic, "F*", &f, &e, &argc, &argv); \ \ - e = e && exact; \ + e = e && exact; \ \ - if (argc == 0) { \ - f = unit op f; \ - } \ - for (i = 0; i < argc; ++i) { \ - if (pic_int_p(argv[i])) { \ - f op##= pic_int(argv[i]); \ - } \ - else if (pic_float_p(argv[i])) { \ - e = false; \ - f op##= pic_float(argv[i]); \ - } \ - else { \ - pic_errorf(pic, #op ": number required"); \ - } \ - } \ + if (argc == 0) { \ + f = unit op f; \ + } \ + for (i = 0; i < argc; ++i) { \ + if (pic_int_p(argv[i])) { \ + f op##= pic_int(argv[i]); \ + } \ + else if (pic_float_p(argv[i])) { \ + e = false; \ + f op##= pic_float(argv[i]); \ + } \ + else { \ + pic_errorf(pic, #op ": number required"); \ + } \ + } \ \ - return e ? pic_int_value((int)f) : pic_float_value(f); \ + return e ? pic_int_value((int)f) : pic_float_value(f); \ } +#define DEFINE_ARITH_INV_OP2(op, name, unit) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + int f; \ + \ + pic_get_args(pic, "i*", &f, &argc, &argv); \ + \ + if (argc == 0) { \ + f = unit op f; \ + } \ + for (i = 0; i < argc; ++i) { \ + if (pic_int_p(argv[i])) { \ + f op##= pic_int(argv[i]); \ + } \ + else { \ + pic_errorf(pic, #op ": number required"); \ + } \ + } \ + \ + return pic_int_value(f); \ + } + +#if PIC_ENABLE_FLOAT DEFINE_ARITH_INV_OP(-, sub, 0, true) DEFINE_ARITH_INV_OP(/, div, 1, false) +#else +DEFINE_ARITH_INV_OP2(-, sub, 0) +DEFINE_ARITH_INV_OP2(/, div, 1) +#endif static pic_value pic_number_abs(pic_state *pic) { +#if PIC_ENABLE_FLOAT double f; bool e; pic_get_args(pic, "F", &f, &e); if (e) { - return pic_int_value(abs((int)f)); + return pic_int_value(f < 0 ? -f : f); } else { return pic_float_value(fabs(f)); } +#else + int i; + + pic_get_args(pic, "i", &i); + + return pic_int_value(i < 0 ? -i : i); +#endif +} + +static pic_value +pic_number_expt(pic_state *pic) +{ +#if PIC_ENABLE_FLOAT + double f, g, h; + bool e1, e2; + + pic_get_args(pic, "FF", &f, &e1, &g, &e2); + + h = pow(f, g); + if (e1 && e2) { + if (h <= INT_MAX) { + return pic_int_value((int)h); + } + } + return pic_float_value(h); +#else + int x, y, i, e = 1, r = 1, s = 0; + + pic_get_args(pic, "ii", &x, &y); + + if (y < 0) { + s = 1; + y = -y; + } + e = x; + for (i = 0; y; ++i) { + if ((y & 1) != 0) { + r *= e; + } + e *= e; + y >>= 1; + } + if (s != 0) { + r = 1 / r; + } + return pic_int_value(r); +#endif } static pic_value pic_number_floor2(pic_state *pic) { +#if PIC_ENABLE_FLOAT int i, j; bool e1, e2; @@ -295,11 +416,23 @@ pic_number_floor2(pic_state *pic) r = i - j * q; return pic_values2(pic, pic_float_value(q), pic_float_value(r)); } +#else + int i, j, k; + + pic_get_args(pic, "ii", &i, &j); + + k = (i < 0 && j < 0) || (0 <= i && 0 <= j) + ? i / j + : (i / j) - 1; + + return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j)); +#endif } static pic_value pic_number_trunc2(pic_state *pic) { +#if PIC_ENABLE_FLOAT int i, j; bool e1, e2; @@ -316,8 +449,16 @@ pic_number_trunc2(pic_state *pic) return pic_values2(pic, pic_float_value(q), pic_float_value(r)); } +#else + int i, j; + + pic_get_args(pic, "ii", &i, &j); + + return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j)); +#endif } +#if PIC_ENABLE_FLOAT static pic_value pic_number_floor(pic_state *pic) { @@ -382,6 +523,180 @@ pic_number_round(pic_state *pic) } } +static pic_value +pic_number_inexact(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_float_value(f); +} + +static pic_value +pic_number_exact(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_int_value((int)(round(f))); +} +#endif + +static pic_value +pic_number_number_to_string(pic_state *pic) +{ +#if PIC_ENABLE_FLOAT + double f; + bool e; + int radix = 10; + pic_str *str; + + pic_get_args(pic, "F|i", &f, &e, &radix); + + if (radix < 2 || radix > 36) { + pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); + } + + if (e) { + int ival = (int) f; + int ilen = number_string_length(ival, radix); + size_t s = ilen + 1; + char *buf = pic_malloc(pic, s); + + number_string(ival, radix, ilen, buf); + + str = pic_make_str(pic, buf, s - 1); + + pic_free(pic, buf); + } + else { + struct pic_port *port = pic_open_output_string(pic); + + xfprintf(port->file, "%f", f); + + str = pic_get_output_string(pic, port); + + pic_close_port(pic, port); + } + + return pic_obj_value(str); +#else + int f; + bool e; + int radix = 10; + pic_str *str; + size_t s; + char *buf; + int ival, ilen; + + pic_get_args(pic, "i|i", &f, &e, &radix); + + if (radix < 2 || radix > 36) { + pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); + } + + ival = f; + ilen = number_string_length(ival, radix); + s = ilen + 1; + + buf = pic_malloc(pic, s); + + number_string(ival, radix, ilen, buf); + + str = pic_make_str(pic, buf, s - 1); + + pic_free(pic, buf); + + return pic_obj_value(str); +#endif +} + +static pic_value +pic_number_string_to_number(pic_state *pic) +{ +#if PIC_ENABLE_FLOAT + const char *str; + int radix = 10; + long num; + char *eptr; + double flo; + + pic_get_args(pic, "z|i", &str, &radix); + + num = strtol(str, &eptr, radix); + if (*eptr == '\0') { + return pic_valid_int(num) + ? pic_int_value((int)num) + : pic_float_value(num); + } + + flo = strtod(str, &eptr); + if (*eptr == '\0') { + return pic_float_value(flo); + } + + pic_errorf(pic, "invalid string given: %s", str); +#else + const char *str; + int radix = 10; + long num; + char *eptr; + + pic_get_args(pic, "z|i", &str, &radix); + + num = strtol(str, &eptr, radix); + if (*eptr == '\0') { + return pic_int_value(num); + } + + pic_errorf(pic, "invalid string given: %s", str); +#endif +} + +#if PIC_ENABLE_FLOAT +static pic_value +pic_number_finite_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_int_p(v)) + return pic_true_value(); + if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v)))) + return pic_true_value(); + else + return pic_false_value(); +} + +static pic_value +pic_number_infinite_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_float_p(v) && isinf(pic_float(v))) + return pic_true_value(); + else + return pic_false_value(); +} + +static pic_value +pic_number_nan_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_float_p(v) && isnan(pic_float(v))) + return pic_true_value(); + else + return pic_false_value(); +} + static pic_value pic_number_exp(pic_state *pic) { @@ -481,104 +796,13 @@ pic_number_sqrt(pic_state *pic) return pic_float_value(sqrt(f)); } - -static pic_value -pic_number_expt(pic_state *pic) -{ - double f, g, h; - bool e1, e2; - - pic_get_args(pic, "FF", &f, &e1, &g, &e2); - - h = pow(f, g); - if (e1 && e2) { - if (h <= INT_MAX) { - return pic_int_value((int)h); - } - } - return pic_float_value(h); -} - -static pic_value -pic_number_inexact(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_float_value(f); -} - -static pic_value -pic_number_exact(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_int_value((int)(round(f))); -} - -static pic_value -pic_number_number_to_string(pic_state *pic) -{ - double f; - bool e; - int radix = 10; - - pic_get_args(pic, "F|i", &f, &e, &radix); - - if (radix < 2 || radix > 36) { - pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); - } - - if (e) { - int ival = (int) f; - int ilen = number_string_length(ival, radix); - char buf[ilen + 1]; - - number_string(ival, radix, ilen, buf); - - return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); - } - else { - char buf[snprintf(NULL, 0, "%f", f) + 1]; - - snprintf(buf, sizeof buf, "%f", f); - - return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); - } -} - -static pic_value -pic_number_string_to_number(pic_state *pic) -{ - const char *str; - int radix = 10; - long num; - char *eptr; - double flo; - - pic_get_args(pic, "z|i", &str, &radix); - - num = strtol(str, &eptr, radix); - if (*eptr == '\0') { - return pic_valid_int(num) - ? pic_int_value((int)num) - : pic_float_value(num); - } - - flo = strtod(str, &eptr); - if (*eptr == '\0') { - return pic_float_value(flo); - } - - pic_errorf(pic, "invalid string given: %s", str); -} +#endif void pic_init_number(pic_state *pic) { + void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); + size_t ai = pic_gc_arena_preserve(pic); pic_defun(pic, "number?", pic_number_real_p); @@ -592,41 +816,54 @@ pic_init_number(pic_state *pic) pic_defun(pic, "inexact?", pic_number_inexact_p); pic_gc_arena_restore(pic, ai); - pic_defun(pic, "=", pic_number_eq); - pic_defun(pic, "<", pic_number_lt); - pic_defun(pic, ">", pic_number_gt); - pic_defun(pic, "<=", pic_number_le); - pic_defun(pic, ">=", pic_number_ge); + pic_defun_vm(pic, "=", pic->rEQ, pic_number_eq); + pic_defun_vm(pic, "<", pic->rLT, pic_number_lt); + pic_defun_vm(pic, ">", pic->rGT, pic_number_gt); + pic_defun_vm(pic, "<=", pic->rLE, pic_number_le); + pic_defun_vm(pic, ">=", pic->rGE, pic_number_ge); pic_gc_arena_restore(pic, ai); - pic_defun(pic, "+", pic_number_add); - pic_defun(pic, "-", pic_number_sub); - pic_defun(pic, "*", pic_number_mul); - pic_defun(pic, "/", pic_number_div); + pic_defun_vm(pic, "+", pic->rADD, pic_number_add); + pic_defun_vm(pic, "-", pic->rSUB, pic_number_sub); + pic_defun_vm(pic, "*", pic->rMUL, pic_number_mul); + pic_defun_vm(pic, "/", pic->rDIV, pic_number_div); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "abs", pic_number_abs); + pic_defun(pic, "expt", pic_number_expt); pic_gc_arena_restore(pic, ai); pic_defun(pic, "floor/", pic_number_floor2); pic_defun(pic, "truncate/", pic_number_trunc2); pic_gc_arena_restore(pic, ai); +#if PIC_ENABLE_FLOAT pic_defun(pic, "floor", pic_number_floor); pic_defun(pic, "ceiling", pic_number_ceil); pic_defun(pic, "truncate", pic_number_trunc); pic_defun(pic, "round", pic_number_round); - pic_gc_arena_restore(pic, ai); - pic_defun(pic, "inexact", pic_number_inexact); pic_defun(pic, "exact", pic_number_exact); pic_gc_arena_restore(pic, ai); +#else + pic_defun(pic, "floor", pic_number_id); + pic_defun(pic, "ceiling", pic_number_id); + pic_defun(pic, "truncate", pic_number_id); + pic_defun(pic, "round", pic_number_id); + pic_defun(pic, "inexact", pic_number_id); + pic_defun(pic, "exact", pic_number_id); + pic_gc_arena_restore(pic, ai); +#endif + pic_defun(pic, "number->string", pic_number_number_to_string); + pic_defun(pic, "string->number", pic_number_string_to_number); + pic_gc_arena_restore(pic, ai); + +#if PIC_ENABLE_FLOAT pic_defun(pic, "finite?", pic_number_finite_p); pic_defun(pic, "infinite?", pic_number_infinite_p); pic_defun(pic, "nan?", pic_number_nan_p); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "abs", pic_number_abs); pic_defun(pic, "sqrt", pic_number_sqrt); - pic_defun(pic, "expt", pic_number_expt); pic_defun(pic, "exp", pic_number_exp); pic_defun(pic, "log", pic_number_log); pic_defun(pic, "sin", pic_number_sin); @@ -636,8 +873,5 @@ pic_init_number(pic_state *pic) pic_defun(pic, "asin", pic_number_asin); pic_defun(pic, "atan", pic_number_atan); pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "number->string", pic_number_number_to_string); - pic_defun(pic, "string->number", pic_number_string_to_number); - pic_gc_arena_restore(pic, ai); +#endif } diff --git a/extlib/benz/pair.c b/extlib/benz/pair.c index 03621ec1..b3da3b6d 100644 --- a/extlib/benz/pair.c +++ b/extlib/benz/pair.c @@ -3,7 +3,6 @@ */ #include "picrin.h" -#include "picrin/pair.h" pic_value pic_cons(pic_state *pic, pic_value car, pic_value cdr) @@ -204,10 +203,10 @@ pic_value pic_reverse(pic_state *pic, pic_value list) { size_t ai = pic_gc_arena_preserve(pic); - pic_value v, acc; + pic_value v, acc, it; acc = pic_nil_value(); - pic_for_each(v, list) { + pic_for_each(v, list, it) { acc = pic_cons(pic, v, acc); pic_gc_arena_restore(pic, ai); @@ -220,10 +219,10 @@ pic_value pic_append(pic_state *pic, pic_value xs, pic_value ys) { size_t ai = pic_gc_arena_preserve(pic); - pic_value x; + pic_value x, it; xs = pic_reverse(pic, xs); - pic_for_each (x, xs) { + pic_for_each (x, xs, it) { ys = pic_cons(pic, x, ys); pic_gc_arena_restore(pic, ai); @@ -493,7 +492,7 @@ pic_pair_set_car(pic_state *pic) pic_set_car(pic, v, w); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -505,7 +504,7 @@ pic_pair_set_cdr(pic_state *pic) pic_set_cdr(pic, v, w); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -532,7 +531,7 @@ static pic_value pic_pair_make_list(pic_state *pic) { size_t i; - pic_value fill = pic_none_value(); + pic_value fill = pic_undef_value(); pic_get_args(pic, "k|o", &i, &fill); @@ -622,7 +621,7 @@ pic_pair_list_set(pic_state *pic) pic_list_set(pic, list, i, obj); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -645,6 +644,9 @@ pic_pair_map(pic_state *pic) pic_get_args(pic, "l*", &proc, &argc, &args); + if (argc == 0) + pic_errorf(pic, "map: wrong number of arguments (1 for at least 2)"); + ret = pic_nil_value(); do { arg = pic_nil_value(); @@ -655,6 +657,7 @@ pic_pair_map(pic_state *pic) pic_push(pic, pic_car(pic, args[i]), arg); args[i] = pic_cdr(pic, args[i]); } + if (i != argc) { break; } @@ -689,7 +692,7 @@ pic_pair_for_each(pic_state *pic) pic_apply(pic, proc, pic_reverse(pic, arg)); } while (1); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -757,13 +760,16 @@ pic_pair_assoc(pic_state *pic) void pic_init_pair(pic_state *pic) { - pic_defun(pic, "pair?", pic_pair_pair_p); - pic_defun(pic, "cons", pic_pair_cons); - pic_defun(pic, "car", pic_pair_car); - pic_defun(pic, "cdr", pic_pair_cdr); + void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); + + pic_defun_vm(pic, "pair?", pic->rPAIRP, pic_pair_pair_p); + pic_defun_vm(pic, "cons", pic->rCONS, pic_pair_cons); + pic_defun_vm(pic, "car", pic->rCAR, pic_pair_car); + pic_defun_vm(pic, "cdr", pic->rCDR, pic_pair_cdr); + pic_defun_vm(pic, "null?", pic->rNILP, pic_pair_null_p); + pic_defun(pic, "set-car!", pic_pair_set_car); pic_defun(pic, "set-cdr!", pic_pair_set_cdr); - pic_defun(pic, "null?", pic_pair_null_p); pic_defun(pic, "caar", pic_pair_caar); pic_defun(pic, "cadr", pic_pair_cadr); diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 5032104b..5b04f89b 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -3,10 +3,6 @@ */ #include "picrin.h" -#include "picrin/proc.h" -#include "picrin/port.h" -#include "picrin/string.h" -#include "picrin/blob.h" pic_value pic_eof_object() @@ -38,6 +34,16 @@ pic_stdout(pic_state *pic) return pic_port_ptr(obj); } +struct pic_port * +pic_stderr(pic_state *pic) +{ + pic_value obj; + + obj = pic_funcall(pic, pic->PICRIN_BASE, "current-error-port", pic_nil_value()); + + return pic_port_ptr(obj); +} + struct pic_port * pic_make_standard_port(pic_state *pic, xFILE *file, short dir) { @@ -50,20 +56,108 @@ pic_make_standard_port(pic_state *pic, xFILE *file, short dir) return port; } +struct strfile { + pic_state *pic; + char *buf; + long pos, end, capa; +}; + +static int +string_read(void *cookie, char *ptr, int size) +{ + struct strfile *m = cookie; + + if (size > (int)(m->end - m->pos)) + size = (int)(m->end - m->pos); + memcpy(ptr, m->buf + m->pos, size); + m->pos += size; + return size; +} + +static int +string_write(void *cookie, const char *ptr, int size) +{ + struct strfile *m = cookie; + + if (m->pos + size >= m->capa) { + m->capa = (m->pos + size) * 2; + m->buf = pic_realloc(m->pic, m->buf, (size_t)m->capa); + } + memcpy(m->buf + m->pos, ptr, size); + m->pos += size; + if (m->end < m->pos) + m->end = m->pos; + return size; +} + +static long +string_seek(void *cookie, long pos, int whence) +{ + struct strfile *m = cookie; + + switch (whence) { + case XSEEK_SET: + m->pos = pos; + break; + case XSEEK_CUR: + m->pos += pos; + break; + case XSEEK_END: + m->pos = m->end + pos; + break; + } + + return m->pos; +} + +static int +string_close(void *cookie) +{ + struct strfile *m = cookie; + + pic_free(m->pic, m->buf); + pic_free(m->pic, m); + return 0; +} + +static xFILE * +string_open(pic_state *pic, const char *data, size_t size) +{ + struct strfile *m; + xFILE *file; + + m = pic_malloc(pic, sizeof(struct strfile)); + m->pic = pic; + m->buf = pic_malloc(pic, size); + m->pos = 0; + m->end = size; + m->capa = size; + + + if (data != NULL) { + memcpy(m->buf, data, size); + file = xfunopen(m, string_read, NULL, string_seek, string_close); + } else { + file = xfunopen(m, NULL, string_write, string_seek, string_close); + } + + if (file == NULL) { + string_close(m); + pic_error(pic, "could not open new output string/bytevector port", pic_nil_value()); + } + return file; +} + struct pic_port * pic_open_input_string(pic_state *pic, const char *str) { struct pic_port *port; port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); + port->file = string_open(pic, str, strlen(str)); port->flags = PIC_PORT_IN | PIC_PORT_TEXT; port->status = PIC_PORT_OPEN; - xfputs(str, port->file); - xfflush(port->file); - xrewind(port->file); - return port; } @@ -73,7 +167,7 @@ pic_open_output_string(pic_state *pic) struct pic_port *port; port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); + port->file = string_open(pic, NULL, 0); port->flags = PIC_PORT_OUT | PIC_PORT_TEXT; port->status = PIC_PORT_OPEN; @@ -83,20 +177,17 @@ pic_open_output_string(pic_state *pic) struct pic_string * pic_get_output_string(pic_state *pic, struct pic_port *port) { - size_t size; - char *buf; + struct strfile *s; + + if (port->file->vtable.write != string_write) { + pic_errorf(pic, "get-output-string: port is not made by open-output-string"); + } - /* get endpos */ xfflush(port->file); - size = (size_t)xftell(port->file); - xrewind(port->file); - /* copy to buf */ - buf = (char *)pic_alloc(pic, size + 1); - buf[size] = 0; - xfread(buf, size, 1, port->file); + s = port->file->vtable.cookie; - return pic_make_str(pic, buf, size); + return pic_make_str(pic, s->buf, s->end); } void @@ -236,7 +327,7 @@ pic_port_close_port(pic_state *pic) pic_close_port(pic, port); - return pic_none_value(); + return pic_undef_value(); } #define assert_port_profile(port, flgs, stat, caller) do { \ @@ -312,14 +403,10 @@ pic_port_open_input_blob(pic_state *pic) pic_get_args(pic, "b", &blob); port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); + port->file = string_open(pic, (const char *)blob->data, blob->len); port->flags = PIC_PORT_IN | PIC_PORT_BINARY; port->status = PIC_PORT_OPEN; - xfwrite(blob->data, 1, blob->len, port->file); - xfflush(port->file); - xrewind(port->file); - return pic_obj_value(port); } @@ -331,7 +418,7 @@ pic_port_open_output_bytevector(pic_state *pic) pic_get_args(pic, ""); port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); + port->file = string_open(pic, NULL, 0); port->flags = PIC_PORT_OUT | PIC_PORT_BINARY; port->status = PIC_PORT_OPEN; @@ -343,20 +430,22 @@ pic_port_get_output_bytevector(pic_state *pic) { struct pic_port *port = pic_stdout(pic); pic_blob *blob; - size_t size; + struct strfile *s; pic_get_args(pic, "|p", &port); assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector"); - /* get endpos */ - xfflush(port->file); - size = (size_t)xftell(port->file); - xrewind(port->file); + if (port->file->vtable.write != string_write) { + pic_errorf(pic, "get-output-bytevector: port is not made by open-output-bytevector"); + } - /* copy to buf */ - blob = pic_make_blob(pic, size); - xfread(blob->data, 1, size, port->file); + xfflush(port->file); + + s = port->file->vtable.cookie; + + blob = pic_make_blob(pic, s->end); + memcpy(blob->data, s->buf, s->end); return pic_obj_value(blob); } @@ -415,7 +504,7 @@ pic_port_read_line(pic_state *pic) } str = pic_get_output_string(pic, buf); - if (pic_strlen(str) == 0 && c == EOF) { + if (pic_str_len(str) == 0 && c == EOF) { return pic_eof_object(); } else { @@ -456,7 +545,7 @@ pic_port_read_string(pic_state *pic){ } str = pic_get_output_string(pic, buf); - if (pic_strlen(str) == 0 && c == EOF) { + if (pic_str_len(str) == 0 && c == EOF) { return pic_eof_object(); } else { @@ -586,7 +675,7 @@ pic_port_newline(pic_state *pic) assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "newline"); xfputs("\n", port->file); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -600,7 +689,7 @@ pic_port_write_char(pic_state *pic) assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-char"); xfputc(c, port->file); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -625,7 +714,7 @@ pic_port_write_string(pic_state *pic) for (i = start; i < end && str[i] != '\0'; ++i) { xfputc(str[i], port->file); } - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -639,7 +728,7 @@ pic_port_write_byte(pic_state *pic) assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-u8"); xfputc(i, port->file); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -665,7 +754,7 @@ pic_port_write_blob(pic_state *pic) for (i = start; i < end; ++i) { xfputc(blob->data[i], port->file); } - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -678,7 +767,7 @@ pic_port_flush(pic_state *pic) assert_port_profile(port, PIC_PORT_OUT, PIC_PORT_OPEN, "flush-output-port"); xfflush(port->file); - return pic_none_value(); + return pic_undef_value(); } void diff --git a/extlib/benz/proc.c b/extlib/benz/proc.c index 2b94201b..9e5713c1 100644 --- a/extlib/benz/proc.c +++ b/extlib/benz/proc.c @@ -3,49 +3,78 @@ */ #include "picrin.h" -#include "picrin/pair.h" -#include "picrin/proc.h" -#include "picrin/irep.h" struct pic_proc * pic_make_proc(pic_state *pic, pic_func_t func, const char *name) { struct pic_proc *proc; + pic_sym *sym; assert(name != NULL); + sym = pic_intern_cstr(pic, name); + proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->kind = PIC_PROC_KIND_FUNC; - proc->u.func.f = func; - proc->u.func.name = pic_intern_cstr(pic, name); - proc->env = NULL; + proc->tag = PIC_PROC_TAG_FUNC; + proc->u.f.func = func; + proc->u.f.name = sym; + proc->u.f.env = NULL; return proc; } struct pic_proc * -pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env) +pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_context *cxt) { struct pic_proc *proc; proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->kind = PIC_PROC_KIND_IREP; - proc->u.irep = irep; - proc->env = env; + proc->tag = PIC_PROC_TAG_IREP; + proc->u.i.irep = irep; + proc->u.i.cxt = cxt; return proc; } -pic_sym +pic_sym * pic_proc_name(struct pic_proc *proc) { - switch (proc->kind) { - case PIC_PROC_KIND_FUNC: - return proc->u.func.name; - case PIC_PROC_KIND_IREP: - return proc->u.irep->name; + switch (proc->tag) { + case PIC_PROC_TAG_FUNC: + return proc->u.f.name; + case PIC_PROC_TAG_IREP: + return proc->u.i.irep->name; } PIC_UNREACHABLE(); } +struct pic_dict * +pic_proc_env(pic_state *pic, struct pic_proc *proc) +{ + assert(pic_proc_func_p(proc)); + + if (! proc->u.f.env) { + proc->u.f.env = pic_make_dict(pic); + } + return proc->u.f.env; +} + +bool +pic_proc_env_has(pic_state *pic, struct pic_proc *proc, const char *key) +{ + return pic_dict_has(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key)); +} + +pic_value +pic_proc_env_ref(pic_state *pic, struct pic_proc *proc, const char *key) +{ + return pic_dict_ref(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key)); +} + +void +pic_proc_env_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value val) +{ + pic_dict_set(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key), val); +} + static pic_value pic_proc_proc_p(pic_state *pic) { diff --git a/extlib/benz/read.c b/extlib/benz/read.c index aed121a6..8320af38 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -3,22 +3,18 @@ */ #include "picrin.h" -#include "picrin/read.h" -#include "picrin/error.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/vector.h" -#include "picrin/blob.h" -#include "picrin/port.h" -#include "picrin/proc.h" static pic_value read(pic_state *pic, struct pic_port *port, int c); static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c); -pic_noreturn static void +PIC_NORETURN static void read_error(pic_state *pic, const char *msg) { - pic_throw(pic, pic->sREAD, msg, pic_nil_value()); + struct pic_error *e; + + e = pic_make_error(pic, pic->sREAD, msg, pic_nil_value()); + + pic_raise(pic, pic_obj_value(e)); } static int @@ -66,6 +62,7 @@ isdelim(int c) return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ } +#if PIC_ENABLE_FLOAT static bool strcaseeq(const char *s1, const char *s2) { @@ -77,31 +74,33 @@ strcaseeq(const char *s1, const char *s2) } return a == b; } +#endif + +static int +case_fold(pic_state *pic, int c) +{ + if (pic->reader->typecase == PIC_CASE_FOLD) { + c = tolower(c); + } + return c; +} static pic_value -read_comment(pic_state *pic, struct pic_port *port, const char *str) +read_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int c) { - int c; - - PIC_UNUSED(pic); - PIC_UNUSED(str); - do { c = next(port); } while (! (c == EOF || c == '\n')); - return pic_undef_value(); + return pic_invalid_value(); } static pic_value -read_block_comment(pic_state *pic, struct pic_port *port, const char *str) +read_block_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int PIC_UNUSED(c)) { int x, y; int i = 1; - PIC_UNUSED(pic); - PIC_UNUSED(str); - y = next(port); while (y != EOF && i > 0) { @@ -115,201 +114,223 @@ read_block_comment(pic_state *pic, struct pic_port *port, const char *str) } } - return pic_undef_value(); + return pic_invalid_value(); } static pic_value -read_datum_comment(pic_state *pic, struct pic_port *port, const char *str) +read_datum_comment(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { - PIC_UNUSED(str); - read(pic, port, next(port)); - return pic_undef_value(); + return pic_invalid_value(); } static pic_value -read_directive(pic_state *pic, struct pic_port *port, const char *str) +read_directive(pic_state *pic, struct pic_port *port, int c) { switch (peek(port)) { case 'n': if (expect(port, "no-fold-case")) { pic->reader->typecase = PIC_CASE_DEFAULT; - return pic_undef_value(); + return pic_invalid_value(); } break; case 'f': if (expect(port, "fold-case")) { pic->reader->typecase = PIC_CASE_FOLD; - return pic_undef_value(); + return pic_invalid_value(); } break; } - return read_comment(pic, port, str); + return read_comment(pic, port, c); } static pic_value -read_eval(pic_state *pic, struct pic_port *port, const char *str) +read_eval(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { pic_value form; - PIC_UNUSED(str); - form = read(pic, port, next(port)); return pic_eval(pic, form, pic->lib); } static pic_value -read_quote(pic_state *pic, struct pic_port *port, const char *str) +read_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { - PIC_UNUSED(str); - - return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port))); + return pic_list2(pic, pic_obj_value(pic->sQUOTE), read(pic, port, next(port))); } static pic_value -read_quasiquote(pic_state *pic, struct pic_port *port, const char *str) +read_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { - PIC_UNUSED(str); - - return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port))); + return pic_list2(pic, pic_obj_value(pic->sQUASIQUOTE), read(pic, port, next(port))); } static pic_value -read_unquote(pic_state *pic, struct pic_port *port, const char *str) +read_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { - PIC_UNUSED(str); + pic_sym *tag = pic->sUNQUOTE; - return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, next(port))); -} - -static pic_value -read_unquote_splicing(pic_state *pic, struct pic_port *port, const char *str) -{ - PIC_UNUSED(str); - - return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port))); -} - -static pic_value -read_symbol(pic_state *pic, struct pic_port *port, const char *str) -{ - size_t len, i; - char *buf; - pic_sym sym; - int c; - - len = strlen(str); - buf = pic_calloc(pic, 1, len + 1); - - for (i = 0; i < len; ++i) { - if (pic->reader->typecase == PIC_CASE_FOLD) { - buf[i] = (char)tolower(str[i]); - } else { - buf[i] = str[i]; - } + if (peek(port) == '@') { + tag = pic->sUNQUOTE_SPLICING; + next(port); } + return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port))); +} + +static pic_value +read_symbol(pic_state *pic, struct pic_port *port, int c) +{ + size_t len; + char *buf; + pic_sym *sym; + + len = 1; + buf = pic_malloc(pic, len + 1); + buf[0] = case_fold(pic, c); + buf[1] = 0; while (! isdelim(peek(port))) { c = next(port); - if (pic->reader->typecase == PIC_CASE_FOLD) { - c = tolower(c); - } len += 1; buf = pic_realloc(pic, buf, len + 1); - buf[len - 1] = (char)c; + buf[len - 1] = case_fold(pic, c); + buf[len] = 0; } - sym = pic_intern(pic, buf, len); + sym = pic_intern_cstr(pic, buf); pic_free(pic, buf); - return pic_sym_value(sym); + return pic_obj_value(sym); } -static size_t -read_uinteger(pic_state *pic, struct pic_port *port, int c, char buf[]) +static unsigned +read_uinteger(pic_state *pic, struct pic_port *port, int c) { - size_t i = 0; + unsigned u = 0; if (! isdigit(c)) { read_error(pic, "expected one or more digits"); } - buf[i++] = (char)c; + u = c - '0'; while (isdigit(c = peek(port))) { - buf[i++] = (char)next(port); + u = u * 10 + next(port) - '0'; } - buf[i] = '\0'; - - return i; + return u; } -static size_t -read_suffix(pic_state *pic, struct pic_port *port, char buf[]) +static int +read_suffix(pic_state *pic, struct pic_port *port) { - size_t i = 0; - int c; + int c, s = 1; c = peek(port); if (c != 'e' && c != 'E') { - return i; + return 0; } - buf[i++] = (char)next(port); + next(port); switch ((c = next(port))) { case '-': + s = -1; case '+': - buf[i++] = (char)c; c = next(port); default: - return i + read_uinteger(pic, port, c, buf + i); + return s * read_uinteger(pic, port, c); } } static pic_value read_unsigned(pic_state *pic, struct pic_port *port, int c) { - char buf[256]; - size_t i; + unsigned u; + int exp, s, i, e; +#if PIC_ENABLE_FLOAT + double f, g; +#endif - i = read_uinteger(pic, port, c, buf); + u = read_uinteger(pic, port, c); switch (peek(port)) { +#if PIC_ENABLE_FLOAT case '.': - buf[i++] = (char)next(port); - i += read_uinteger(pic, port, next(port), buf + i); - read_suffix(pic, port, buf + i); - return pic_float_value(atof(buf)); + next(port); + g = 0, e = 0; + while (isdigit(c = peek(port))) { + g = g * 10 + (next(port) - '0'); + e++; + } + f = u + g * pow(10, -e); + + exp = read_suffix(pic, port); + if (exp >= 0) { + s = 0; + } else { + exp = -exp; + s = 1; + } + + e = 10; + for (i = 0; exp; ++i) { + if ((exp & 1) != 0) { + f = s ? f / e : (f * e); + } + e *= e; + exp >>= 1; + } + return pic_float_value(f); +#endif default: - read_suffix(pic, port, buf + i); - return pic_int_value((int)(atof(buf))); + exp = read_suffix(pic, port); + if (exp >= 0) { + s = 0; + } else { + exp = -exp; + s = 1; + } + + e = 10; + for (i = 0; exp; ++i) { + if ((exp & 1) != 0) { + u = s ? u / e : (u * e); + } + e *= e; + exp >>= 1; + } + + return pic_int_value(u); } } static pic_value -read_number(pic_state *pic, struct pic_port *port, const char *str) +read_number(pic_state *pic, struct pic_port *port, int c) { - return read_unsigned(pic, port, str[0]); + return read_unsigned(pic, port, c); } static pic_value negate(pic_value n) { +#if PIC_ENABLE_FLOAT if (pic_int_p(n)) { return pic_int_value(-pic_int(n)); } else { return pic_float_value(-pic_float(n)); } +#else + return pic_int_value(-pic_int(n)); +#endif } static pic_value -read_minus(pic_state *pic, struct pic_port *port, const char *str) +read_minus(pic_state *pic, struct pic_port *port, int c) { pic_value sym; @@ -317,19 +338,21 @@ read_minus(pic_state *pic, struct pic_port *port, const char *str) return negate(read_unsigned(pic, port, next(port))); } else { - sym = read_symbol(pic, port, str); - if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-inf.0")) { + sym = read_symbol(pic, port, c); +#if PIC_ENABLE_FLOAT + if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-inf.0")) { return pic_float_value(-INFINITY); } - if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-nan.0")) { + if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) { return pic_float_value(-NAN); } +#endif return sym; } } static pic_value -read_plus(pic_state *pic, struct pic_port *port, const char *str) +read_plus(pic_state *pic, struct pic_port *port, int c) { pic_value sym; @@ -337,44 +360,50 @@ read_plus(pic_state *pic, struct pic_port *port, const char *str) return read_unsigned(pic, port, next(port)); } else { - sym = read_symbol(pic, port, str); - if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+inf.0")) { + sym = read_symbol(pic, port, c); +#if PIC_ENABLE_FLOAT + if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+inf.0")) { return pic_float_value(INFINITY); } - if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+nan.0")) { + if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) { return pic_float_value(NAN); } +#endif return sym; } } static pic_value -read_true(pic_state *pic, struct pic_port *port, const char *str) +read_true(pic_state *pic, struct pic_port *port, int c) { - PIC_UNUSED(pic); - PIC_UNUSED(port); - PIC_UNUSED(str); + if ((c = peek(port)) == 'r') { + if (! expect(port, "rue")) { + read_error(pic, "unexpected character while reading #true"); + } + } else if (! isdelim(c)) { + read_error(pic, "non-delimiter character given after #t"); + } return pic_true_value(); } static pic_value -read_false(pic_state *pic, struct pic_port *port, const char *str) +read_false(pic_state *pic, struct pic_port *port, int c) { - PIC_UNUSED(pic); - PIC_UNUSED(port); - PIC_UNUSED(str); + if ((c = peek(port)) == 'a') { + if (! expect(port, "alse")) { + read_error(pic, "unexpected character while reading #false"); + } + } else if (! isdelim(c)) { + read_error(pic, "non-delimiter character given after #f"); + } return pic_false_value(); } static pic_value -read_char(pic_state *pic, struct pic_port *port, const char *str) +read_char(pic_state *pic, struct pic_port *port, int c) { - int c; - - PIC_UNUSED(str); - c = next(port); if (! isdelim(peek(port))) { @@ -408,17 +437,14 @@ read_char(pic_state *pic, struct pic_port *port, const char *str) } static pic_value -read_string(pic_state *pic, struct pic_port *port, const char *name) +read_string(pic_state *pic, struct pic_port *port, int c) { - int c; char *buf; size_t size, cnt; pic_str *str; - PIC_UNUSED(name); - size = 256; - buf = pic_alloc(pic, size); + buf = pic_malloc(pic, size); cnt = 0; /* TODO: intraline whitespaces */ @@ -446,20 +472,17 @@ read_string(pic_state *pic, struct pic_port *port, const char *name) } static pic_value -read_pipe(pic_state *pic, struct pic_port *port, const char *str) +read_pipe(pic_state *pic, struct pic_port *port, int c) { char *buf; size_t size, cnt; - pic_sym sym; + pic_sym *sym; /* Currently supports only ascii chars */ char HEX_BUF[3]; size_t i = 0; - int c; - - PIC_UNUSED(str); size = 256; - buf = pic_alloc(pic, size); + buf = pic_malloc(pic, size); cnt = 0; while ((c = next(port)) != '|') { if (c == '\\') { @@ -489,20 +512,17 @@ read_pipe(pic_state *pic, struct pic_port *port, const char *str) sym = pic_intern_cstr(pic, buf); pic_free(pic, buf); - return pic_sym_value(sym); + return pic_obj_value(sym); } static pic_value -read_blob(pic_state *pic, struct pic_port *port, const char *str) +read_blob(pic_state *pic, struct pic_port *port, int c) { - int nbits, n, c; + int nbits, n; size_t len, i; - char buf[256]; unsigned char *dat; pic_blob *blob; - PIC_UNUSED(str); - nbits = 0; while (isdigit(c = next(port))) { @@ -521,8 +541,7 @@ read_blob(pic_state *pic, struct pic_port *port, const char *str) dat = NULL; c = next(port); while ((c = skip(port, c)) != ')') { - read_uinteger(pic, port, c, buf); - n = atoi(buf); + n = read_uinteger(pic, port, c); if (n < 0 || (1 << nbits) <= n) { read_error(pic, "invalid element in bytevector literal"); } @@ -542,11 +561,25 @@ read_blob(pic_state *pic, struct pic_port *port, const char *str) } static pic_value -read_pair(pic_state *pic, struct pic_port *port, const char *str) +read_undef_or_blob(pic_state *pic, struct pic_port *port, int c) { - const int tCLOSE = (str[0] == '(') ? ')' : ']'; + if ((c = peek(port)) == 'n') { + if (! expect(port, "ndefined")) { + read_error(pic, "unexpected character while reading #undefined"); + } + return pic_undef_value(); + } + if (! isdigit(c)) { + read_error(pic, "expect #undefined or #u8(...), but illegal character given"); + } + return read_blob(pic, port, 'u'); +} + +static pic_value +read_pair(pic_state *pic, struct pic_port *port, int c) +{ + static const int tCLOSE = ')'; pic_value car, cdr; - int c; retry: @@ -560,7 +593,7 @@ read_pair(pic_state *pic, struct pic_port *port, const char *str) closing: if ((c = skip(port, ' ')) != tCLOSE) { - if (pic_undef_p(read_nullable(pic, port, c))) { + if (pic_invalid_p(read_nullable(pic, port, c))) { goto closing; } read_error(pic, "unmatched parenthesis"); @@ -570,21 +603,21 @@ read_pair(pic_state *pic, struct pic_port *port, const char *str) else { car = read_nullable(pic, port, c); - if (pic_undef_p(car)) { + if (pic_invalid_p(car)) { goto retry; } - cdr = read_pair(pic, port, str); + cdr = read_pair(pic, port, '('); return pic_cons(pic, car, cdr); } } static pic_value -read_vector(pic_state *pic, struct pic_port *port, const char *str) +read_vector(pic_state *pic, struct pic_port *port, int c) { pic_value list; - list = read(pic, port, str[1]); + list = read(pic, port, c); return pic_obj_value(pic_make_vec_from_list(pic, list)); } @@ -596,11 +629,11 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) int c; switch ((c = skip(port, ' '))) { - case '(': case '[': + case '(': { pic_value tmp; - val = pic_cons(pic, pic_none_value(), pic_none_value()); + val = pic_cons(pic, pic_undef_value(), pic_undef_value()); xh_put_int(&pic->reader->labels, i, &val); @@ -648,12 +681,10 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) } static pic_value -read_label_ref(pic_state *pic, struct pic_port *port, int i) +read_label_ref(pic_state *pic, struct pic_port PIC_UNUSED(*port), int i) { xh_entry *e; - PIC_UNUSED(port); - e = xh_get_int(&pic->reader->labels, i); if (! e) { read_error(pic, "label of given index not defined"); @@ -662,14 +693,13 @@ read_label_ref(pic_state *pic, struct pic_port *port, int i) } static pic_value -read_label(pic_state *pic, struct pic_port *port, const char *str) +read_label(pic_state *pic, struct pic_port *port, int c) { - int i, c; + int i; i = 0; - c = str[1]; /* initial index letter */ do { - i = i * 10 + c; + i = i * 10 + c - '0'; } while (isdigit(c = next(port))); if (c == '=') { @@ -682,54 +712,41 @@ read_label(pic_state *pic, struct pic_port *port, const char *str) } static pic_value -read_unmatch(pic_state *pic, struct pic_port *port, const char *str) +read_unmatch(pic_state *pic, struct pic_port PIC_UNUSED(*port), int PIC_UNUSED(c)) { - PIC_UNUSED(port); - PIC_UNUSED(str); - read_error(pic, "unmatched parenthesis"); } +static pic_value +read_dispatch(pic_state *pic, struct pic_port *port, int c) +{ + c = next(port); + + if (c == EOF) { + read_error(pic, "unexpected EOF"); + } + + if (pic->reader->dispatch[c] == NULL) { + read_error(pic, "invalid character at the seeker head"); + } + + return pic->reader->dispatch[c](pic, port, c); +} + static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c) { - struct pic_trie *trie = pic->reader->trie; - char buf[128]; - size_t i = 0; - pic_str *str; - c = skip(port, c); if (c == EOF) { read_error(pic, "unexpected EOF"); } - if (trie->table[c] == NULL) { + if (pic->reader->table[c] == NULL) { read_error(pic, "invalid character at the seeker head"); } - buf[i++] = (char)c; - - while (i < sizeof buf) { - trie = trie->table[c]; - - if ((c = peek(port)) == EOF) { - break; - } - if (trie->table[c] == NULL) { - break; - } - buf[i++] = (char)next(port); - } - if (i == sizeof buf) { - read_error(pic, "too long dispatch string"); - } - - if (trie->proc == NULL) { - read_error(pic, "no reader registered for current string"); - } - str = pic_make_str(pic, buf, i); - return pic_apply2(pic, trie->proc, pic_obj_value(port), pic_obj_value(str)); + return pic->reader->table[c](pic, port, c); } static pic_value @@ -740,7 +757,7 @@ read(pic_state *pic, struct pic_port *port, int c) retry: val = read_nullable(pic, port, c); - if (pic_undef_p(val)) { + if (pic_invalid_p(val)) { c = next(port); goto retry; } @@ -748,137 +765,79 @@ read(pic_state *pic, struct pic_port *port, int c) return val; } -struct pic_trie * -pic_make_trie(pic_state *pic) +static void +reader_table_init(struct pic_reader *reader) { - struct pic_trie *trie; - - trie = pic_alloc(pic, sizeof(struct pic_trie)); - trie->proc = NULL; - memset(trie->table, 0, sizeof trie->table); - - return trie; -} - -void -pic_trie_delete(pic_state *pic, struct pic_trie *trie) -{ - size_t i; - - for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) { - if (trie->table[i] != NULL) { - pic_trie_delete(pic, trie->table[i]); - } - } - - pic_free(pic, trie); -} - -void -pic_define_reader(pic_state *pic, const char *str, pic_func_t reader) -{ - struct pic_trie *trie = pic->reader->trie; int c; - while ((c = *str++)) { - if (trie->table[c] == NULL) { - trie->table[c] = pic_make_trie(pic); - } - trie = trie->table[c]; - } - trie->proc = pic_make_proc(pic, reader, "reader"); -} + reader->table[0] = NULL; -#define DEFINE_READER(name) \ - static pic_value \ - pic_##name(pic_state *pic) \ - { \ - struct pic_port *port; \ - const char *str; \ - \ - pic_get_args(pic, "pz", &port, &str); \ - \ - return name(pic, port, str); \ + /* default reader */ + for (c = 1; c < 256; ++c) { + reader->table[c] = read_symbol; } -DEFINE_READER(read_unmatch) -DEFINE_READER(read_comment) -DEFINE_READER(read_quote) -DEFINE_READER(read_quasiquote) -DEFINE_READER(read_unquote) -DEFINE_READER(read_unquote_splicing) -DEFINE_READER(read_string) -DEFINE_READER(read_pipe) -DEFINE_READER(read_plus) -DEFINE_READER(read_minus) -DEFINE_READER(read_pair) -DEFINE_READER(read_directive) -DEFINE_READER(read_block_comment) -DEFINE_READER(read_datum_comment) -DEFINE_READER(read_true) -DEFINE_READER(read_false) -DEFINE_READER(read_char) -DEFINE_READER(read_vector) -DEFINE_READER(read_blob) -DEFINE_READER(read_eval) -DEFINE_READER(read_symbol) -DEFINE_READER(read_number) -DEFINE_READER(read_label) - -void -pic_init_reader(pic_state *pic) -{ - static const char INIT[] = "!$%&*./:<=>?@^_~"; - char buf[3] = { 0 }; - size_t i; - - pic_define_reader(pic, ")", pic_read_unmatch); - pic_define_reader(pic, ";", pic_read_comment); - pic_define_reader(pic, "'", pic_read_quote); - pic_define_reader(pic, "`", pic_read_quasiquote); - pic_define_reader(pic, ",", pic_read_unquote); - pic_define_reader(pic, ",@", pic_read_unquote_splicing); - pic_define_reader(pic, "\"", pic_read_string); - pic_define_reader(pic, "|", pic_read_pipe); - pic_define_reader(pic, "+", pic_read_plus); - pic_define_reader(pic, "-", pic_read_minus); - pic_define_reader(pic, "(", pic_read_pair); - pic_define_reader(pic, "[", pic_read_pair); - - pic_define_reader(pic, "#!", pic_read_directive); - pic_define_reader(pic, "#|", pic_read_block_comment); - pic_define_reader(pic, "#;", pic_read_datum_comment); - pic_define_reader(pic, "#t", pic_read_true); - pic_define_reader(pic, "#true", pic_read_true); - pic_define_reader(pic, "#f", pic_read_false); - pic_define_reader(pic, "#false", pic_read_false); - pic_define_reader(pic, "#\\", pic_read_char); - pic_define_reader(pic, "#(", pic_read_vector); - pic_define_reader(pic, "#u", pic_read_blob); - pic_define_reader(pic, "#.", pic_read_eval); + reader->table[')'] = read_unmatch; + reader->table[';'] = read_comment; + reader->table['\''] = read_quote; + reader->table['`'] = read_quasiquote; + reader->table[','] = read_unquote; + reader->table['"'] = read_string; + reader->table['|'] = read_pipe; + reader->table['+'] = read_plus; + reader->table['-'] = read_minus; + reader->table['('] = read_pair; + reader->table['#'] = read_dispatch; /* read number */ - for (buf[0] = '0'; buf[0] <= '9'; ++buf[0]) { - pic_define_reader(pic, buf, pic_read_number); + for (c = '0'; c <= '9'; ++c) { + reader->table[c] = read_number; } - /* read symbol */ - for (buf[0] = 'a'; buf[0] <= 'z'; ++buf[0]) { - pic_define_reader(pic, buf, pic_read_symbol); + reader->dispatch['!'] = read_directive; + reader->dispatch['|'] = read_block_comment; + reader->dispatch[';'] = read_datum_comment; + reader->dispatch['t'] = read_true; + reader->dispatch['f'] = read_false; + reader->dispatch['\\'] = read_char; + reader->dispatch['('] = read_vector; + reader->dispatch['u'] = read_undef_or_blob; + reader->dispatch['.'] = read_eval; + + /* read labels */ + for (c = '0'; c <= '9'; ++c) { + reader->dispatch[c] = read_label; } - for (buf[0] = 'A'; buf[0] <= 'Z'; ++buf[0]) { - pic_define_reader(pic, buf, pic_read_symbol); - } - for (i = 0; i < sizeof INIT; ++i) { - buf[0] = INIT[i]; - pic_define_reader(pic, buf, pic_read_symbol); +} + +struct pic_reader * +pic_reader_open(pic_state *pic) +{ + struct pic_reader *reader; + int c; + + reader = pic_malloc(pic, sizeof(struct pic_reader)); + reader->typecase = PIC_CASE_DEFAULT; + xh_init_int(&reader->labels, sizeof(pic_value)); + + for (c = 0; c < 256; ++c) { + reader->table[c] = NULL; } - /* read label */ - buf[0] = '#'; - for (buf[1] = '0'; buf[1] <= '9'; ++buf[1]) { - pic_define_reader(pic, buf, pic_read_label); + for (c = 0; c < 256; ++c) { + reader->dispatch[c] = NULL; } + + reader_table_init(reader); + + return reader; +} + +void +pic_reader_close(pic_state *pic, struct pic_reader *reader) +{ + xh_destroy(&reader->labels); + pic_free(pic, reader); } pic_value @@ -896,7 +855,7 @@ pic_read(pic_state *pic, struct pic_port *port) val = read_nullable(pic, port, c); - if (pic_undef_p(val)) { + if (pic_invalid_p(val)) { c = next(port); goto retry; } @@ -907,11 +866,14 @@ pic_read(pic_state *pic, struct pic_port *port) pic_value pic_read_cstr(pic_state *pic, const char *str) { - struct pic_port *port; + struct pic_port *port = pic_open_input_string(pic, str); + pic_value form; - port = pic_open_input_string(pic, str); + form = pic_read(pic, port); - return pic_read(pic, port); + pic_close_port(pic, port); + + return form; } static pic_value diff --git a/extlib/benz/record.c b/extlib/benz/record.c index 7ba4be29..55c98f14 100644 --- a/extlib/benz/record.c +++ b/extlib/benz/record.c @@ -3,15 +3,17 @@ */ #include "picrin.h" -#include "picrin/record.h" struct pic_record * pic_make_record(pic_state *pic, pic_value rectype) { struct pic_record *rec; + struct pic_dict *data; + + data = pic_make_dict(pic); rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD); - xh_init_int(&rec->hash, sizeof(pic_value)); + rec->data = data; pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype); @@ -25,23 +27,18 @@ pic_record_type(pic_state *pic, struct pic_record *rec) } pic_value -pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym slot) +pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym *slot) { - xh_entry *e; - - e = xh_get_int(&rec->hash, slot); - if (! e) { - pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_sym_value(slot), rec); + if (! pic_dict_has(pic, rec->data, slot)) { + pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_obj_value(slot), rec); } - return xh_val(e, pic_value); + return pic_dict_ref(pic, rec->data, slot); } void -pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym slot, pic_value val) +pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym *slot, pic_value val) { - PIC_UNUSED(pic); - - xh_put_int(&rec->hash, slot, &val); + pic_dict_set(pic, rec->data, slot, val); } static pic_value @@ -81,7 +78,7 @@ static pic_value pic_record_record_ref(pic_state *pic) { struct pic_record *rec; - pic_sym slot; + pic_sym *slot; pic_get_args(pic, "rm", &rec, &slot); @@ -92,14 +89,14 @@ static pic_value pic_record_record_set(pic_state *pic) { struct pic_record *rec; - pic_sym slot; + pic_sym *slot; pic_value val; pic_get_args(pic, "rmo", &rec, &slot, &val); pic_record_set(pic, rec, slot, val); - return pic_none_value(); + return pic_undef_value(); } void diff --git a/extlib/benz/reg.c b/extlib/benz/reg.c new file mode 100644 index 00000000..b23da584 --- /dev/null +++ b/extlib/benz/reg.c @@ -0,0 +1,121 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" + +struct pic_reg * +pic_make_reg(pic_state *pic) +{ + struct pic_reg *reg; + + reg = (struct pic_reg *)pic_obj_alloc(pic, sizeof(struct pic_reg), PIC_TT_REG); + reg->prev = NULL; + xh_init_ptr(®->hash, sizeof(pic_value)); + + return reg; +} + +pic_value +pic_reg_ref(pic_state *pic, struct pic_reg *reg, void *key) +{ + xh_entry *e; + + e = xh_get_ptr(®->hash, key); + if (! e) { + pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key)); + } + return xh_val(e, pic_value); +} + +void +pic_reg_set(pic_state PIC_UNUSED(*pic), struct pic_reg *reg, void *key, pic_value val) +{ + xh_put_ptr(®->hash, key, &val); +} + +bool +pic_reg_has(pic_state PIC_UNUSED(*pic), struct pic_reg *reg, void *key) +{ + return xh_get_ptr(®->hash, key) != NULL; +} + +void +pic_reg_del(pic_state *pic, struct pic_reg *reg, void *key) +{ + if (xh_get_ptr(®->hash, key) == NULL) { + pic_errorf(pic, "no slot named ~s found in registry", pic_obj_value(key)); + } + + xh_del_ptr(®->hash, key); +} + + +static pic_value +reg_get(pic_state *pic, struct pic_reg *reg, void *key) +{ + if (! pic_reg_has(pic, reg, key)) { + return pic_undef_value(); + } + return pic_reg_ref(pic, reg, key); +} + +static pic_value +reg_set(pic_state *pic, struct pic_reg *reg, void *key, pic_value val) +{ + if (pic_undef_p(val)) { + if (pic_reg_has(pic, reg, key)) { + pic_reg_del(pic, reg, key); + } + } else { + pic_reg_set(pic, reg, key, val); + } + + return pic_undef_value(); +} + +static pic_value +reg_call(pic_state *pic) +{ + struct pic_proc *self = pic_get_proc(pic); + struct pic_reg *reg; + pic_value key, val; + int n; + + n = pic_get_args(pic, "o|o", &key, &val); + + if (! pic_obj_p(key)) { + pic_errorf(pic, "attempted to set a non-object key '~s' in a registory", key); + } + + reg = pic_reg_ptr(pic_proc_env_ref(pic, self, "reg")); + + if (n == 1) { + return reg_get(pic, reg, pic_obj_ptr(key)); + } else { + return reg_set(pic, reg, pic_obj_ptr(key), val); + } +} + +static pic_value +pic_reg_make_registry(pic_state *pic) +{ + struct pic_reg *reg; + struct pic_proc *proc; + + pic_get_args(pic, ""); + + reg = pic_make_reg(pic); + + proc = pic_make_proc(pic, reg_call, ""); + + pic_proc_env_set(pic, proc, "reg", pic_obj_value(reg)); + + return pic_obj_value(proc); +} + +void +pic_init_reg(pic_state *pic) +{ + pic_defun(pic, "make-registry", pic_reg_make_registry); +} diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 3f32e1c5..0caa2a6b 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -3,18 +3,146 @@ */ #include "picrin.h" -#include "picrin/gc.h" -#include "picrin/read.h" -#include "picrin/proc.h" -#include "picrin/macro.h" -#include "picrin/cont.h" -#include "picrin/port.h" -#include "picrin/error.h" -void pic_init_core(pic_state *); +void +pic_add_feature(pic_state *pic, const char *feature) +{ + pic_push(pic, pic_obj_value(pic_intern_cstr(pic, feature)), pic->features); +} + +void pic_init_undef(pic_state *); +void pic_init_bool(pic_state *); +void pic_init_pair(pic_state *); +void pic_init_port(pic_state *); +void pic_init_number(pic_state *); +void pic_init_proc(pic_state *); +void pic_init_symbol(pic_state *); +void pic_init_vector(pic_state *); +void pic_init_blob(pic_state *); +void pic_init_cont(pic_state *); +void pic_init_char(pic_state *); +void pic_init_error(pic_state *); +void pic_init_str(pic_state *); +void pic_init_macro(pic_state *); +void pic_init_var(pic_state *); +void pic_init_write(pic_state *); +void pic_init_read(pic_state *); +void pic_init_dict(pic_state *); +void pic_init_record(pic_state *); +void pic_init_eval(pic_state *); +void pic_init_lib(pic_state *); +void pic_init_attr(pic_state *); +void pic_init_reg(pic_state *); + +extern const char pic_boot[][80]; + +static void +pic_init_features(pic_state *pic) +{ + pic_add_feature(pic, "picrin"); + pic_add_feature(pic, "ieee-float"); + +#if _POSIX_SOURCE + pic_add_feature(pic, "posix"); +#endif + +#if _WIN32 + pic_add_feature(pic, "windows"); +#endif + +#if __unix__ + pic_add_feature(pic, "unix"); +#endif +#if __gnu_linux__ + pic_add_feature(pic, "gnu-linux"); +#endif +#if __FreeBSD__ + pic_add_feature(pic, "freebsd"); +#endif + +#if __i386__ + pic_add_feature(pic, "i386"); +#elif __x86_64__ + pic_add_feature(pic, "x86-64"); +#elif __ppc__ + pic_add_feature(pic, "ppc"); +#elif __sparc__ + pic_add_feature(pic, "sparc"); +#endif + +#if __ILP32__ + pic_add_feature(pic, "ilp32"); +#elif __LP64__ + pic_add_feature(pic, "lp64"); +#endif + +#if defined(__BYTE_ORDER__) +# if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + pic_add_feature(pic, "little-endian"); +# elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ + pic_add_feature(pic, "big-endian"); +# endif +#else +# if __LITTLE_ENDIAN__ + pic_add_feature(pic, "little-endian"); +# elif __BIG_ENDIAN__ + pic_add_feature(pic, "big-endian"); +# endif +#endif +} + +#define DONE pic_gc_arena_restore(pic, ai); + +static void +pic_init_core(pic_state *pic) +{ + void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *); + + pic_init_features(pic); + + pic_deflibrary (pic, "(picrin base)") { + size_t ai = pic_gc_arena_preserve(pic); + + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); + + pic_init_undef(pic); DONE; + pic_init_bool(pic); DONE; + pic_init_pair(pic); DONE; + pic_init_port(pic); DONE; + pic_init_number(pic); DONE; + pic_init_proc(pic); DONE; + pic_init_symbol(pic); DONE; + pic_init_vector(pic); DONE; + pic_init_blob(pic); DONE; + pic_init_cont(pic); DONE; + pic_init_char(pic); DONE; + pic_init_error(pic); DONE; + pic_init_str(pic); DONE; + pic_init_macro(pic); DONE; + pic_init_var(pic); DONE; + pic_init_write(pic); DONE; + pic_init_read(pic); DONE; + pic_init_dict(pic); DONE; + pic_init_record(pic); DONE; + pic_init_eval(pic); DONE; + pic_init_lib(pic); DONE; + pic_init_attr(pic); DONE; + pic_init_reg(pic); DONE; + + pic_load_cstr(pic, &pic_boot[0][0]); + } + + pic_import_library(pic, pic->PICRIN_BASE); +} pic_state * -pic_open(int argc, char *argv[], char **envp) +pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) { struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short); char t; @@ -22,10 +150,23 @@ pic_open(int argc, char *argv[], char **envp) pic_state *pic; size_t ai; - pic = malloc(sizeof(pic_state)); + pic = allocf(NULL, sizeof(pic_state)); + + if (! pic) { + goto EXIT_PIC; + } + + /* allocator */ + pic->allocf = allocf; + + /* turn off GC */ + pic->gc_enable = false; + + /* jmp */ + pic->jmp = NULL; /* root block */ - pic->wind = NULL; + pic->cp = NULL; /* command line */ pic->argc = argc; @@ -33,34 +174,62 @@ pic_open(int argc, char *argv[], char **envp) pic->envp = envp; /* prepare VM stack */ - pic->stbase = pic->sp = calloc(PIC_STACK_SIZE, sizeof(pic_value)); + pic->stbase = pic->sp = allocf(NULL, PIC_STACK_SIZE * sizeof(pic_value)); pic->stend = pic->stbase + PIC_STACK_SIZE; + if (! pic->sp) { + goto EXIT_SP; + } + /* callinfo */ - pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo)); + pic->cibase = pic->ci = allocf(NULL, PIC_STACK_SIZE * sizeof(pic_callinfo)); pic->ciend = pic->cibase + PIC_STACK_SIZE; + if (! pic->ci) { + goto EXIT_CI; + } + /* exception handler */ - pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *)); + pic->xpbase = pic->xp = allocf(NULL, PIC_RESCUE_SIZE * sizeof(struct pic_proc *)); pic->xpend = pic->xpbase + PIC_RESCUE_SIZE; + if (! pic->xp) { + goto EXIT_XP; + } + + /* GC arena */ + pic->arena = allocf(NULL, PIC_ARENA_SIZE * sizeof(struct pic_object *)); + pic->arena_size = PIC_ARENA_SIZE; + pic->arena_idx = 0; + + if (! pic->arena) { + goto EXIT_ARENA; + } + + /* trampoline iseq */ + pic->iseq = allocf(NULL, 2 * sizeof(pic_code)); + + if (! pic->iseq) { + goto EXIT_ISEQ; + } + /* memory heap */ - pic->heap = pic_heap_open(); + pic->heap = pic_heap_open(pic); + + /* registries */ + pic->regs = NULL; /* symbol table */ - xh_init_str(&pic->syms, sizeof(pic_sym)); - xh_init_int(&pic->sym_names, sizeof(const char *)); - pic->sym_cnt = 0; - pic->uniq_sym_cnt = 0; + xh_init_str(&pic->syms, sizeof(pic_sym *)); /* global variables */ - xh_init_int(&pic->globals, sizeof(pic_value)); + pic->globals = NULL; /* macros */ - xh_init_int(&pic->macros, sizeof(struct pic_macro *)); + pic->macros = NULL; /* attributes */ - xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *)); + pic->attrs = NULL; /* features */ pic->features = pic_nil_value(); @@ -69,31 +238,24 @@ pic_open(int argc, char *argv[], char **envp) pic->libs = pic_nil_value(); pic->lib = NULL; - /* reader */ - pic->reader = malloc(sizeof(struct pic_reader)); - pic->reader->typecase = PIC_CASE_DEFAULT; - pic->reader->trie = pic_make_trie(pic); - xh_init_int(&pic->reader->labels, sizeof(pic_value)); - /* raised error object */ - pic->err = pic_undef_value(); + pic->err = pic_invalid_value(); /* standard ports */ pic->xSTDIN = NULL; pic->xSTDOUT = NULL; pic->xSTDERR = NULL; - /* GC arena */ - pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **)); - pic->arena_size = PIC_ARENA_SIZE; - pic->arena_idx = 0; + /* parameter table */ + pic->ptable = pic_nil_value(); /* native stack marker */ pic->native_stack_start = &t; + ai = pic_gc_arena_preserve(pic); + #define S(slot,name) pic->slot = pic_intern_cstr(pic, name); - ai = pic_gc_arena_preserve(pic); S(sDEFINE, "define"); S(sLAMBDA, "lambda"); S(sIF, "if"); @@ -107,7 +269,6 @@ pic_open(int argc, char *argv[], char **envp) S(sIMPORT, "import"); S(sEXPORT, "export"); S(sDEFINE_LIBRARY, "define-library"); - S(sIN_LIBRARY, "in-library"); S(sCOND_EXPAND, "cond-expand"); S(sAND, "and"); S(sOR, "or"); @@ -121,8 +282,8 @@ pic_open(int argc, char *argv[], char **envp) S(sCAR, "car"); S(sCDR, "cdr"); S(sNILP, "null?"); - S(sSYMBOL_P, "symbol?"); - S(sPAIR_P, "pair?"); + S(sSYMBOLP, "symbol?"); + S(sPAIRP, "pair?"); S(sADD, "+"); S(sSUB, "-"); S(sMUL, "*"); @@ -136,11 +297,19 @@ pic_open(int argc, char *argv[], char **envp) S(sNOT, "not"); S(sREAD, "read"); S(sFILE, "file"); + S(sCALL, "call"); + S(sTAILCALL, "tail-call"); + S(sGREF, "gref"); + S(sLREF, "lref"); + S(sCREF, "cref"); + S(sRETURN, "return"); + S(sCALL_WITH_VALUES, "call-with-values"); + S(sTAILCALL_WITH_VALUES, "tailcall-with-values"); + pic_gc_arena_restore(pic, ai); #define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); - ai = pic_gc_arena_preserve(pic); R(rDEFINE, "define"); R(rLAMBDA, "lambda"); R(rIF, "if"); @@ -151,45 +320,97 @@ pic_open(int argc, char *argv[], char **envp) R(rIMPORT, "import"); R(rEXPORT, "export"); R(rDEFINE_LIBRARY, "define-library"); - R(rIN_LIBRARY, "in-library"); R(rCOND_EXPAND, "cond-expand"); + R(rCONS, "cons"); + R(rCAR, "car"); + R(rCDR, "cdr"); + R(rNILP, "null?"); + R(rSYMBOLP, "symbol?"); + R(rPAIRP, "pair?"); + R(rADD, "+"); + R(rSUB, "-"); + R(rMUL, "*"); + R(rDIV, "/"); + R(rEQ, "="); + R(rLT, "<"); + R(rLE, "<="); + R(rGT, ">"); + R(rGE, ">="); + R(rNOT, "not"); + R(rVALUES, "values"); + R(rCALL_WITH_VALUES, "call-with-values"); pic_gc_arena_restore(pic, ai); + /* root tables */ + pic->globals = pic_make_dict(pic); + pic->macros = pic_make_dict(pic); + pic->attrs = pic_make_reg(pic); + /* root block */ - pic->wind = pic_alloc(pic, sizeof(struct pic_winder)); - pic->wind->prev = NULL; - pic->wind->depth = 0; - pic->wind->in = pic->wind->out = NULL; + pic->cp = pic_malloc(pic, sizeof(pic_checkpoint)); + pic->cp->prev = NULL; + pic->cp->depth = 0; + pic->cp->in = pic->cp->out = NULL; - /* init readers */ - pic_init_reader(pic); - - /* standard libraries */ - pic->PICRIN_BASE = pic_open_library(pic, pic_read_cstr(pic, "(picrin base)")); - pic->PICRIN_USER = pic_open_library(pic, pic_read_cstr(pic, "(picrin user)")); - pic->lib = pic->PICRIN_USER; + /* reader */ + pic->reader = pic_reader_open(pic); /* standard I/O */ pic->xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN); pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT); pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT); + /* parameter table */ + pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable); + + /* standard libraries */ + pic->PICRIN_BASE = pic_make_library(pic, pic_read_cstr(pic, "(picrin base)")); + pic->PICRIN_USER = pic_make_library(pic, pic_read_cstr(pic, "(picrin user)")); + pic->lib = pic->PICRIN_USER; + pic->prev_lib = NULL; + + pic_gc_arena_restore(pic, ai); + + /* turn on GC */ + pic->gc_enable = true; + pic_init_core(pic); + pic_gc_arena_restore(pic, ai); + return pic; + + EXIT_ISEQ: + allocf(pic->arena, 0); + EXIT_ARENA: + allocf(pic->xp, 0); + EXIT_XP: + allocf(pic->ci, 0); + EXIT_CI: + allocf(pic->sp, 0); + EXIT_SP: + allocf(pic, 0); + EXIT_PIC: + return NULL; } void pic_close(pic_state *pic) { xh_entry *it; + pic_allocf allocf = pic->allocf; /* invoke exit handlers */ - while (pic->wind) { - if (pic->wind->out) { - pic_apply0(pic, pic->wind->out); + while (pic->cp) { + if (pic->cp->out) { + pic_apply0(pic, pic->cp->out); } - pic->wind = pic->wind->prev; + pic->cp = pic->cp->prev; + } + + /* free symbol names */ + for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) { + allocf(xh_key(it, char *), 0); } /* clear out root objects */ @@ -197,10 +418,11 @@ pic_close(pic_state *pic) pic->ci = pic->cibase; pic->xp = pic->xpbase; pic->arena_idx = 0; - pic->err = pic_undef_value(); - xh_clear(&pic->globals); - xh_clear(&pic->macros); - xh_clear(&pic->attrs); + pic->err = pic_invalid_value(); + pic->globals = NULL; + pic->macros = NULL; + pic->attrs = NULL; + xh_clear(&pic->syms); pic->features = pic_nil_value(); pic->libs = pic_nil_value(); @@ -208,32 +430,24 @@ pic_close(pic_state *pic) pic_gc_run(pic); /* free heaps */ - pic_heap_close(pic->heap); - - /* free runtime context */ - free(pic->stbase); - free(pic->cibase); - free(pic->xpbase); + pic_heap_close(pic, pic->heap); /* free reader struct */ - xh_destroy(&pic->reader->labels); - pic_trie_delete(pic, pic->reader->trie); - free(pic->reader); + pic_reader_close(pic, pic->reader); + + /* free runtime context */ + allocf(pic->stbase, 0); + allocf(pic->cibase, 0); + allocf(pic->xpbase, 0); + + /* free trampoline iseq */ + allocf(pic->iseq, 0); /* free global stacks */ xh_destroy(&pic->syms); - xh_destroy(&pic->globals); - xh_destroy(&pic->macros); - xh_destroy(&pic->attrs); /* free GC arena */ - free(pic->arena); + allocf(pic->arena, 0); - /* free symbol names */ - for (it = xh_begin(&pic->sym_names); it != NULL; it = xh_next(it)) { - free(xh_val(it, char *)); - } - xh_destroy(&pic->sym_names); - - free(pic); + allocf(pic, 0); } diff --git a/extlib/benz/string.c b/extlib/benz/string.c index 43514b2d..1e1e083c 100644 --- a/extlib/benz/string.c +++ b/extlib/benz/string.c @@ -3,12 +3,87 @@ */ #include "picrin.h" -#include "picrin/string.h" -#include "picrin/pair.h" -#include "picrin/port.h" + +struct pic_chunk { + char *str; + int refcnt; + size_t len; + char buf[1]; +}; + +struct pic_rope { + int refcnt; + size_t weight; + struct pic_chunk *chunk; + size_t offset; + struct pic_rope *left, *right; +}; + +#define CHUNK_INCREF(c) do { \ + (c)->refcnt++; \ + } while (0) + +#define CHUNK_DECREF(c) do { \ + struct pic_chunk *c_ = (c); \ + if (! --c_->refcnt) { \ + if (c_->str != c_->buf) \ + pic_free(pic, c_->str); \ + pic_free(pic, c_); \ + } \ + } while (0) + +void +pic_rope_incref(pic_state PIC_UNUSED(*pic), struct pic_rope *x) { + x->refcnt++; +} + +void +pic_rope_decref(pic_state *pic, struct pic_rope *x) { + if (! --x->refcnt) { + if (x->chunk) { + CHUNK_DECREF(x->chunk); + pic_free(pic, x); + return; + } + pic_rope_decref(pic, x->left); + pic_rope_decref(pic, x->right); + pic_free(pic, x); + } +} + +static struct pic_chunk * +pic_make_chunk(pic_state *pic, const char *str, size_t len) +{ + struct pic_chunk *c; + + c = pic_malloc(pic, sizeof(struct pic_chunk) + len); + c->refcnt = 1; + c->str = c->buf; + c->len = len; + c->buf[len] = 0; + memcpy(c->buf, str, len); + + return c; +} + +static struct pic_rope * +pic_make_rope(pic_state *pic, struct pic_chunk *c) +{ + struct pic_rope *x; + + x = pic_malloc(pic, sizeof(struct pic_rope)); + x->refcnt = 1; + x->left = NULL; + x->right = NULL; + x->weight = c->len; + x->offset = 0; + x->chunk = c; /* delegate ownership */ + + return x; +} static pic_str * -make_str_rope(pic_state *pic, xrope *rope) +pic_make_string(pic_state *pic, struct pic_rope *rope) { pic_str *str; @@ -17,13 +92,146 @@ make_str_rope(pic_state *pic, xrope *rope) return str; } -pic_str * -pic_make_str(pic_state *pic, const char *imbed, size_t len) +static size_t +rope_len(struct pic_rope *x) { - if (imbed == NULL && len > 0) { + return x->weight; +} + +static char +rope_at(struct pic_rope *x, size_t i) +{ + while (i < x->weight) { + if (x->chunk) { + return x->chunk->str[x->offset + i]; + } + if (i < x->left->weight) { + x = x->left; + } else { + x = x->right; + i -= x->left->weight; + } + } + return -1; +} + +static struct pic_rope * +rope_cat(pic_state *pic, struct pic_rope *x, struct pic_rope *y) +{ + struct pic_rope *z; + + z = pic_malloc(pic, sizeof(struct pic_rope)); + z->refcnt = 1; + z->left = x; + z->right = y; + z->weight = x->weight + y->weight; + z->offset = 0; + z->chunk = NULL; + + pic_rope_incref(pic, x); + pic_rope_incref(pic, y); + + return z; +} + +static struct pic_rope * +rope_sub(pic_state *pic, struct pic_rope *x, size_t i, size_t j) +{ + assert(i <= j); + assert(j <= x->weight); + + if (i == 0 && x->weight == j) { + pic_rope_incref(pic, x); + return x; + } + + if (x->chunk) { + struct pic_rope *y; + + y = pic_malloc(pic, sizeof(struct pic_rope)); + y->refcnt = 1; + y->left = NULL; + y->right = NULL; + y->weight = j - i; + y->offset = x->offset + i; + y->chunk = x->chunk; + + CHUNK_INCREF(x->chunk); + + return y; + } + + if (j <= x->left->weight) { + return rope_sub(pic, x->left, i, j); + } + else if (x->left->weight <= i) { + return rope_sub(pic, x->right, i - x->left->weight, j - x->left->weight); + } + else { + struct pic_rope *r, *l; + + l = rope_sub(pic, x->left, i, x->left->weight); + r = rope_sub(pic, x->right, 0, j - x->left->weight); + x = rope_cat(pic, l, r); + + pic_rope_decref(pic, l); + pic_rope_decref(pic, r); + + return x; + } +} + +static void +flatten(pic_state *pic, struct pic_rope *x, struct pic_chunk *c, size_t offset) +{ + if (x->chunk) { + memcpy(c->str + offset, x->chunk->str + x->offset, x->weight); + CHUNK_DECREF(x->chunk); + + x->chunk = c; + x->offset = offset; + CHUNK_INCREF(c); + return; + } + flatten(pic, x->left, c, offset); + flatten(pic, x->right, c, offset + x->left->weight); + + pic_rope_decref(pic, x->left); + pic_rope_decref(pic, x->right); + x->left = x->right = NULL; + x->chunk = c; + x->offset = offset; + CHUNK_INCREF(c); +} + +static const char * +rope_cstr(pic_state *pic, struct pic_rope *x) +{ + struct pic_chunk *c; + + if (x->chunk && x->offset == 0 && x->weight == x->chunk->len) { + return x->chunk->str; /* reuse cached chunk */ + } + + c = pic_malloc(pic, sizeof(struct pic_chunk) + x->weight); + c->refcnt = 1; + c->len = x->weight; + c->str = c->buf; + c->str[c->len] = '\0'; + + flatten(pic, x, c, 0); + + CHUNK_DECREF(c); + return c->str; +} + +pic_str * +pic_make_str(pic_state *pic, const char *str, size_t len) +{ + if (str == NULL && len > 0) { pic_errorf(pic, "zero length specified against NULL ptr"); } - return make_str_rope(pic, xr_new_copy(imbed, len)); + return pic_make_string(pic, pic_make_rope(pic, pic_make_chunk(pic, str, len))); } pic_str * @@ -36,20 +244,25 @@ pic_str * pic_make_str_fill(pic_state *pic, size_t len, char fill) { size_t i; - char buf[len + 1]; + char *buf = pic_malloc(pic, len); + pic_str *str; for (i = 0; i < len; ++i) { buf[i] = fill; } buf[i] = '\0'; - return pic_make_str(pic, buf, len); + str = pic_make_str(pic, buf, len); + + pic_free(pic, buf); + + return str; } size_t -pic_strlen(pic_str *str) +pic_str_len(pic_str *str) { - return xr_len(str->rope); + return rope_len(str->rope); } char @@ -57,7 +270,7 @@ pic_str_ref(pic_state *pic, pic_str *str, size_t i) { int c; - c = xr_at(str->rope, i); + c = rope_at(str->rope, i); if (c == -1) { pic_errorf(pic, "index out of range %d", i); } @@ -65,27 +278,27 @@ pic_str_ref(pic_state *pic, pic_str *str, size_t i) } pic_str * -pic_strcat(pic_state *pic, pic_str *a, pic_str *b) +pic_str_cat(pic_state *pic, pic_str *a, pic_str *b) { - return make_str_rope(pic, xr_cat(a->rope, b->rope)); + return pic_make_string(pic, rope_cat(pic, a->rope, b->rope)); } pic_str * -pic_substr(pic_state *pic, pic_str *str, size_t s, size_t e) +pic_str_sub(pic_state *pic, pic_str *str, size_t s, size_t e) { - return make_str_rope(pic, xr_sub(str->rope, s, e)); + return pic_make_string(pic, rope_sub(pic, str->rope, s, e)); } int -pic_strcmp(pic_str *str1, pic_str *str2) +pic_str_cmp(pic_state *pic, pic_str *str1, pic_str *str2) { - return strcmp(xr_cstr(str1->rope), xr_cstr(str2->rope)); + return strcmp(pic_str_cstr(pic, str1), pic_str_cstr(pic, str2)); } const char * -pic_str_cstr(pic_str *str) +pic_str_cstr(pic_state *pic, pic_str *str) { - return xr_cstr(str->rope); + return rope_cstr(pic, str->rope); } pic_value @@ -122,9 +335,11 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) case 'p': xfprintf(file, "%p", va_arg(ap, void *)); break; +#if PIC_ENABLE_FLOAT case 'f': xfprintf(file, "%f", va_arg(ap, double)); break; +#endif } break; case '~': @@ -238,7 +453,7 @@ pic_str_string(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - buf = pic_alloc(pic, (size_t)argc); + buf = pic_malloc(pic, (size_t)argc); for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], char); @@ -269,7 +484,7 @@ pic_str_string_length(pic_state *pic) pic_get_args(pic, "s", &str); - return pic_size_value(pic_strlen(str)); + return pic_size_value(pic_str_len(str)); } static pic_value @@ -300,7 +515,7 @@ pic_str_string_ref(pic_state *pic) if (! pic_str_p(argv[i])) { \ return pic_false_value(); \ } \ - if (! (pic_strcmp(pic_str_ptr(argv[i-1]), pic_str_ptr(argv[i])) op 0)) { \ + if (! (pic_str_cmp(pic, pic_str_ptr(argv[i-1]), pic_str_ptr(argv[i])) op 0)) { \ return pic_false_value(); \ } \ } \ @@ -326,10 +541,10 @@ pic_str_string_copy(pic_state *pic) case 1: start = 0; case 2: - end = pic_strlen(str); + end = pic_str_len(str); } - return pic_obj_value(pic_substr(pic, str, start, end)); + return pic_obj_value(pic_str_sub(pic, str, start, end)); } static pic_value @@ -346,7 +561,7 @@ pic_str_string_append(pic_state *pic) if (! pic_str_p(argv[i])) { pic_errorf(pic, "type error"); } - str = pic_strcat(pic, str, pic_str_ptr(argv[i])); + str = pic_str_cat(pic, str, pic_str_ptr(argv[i])); } return pic_obj_value(str); } @@ -357,23 +572,27 @@ pic_str_string_map(pic_state *pic) struct pic_proc *proc; pic_value *argv, vals, val; size_t argc, i, len, j; + pic_str *str; + char *buf; pic_get_args(pic, "l*", &proc, &argc, &argv); - len = SIZE_MAX; - for (i = 0; i < argc; ++i) { + if (argc == 0) { + pic_errorf(pic, "string-map: one or more strings expected, but got zero"); + } else { + pic_assert_type(pic, argv[0], str); + len = pic_str_len(pic_str_ptr(argv[0])); + } + for (i = 1; i < argc; ++i) { pic_assert_type(pic, argv[i], str); - len = len < pic_strlen(pic_str_ptr(argv[i])) + len = len < pic_str_len(pic_str_ptr(argv[i])) ? len - : pic_strlen(pic_str_ptr(argv[i])); + : pic_str_len(pic_str_ptr(argv[i])); } - if (len == SIZE_MAX) { - pic_errorf(pic, "string-map: one or more strings expected, but got zero"); - } - else { - char buf[len]; + buf = pic_malloc(pic, len); + pic_try { for (i = 0; i < len; ++i) { vals = pic_nil_value(); for (j = 0; j < argc; ++j) { @@ -384,9 +603,16 @@ pic_str_string_map(pic_state *pic) pic_assert_type(pic, val, char); buf[i] = pic_char(val); } - - return pic_obj_value(pic_make_str(pic, buf, len)); + str = pic_make_str(pic, buf, len); } + pic_catch { + pic_free(pic, buf); + pic_raise(pic, pic->err); + } + + pic_free(pic, buf); + + return pic_obj_value(str); } static pic_value @@ -398,16 +624,18 @@ pic_str_string_for_each(pic_state *pic) pic_get_args(pic, "l*", &proc, &argc, &argv); - len = SIZE_MAX; - for (i = 0; i < argc; ++i) { + if (argc == 0) { + pic_errorf(pic, "string-map: one or more strings expected, but got zero"); + } else { + pic_assert_type(pic, argv[0], str); + len = pic_str_len(pic_str_ptr(argv[0])); + } + for (i = 1; i < argc; ++i) { pic_assert_type(pic, argv[i], str); - len = len < pic_strlen(pic_str_ptr(argv[i])) + len = len < pic_str_len(pic_str_ptr(argv[i])) ? len - : pic_strlen(pic_str_ptr(argv[i])); - } - if (len == SIZE_MAX) { - pic_errorf(pic, "string-map: one or more strings expected, but got zero"); + : pic_str_len(pic_str_ptr(argv[i])); } for (i = 0; i < len; ++i) { @@ -418,33 +646,41 @@ pic_str_string_for_each(pic_state *pic) pic_apply(pic, proc, vals); } - return pic_none_value(); + return pic_undef_value(); } static pic_value pic_str_list_to_string(pic_state *pic) { pic_str *str; - pic_value list, e; + pic_value list, e, it; size_t i = 0; + char *buf; pic_get_args(pic, "o", &list); if (pic_length(pic, list) == 0) { return pic_obj_value(pic_make_str(pic, NULL, 0)); - } else { - char buf[pic_length(pic, list)]; + } - pic_for_each (e, list) { + buf = pic_malloc(pic, pic_length(pic, list)); + + pic_try { + pic_for_each (e, list, it) { pic_assert_type(pic, e, char); buf[i++] = pic_char(e); } str = pic_make_str(pic, buf, i); - - return pic_obj_value(str); } + pic_catch { + pic_free(pic, buf); + pic_raise(pic, pic->err); + } + pic_free(pic, buf); + + return pic_obj_value(str); } static pic_value @@ -461,7 +697,7 @@ pic_str_string_to_list(pic_state *pic) case 1: start = 0; case 2: - end = pic_strlen(str); + end = pic_str_len(str); } list = pic_nil_value(); diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 3fd40f68..8298465d 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -3,92 +3,68 @@ */ #include "picrin.h" -#include "picrin/string.h" -pic_sym -pic_intern(pic_state *pic, const char *str, size_t len) +pic_sym * +pic_make_symbol(pic_state *pic, pic_str *str) { - char *cstr; - xh_entry *e; - pic_sym id; + pic_sym *sym; - cstr = (char *)pic_malloc(pic, len + 1); - cstr[len] = '\0'; - memcpy(cstr, str, len); - - e = xh_get_str(&pic->syms, cstr); - if (e) { - return xh_val(e, pic_sym); - } - - id = pic->sym_cnt++; - xh_put_str(&pic->syms, cstr, &id); - xh_put_int(&pic->sym_names, id, &cstr); - return id; + sym = (pic_sym *)pic_obj_alloc(pic, sizeof(struct pic_symbol), PIC_TT_SYMBOL); + sym->str = str; + return sym; } -pic_sym +pic_sym * +pic_intern(pic_state *pic, pic_str *str) +{ + xh_entry *e; + pic_sym *sym; + char *cstr; + + e = xh_get_str(&pic->syms, pic_str_cstr(pic, str)); + if (e) { + sym = xh_val(e, pic_sym *); + pic_gc_protect(pic, pic_obj_value(sym)); + return sym; + } + + cstr = pic_malloc(pic, pic_str_len(str) + 1); + strcpy(cstr, pic_str_cstr(pic, str)); + + sym = pic_make_symbol(pic, str); + xh_put_str(&pic->syms, cstr, &sym); + return sym; +} + +pic_sym * pic_intern_cstr(pic_state *pic, const char *str) { - return pic_intern(pic, str, strlen(str)); + return pic_intern(pic, pic_make_str(pic, str, strlen(str))); } -pic_sym -pic_intern_str(pic_state *pic, pic_str *str) +pic_sym * +pic_gensym(pic_state *pic, pic_sym *base) { - return pic_intern_cstr(pic, pic_str_cstr(str)); -} - -pic_sym -pic_gensym(pic_state *pic, pic_sym base) -{ - int uid = pic->uniq_sym_cnt++, len; - char *str, mark; - pic_sym uniq; - - if (pic_interned_p(pic, base)) { - mark = '@'; - } else { - mark = '.'; - } - - len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid); - str = pic_alloc(pic, (size_t)len + 1); - sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid); - - /* don't put the symbol to pic->syms to keep it uninterned */ - uniq = pic->sym_cnt++; - xh_put_int(&pic->sym_names, uniq, &str); - - return uniq; -} - -pic_sym -pic_ungensym(pic_state *pic, pic_sym base) -{ - const char *name, *occr; - - if (pic_interned_p(pic, base)) { - return base; - } - - name = pic_symbol_name(pic, base); - if ((occr = strrchr(name, '@')) == NULL) { - pic_panic(pic, "logic flaw"); - } - return pic_intern(pic, name, (size_t)(occr - name)); + return pic_make_symbol(pic, base->str); } bool -pic_interned_p(pic_state *pic, pic_sym sym) +pic_interned_p(pic_state *pic, pic_sym *sym) { - return sym == pic_intern_cstr(pic, pic_symbol_name(pic, sym)); + xh_entry *e; + + e = xh_get_str(&pic->syms, pic_str_cstr(pic, sym->str)); + if (e) { + return sym == xh_val(e, pic_sym *); + } else { + return false; + } } const char * -pic_symbol_name(pic_state *pic, pic_sym sym) +pic_symbol_name(pic_state *pic, pic_sym *sym) { - return xh_val(xh_get_int(&pic->sym_names, sym), const char *); + return pic_str_cstr(pic, sym->str); } static pic_value @@ -123,35 +99,30 @@ pic_symbol_symbol_eq_p(pic_state *pic) static pic_value pic_symbol_symbol_to_string(pic_state *pic) { - pic_value v; + pic_sym *sym; - pic_get_args(pic, "o", &v); + pic_get_args(pic, "m", &sym); - if (! pic_sym_p(v)) { - pic_errorf(pic, "symbol->string: expected symbol"); - } - - return pic_obj_value(pic_make_str_cstr(pic, pic_symbol_name(pic, pic_sym(v)))); + return pic_obj_value(sym->str); } static pic_value pic_symbol_string_to_symbol(pic_state *pic) { - pic_value v; + pic_str *str; - pic_get_args(pic, "o", &v); + pic_get_args(pic, "s", &str); - if (! pic_str_p(v)) { - pic_errorf(pic, "string->symbol: expected string"); - } - - return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v)))); + return pic_obj_value(pic_intern(pic, str)); } void pic_init_symbol(pic_state *pic) { - pic_defun(pic, "symbol?", pic_symbol_symbol_p); + void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); + + pic_defun_vm(pic, "symbol?", pic->rSYMBOLP, pic_symbol_symbol_p); + pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); diff --git a/extlib/benz/undef.c b/extlib/benz/undef.c new file mode 100644 index 00000000..9e709c0e --- /dev/null +++ b/extlib/benz/undef.c @@ -0,0 +1,21 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" + +static pic_value +pic_undef_undefined_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_undef_p(v) ? pic_true_value() : pic_false_value(); +} + +void +pic_init_undef(pic_state *pic) +{ + pic_defun(pic, "undefined?", pic_undef_undefined_p); +} diff --git a/extlib/benz/var.c b/extlib/benz/var.c index 7eb4e08a..5fd44c0b 100644 --- a/extlib/benz/var.c +++ b/extlib/benz/var.c @@ -3,77 +3,57 @@ */ #include "picrin.h" -#include "picrin/pair.h" -#include "picrin/proc.h" static pic_value -var_lookup(pic_state *pic, pic_value var) +var_conv(pic_state *pic, struct pic_proc *var, pic_value val) { - pic_value val, env, binding; - - val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment"); - if (pic_eq_p(val, var)) { - return pic_false_value(); + if (pic_proc_env_has(pic, var, "conv") != 0) { + return pic_apply1(pic, pic_proc_ptr(pic_proc_env_ref(pic, var, "conv")), val); } + return val; +} - env = pic_apply0(pic, pic_proc_ptr(val)); - while (! pic_nil_p(env)) { - binding = pic_car(pic, env); +static pic_value +var_get(pic_state *pic, struct pic_proc *var) +{ + pic_value elem, it; + struct pic_reg *reg; - while (! pic_nil_p(binding)) { - if (pic_eq_p(pic_caar(pic, binding), var)) { - return pic_car(pic, binding); - } - binding = pic_cdr(pic, binding); + pic_for_each (elem, pic->ptable, it) { + reg = pic_reg_ptr(elem); + if (pic_reg_has(pic, reg, var)) { + return pic_reg_ref(pic, reg, var); } - env = pic_cdr(pic, env); } + pic_panic(pic, "logic flaw"); +} - return pic_false_value(); +static pic_value +var_set(pic_state *pic, struct pic_proc *var, pic_value val) +{ + struct pic_reg *reg; + + reg = pic_reg_ptr(pic_car(pic, pic->ptable)); + + pic_reg_set(pic, reg, var, val); + + return pic_undef_value(); } static pic_value var_call(pic_state *pic) { struct pic_proc *self = pic_get_proc(pic); - pic_value val, tmp, box, conv; + pic_value val; int n; - n = pic_get_args(pic, "|oo", &val, &tmp); + n = pic_get_args(pic, "|o", &val); - box = var_lookup(pic, pic_obj_value(self)); - if (! pic_test(box)) { - box = pic_attr_ref(pic, pic_obj_value(self), "@@box"); + if (n == 0) { + return var_get(pic, self); + } else { + return var_set(pic, self, var_conv(pic, self, val)); } - - switch (n) { - case 0: - return pic_cdr(pic, box); - - case 1: - conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter"); - if (pic_test(conv)) { - pic_assert_type(pic, conv, proc); - - val = pic_apply1(pic, pic_proc_ptr(conv), val); - } - pic_set_cdr(pic, box, val); - - return pic_none_value(); - - case 2: - assert(pic_false_p(tmp)); - - conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter"); - if (pic_test(conv)) { - pic_assert_type(pic, conv, proc); - - return pic_apply1(pic, pic_proc_ptr(conv), val); - } else { - return val; - } - } - PIC_UNREACHABLE(); } struct pic_proc * @@ -82,8 +62,12 @@ pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) struct pic_proc *var; var = pic_make_proc(pic, var_call, ""); - pic_attr_set(pic, pic_obj_value(var), "@@box", pic_cons(pic, pic_false_value(), init)); - pic_attr_set(pic, pic_obj_value(var), "@@converter", conv ? pic_obj_value(conv) : pic_false_value()); + + if (conv != NULL) { + pic_proc_env_set(pic, var, "conv", pic_obj_value(conv)); + } + + pic_apply1(pic, var, init); return var; } @@ -99,12 +83,26 @@ pic_var_make_parameter(pic_state *pic) return pic_obj_value(pic_make_var(pic, init, conv)); } +static pic_value +pic_var_with_parameter(pic_state *pic) +{ + struct pic_proc *body; + pic_value val; + + pic_get_args(pic, "l", &body); + + pic->ptable = pic_cons(pic, pic_obj_value(pic_make_reg(pic)), pic->ptable); + + val = pic_apply0(pic, body); + + pic->ptable = pic_cdr(pic, pic->ptable); + + return val; +} + void pic_init_var(pic_state *pic) { - pic_define_noexport(pic, "current-dynamic-environment", pic_false_value()); - pic_defun(pic, "make-parameter", pic_var_make_parameter); - - pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL))); + pic_defun(pic, "with-parameter", pic_var_with_parameter); } diff --git a/extlib/benz/vector.c b/extlib/benz/vector.c index 33070d24..c3b914c1 100644 --- a/extlib/benz/vector.c +++ b/extlib/benz/vector.c @@ -3,9 +3,6 @@ */ #include "picrin.h" -#include "picrin/vector.h" -#include "picrin/string.h" -#include "picrin/pair.h" struct pic_vector * pic_make_vec(pic_state *pic, size_t len) @@ -15,9 +12,9 @@ pic_make_vec(pic_state *pic, size_t len) vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR); vec->len = len; - vec->data = (pic_value *)pic_alloc(pic, sizeof(pic_value) * len); + vec->data = (pic_value *)pic_malloc(pic, sizeof(pic_value) * len); for (i = 0; i < len; ++i) { - vec->data[i] = pic_none_value(); + vec->data[i] = pic_undef_value(); } return vec; } @@ -122,7 +119,7 @@ pic_vec_vector_set(pic_state *pic) pic_errorf(pic, "vector-set!: index out of range"); } v->data[k] = o; - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -147,14 +144,14 @@ pic_vec_vector_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 @@ -234,7 +231,7 @@ pic_vec_vector_fill_i(pic_state *pic) vec->data[start++] = obj; } - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -295,14 +292,14 @@ pic_vec_vector_for_each(pic_state *pic) pic_apply(pic, proc, vals); } - return pic_none_value(); + return pic_undef_value(); } static pic_value pic_vec_list_to_vector(pic_state *pic) { struct pic_vector *vec; - pic_value list, e, *data; + pic_value list, e, it, *data; pic_get_args(pic, "o", &list); @@ -310,7 +307,7 @@ pic_vec_list_to_vector(pic_state *pic) data = vec->data; - pic_for_each (e, list) { + pic_for_each (e, list, it) { *data++ = e; } return pic_obj_value(vec); @@ -363,7 +360,7 @@ pic_vec_vector_to_string(pic_state *pic) pic_errorf(pic, "vector->string: end index must not be less than start index"); } - buf = pic_alloc(pic, end - start); + buf = pic_malloc(pic, end - start); for (i = start; i < end; ++i) { pic_assert_type(pic, vec->data[i], char); @@ -392,7 +389,7 @@ pic_vec_string_to_vector(pic_state *pic) case 1: start = 0; case 2: - end = pic_strlen(str); + end = pic_str_len(str); } if (end < start) { diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index ea4821e2..7a062019 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -3,18 +3,6 @@ */ #include "picrin.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/vector.h" -#include "picrin/proc.h" -#include "picrin/port.h" -#include "picrin/irep.h" -#include "picrin/blob.h" -#include "picrin/lib.h" -#include "picrin/macro.h" -#include "picrin/error.h" -#include "picrin/dict.h" -#include "picrin/record.h" #define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)]) @@ -40,7 +28,7 @@ pic_get_proc(pic_state *pic) * F double *, bool * float with exactness * s pic_str ** string object * z char ** c string - * m pic_sym * symbol + * m pic_sym ** symbol * v pic_vec ** vector object * b pic_blob ** bytevector object * c char * char @@ -57,167 +45,180 @@ int pic_get_args(pic_state *pic, const char *format, ...) { char c; - int i = 1, argc = pic->ci->argc; + size_t paramc, optc, min; + size_t i , argc = pic->ci->argc - 1; va_list ap; - bool opt = false; + bool rest = false, opt = false; - va_start(ap, format); - while ((c = *format++)) { - switch (c) { - default: - if (argc <= i && ! opt) { - pic_errorf(pic, "wrong number of arguments"); - } - break; - case '|': - break; - case '*': - break; - } + /* paramc: required args count as scheme proc + optc: optional args count as scheme proc + argc: passed args count as scheme proc + vargc: args count passed to this function + */ - /* in order to run out of all arguments passed to this function - (i.e. do va_arg for each argument), optional argument existence - check is done in every case closure */ - - if (c == '*') - break; - - switch (c) { - case '|': + /* check nparams first */ + for (paramc = 0, c = *format; c; c = format[++paramc]) { + if (c == '|') { opt = true; break; + } + else if (c == '*') { + rest = true; + break; + } + } + + for (optc = 0; opt && c; c = format[paramc + opt + ++optc]) { + if (c == '*') { + rest = true; + break; + } + } + + /* '|' should be followed by at least 1 char */ + assert((opt ? 1 : 0) <= optc); + /* '*' should not be followed by any char */ + assert(format[paramc + opt + optc + rest] == '\0'); + + /* check argc. */ + if (argc < paramc || (paramc + optc < argc && ! rest)) { + pic_errorf(pic, "%s: wrong number of arguments (%d for %s%d)", + pic_symbol_name(pic, pic_proc_name(pic_proc_ptr(GET_OPERAND(pic, 0)))) , + argc, + rest? "at least " : "", + paramc); + } + + /* start dispatching */ + va_start(ap, format); + min = paramc + optc < argc ? paramc + optc : argc; + for (i = 1; i < min + 1; i++) { + + c = *format++; + /* skip '|' if exists. This is always safe because of assert and argc check */ + c = c == '|' ? *format++ : c; + + switch (c) { case 'o': { pic_value *p; p = va_arg(ap, pic_value*); - if (i < argc) { - *p = GET_OPERAND(pic,i); - i++; - } + *p = GET_OPERAND(pic,i); break; } +#if PIC_ENABLE_FLOAT case 'f': { double *f; + pic_value v; f = va_arg(ap, double *); - if (i < argc) { - pic_value v; - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_FLOAT: - *f = pic_float(v); - break; - case PIC_TT_INT: - *f = pic_int(v); - break; - default: - pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - i++; + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_FLOAT: + *f = pic_float(v); + break; + case PIC_TT_INT: + *f = pic_int(v); + break; + default: + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); } break; } case 'F': { double *f; bool *e; + pic_value v; f = va_arg(ap, double *); e = va_arg(ap, bool *); - if (i < argc) { - pic_value v; - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_FLOAT: - *f = pic_float(v); - *e = false; - break; - case PIC_TT_INT: - *f = pic_int(v); - *e = true; - break; - default: - pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - i++; + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_FLOAT: + *f = pic_float(v); + *e = false; + break; + case PIC_TT_INT: + *f = pic_int(v); + *e = true; + break; + default: + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); } break; } case 'I': { int *k; bool *e; + pic_value v; k = va_arg(ap, int *); e = va_arg(ap, bool *); - if (i < argc) { - pic_value v; - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_FLOAT: - *k = (int)pic_float(v); - *e = false; - break; - case PIC_TT_INT: - *k = pic_int(v); - *e = true; - break; - default: - pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - i++; + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_FLOAT: + *k = (int)pic_float(v); + *e = false; + break; + case PIC_TT_INT: + *k = pic_int(v); + *e = true; + break; + default: + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); } break; } +#endif case 'i': { int *k; + pic_value v; k = va_arg(ap, int *); - if (i < argc) { - pic_value v; - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_FLOAT: - *k = (int)pic_float(v); - break; - case PIC_TT_INT: - *k = pic_int(v); - break; - default: - pic_errorf(pic, "pic_get_args: expected int, but got ~s", v); - } - i++; + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { +#if PIC_ENABLE_FLOAT + case PIC_TT_FLOAT: + *k = (int)pic_float(v); + break; +#endif + case PIC_TT_INT: + *k = pic_int(v); + break; + default: + pic_errorf(pic, "pic_get_args: expected int, but got ~s", v); } break; } case 'k': { size_t *k; + pic_value v; + int x; + size_t s; k = va_arg(ap, size_t *); - if (i < argc) { - pic_value v; - int x; - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_INT: - x = pic_int(v); - if (x < 0) { - pic_errorf(pic, "pic_get_args: expected non-negative int, but got ~s", v); - } - if (sizeof(unsigned) > sizeof(size_t)) { - if ((unsigned)x > (unsigned)SIZE_MAX) { - pic_errorf(pic, "pic_get_args: int unrepresentable with size_t ~s", v); - } - } - *k = (size_t)x; - break; - default: - pic_errorf(pic, "pic_get_args: expected int, but got ~s", v); + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_INT: + x = pic_int(v); + if (x < 0) { + pic_errorf(pic, "pic_get_args: expected non-negative int, but got ~s", v); } - i++; + s = (size_t)x; + if (sizeof(unsigned) > sizeof(size_t)) { + if (x != (int)s) { + pic_errorf(pic, "pic_get_args: int unrepresentable with size_t ~s", v); + } + } + *k = (size_t)x; + break; + default: + pic_errorf(pic, "pic_get_args: expected int, but got ~s", v); } break; } @@ -226,15 +227,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; str = va_arg(ap, pic_str **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_str_p(v)) { - *str = pic_str_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_str_p(v)) { + *str = pic_str_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); } break; } @@ -243,30 +241,26 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; cstr = va_arg(ap, const char **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (! pic_str_p(v)) { - pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); - } - *cstr = pic_str_cstr(pic_str_ptr(v)); - i++; + v = GET_OPERAND(pic,i); + if (pic_str_p(v)) { + *cstr = pic_str_cstr(pic, pic_str_ptr(v)); + } + else { + pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); } break; } case 'm': { - pic_sym *m; + pic_sym **m; pic_value v; - m = va_arg(ap, pic_sym *); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_sym_p(v)) { - *m = pic_sym(v); - } - else { - pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v); - } - i++; + m = va_arg(ap, pic_sym **); + v = GET_OPERAND(pic,i); + if (pic_sym_p(v)) { + *m = pic_sym_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v); } break; } @@ -275,15 +269,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; vec = va_arg(ap, struct pic_vector **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_vec_p(v)) { - *vec = pic_vec_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected vector, but got ~s", v); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_vec_p(v)) { + *vec = pic_vec_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected vector, but got ~s", v); } break; } @@ -292,15 +283,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; b = va_arg(ap, struct pic_blob **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_blob_p(v)) { - *b = pic_blob_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_blob_p(v)) { + *b = pic_blob_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v); } break; } @@ -309,15 +297,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; k = va_arg(ap, char *); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_char_p(v)) { - *k = pic_char(v); - } - else { - pic_errorf(pic, "pic_get_args: expected char, but got ~s", v); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_char_p(v)) { + *k = pic_char(v); + } + else { + pic_errorf(pic, "pic_get_args: expected char, but got ~s", v); } break; } @@ -326,15 +311,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; l = va_arg(ap, struct pic_proc **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_proc_p(v)) { - *l = pic_proc_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args, expected procedure, but got ~s", v); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_proc_p(v)) { + *l = pic_proc_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args, expected procedure, but got ~s", v); } break; } @@ -343,15 +325,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; p = va_arg(ap, struct pic_port **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_port_p(v)) { - *p = pic_port_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args, expected port, but got ~s", v); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_port_p(v)) { + *p = pic_port_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args, expected port, but got ~s", v); } break; } @@ -360,15 +339,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; d = va_arg(ap, struct pic_dict **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_dict_p(v)) { - *d = pic_dict_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_dict_p(v)) { + *d = pic_dict_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v); } break; } @@ -377,15 +353,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; r = va_arg(ap, struct pic_record **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_record_p(v)) { - *r = pic_record_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected record, but got ~s", v); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_record_p(v)) { + *r = pic_record_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected record, but got ~s", v); } break; } @@ -394,15 +367,12 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_value v; e = va_arg(ap, struct pic_error **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_error_p(v)) { - *e = pic_error_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args, expected error"); - } - i++; + v = GET_OPERAND(pic,i); + if (pic_error_p(v)) { + *e = pic_error_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args, expected error"); } break; } @@ -410,39 +380,43 @@ pic_get_args(pic_state *pic, const char *format, ...) pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c); } } - if ('*' == c) { - size_t *n; - pic_value **argv; + if (rest) { + size_t *n; + pic_value **argv; - n = va_arg(ap, size_t *); - argv = va_arg(ap, pic_value **); - if (i <= argc) { - *n = (size_t)(argc - i); + n = va_arg(ap, size_t *); + argv = va_arg(ap, pic_value **); + *n = (size_t)(argc - (i - 1)); *argv = &GET_OPERAND(pic, i); - i = argc; - } - } - else if (argc > i) { - pic_errorf(pic, "wrong number of arguments"); } va_end(ap); - return i - 1; + return argc; +} + +void +pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rsym) +{ + pic_put_rename(pic, env, sym, rsym); + + if (pic->lib && pic->lib->env == env) { + pic_export(pic, sym); + } } void pic_define_noexport(pic_state *pic, const char *name, pic_value val) { - pic_sym sym, rename; + pic_sym *sym, *rename; sym = pic_intern_cstr(pic, name); - if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { + if ((rename = pic_find_rename(pic, pic->lib->env, sym)) == NULL) { rename = pic_add_rename(pic, pic->lib->env, sym); } else { - pic_warn(pic, "redefining global"); + pic_warnf(pic, "redefining global"); } - xh_put_int(&pic->globals, rename, &val); + pic_dict_set(pic, pic->globals, rename, val); } void @@ -456,29 +430,29 @@ pic_define(pic_state *pic, const char *name, pic_value val) pic_value pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) { - pic_sym sym, rename; + pic_sym *sym, *rename; sym = pic_intern_cstr(pic, name); - if (! pic_find_rename(pic, lib->env, sym, &rename)) { + if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } - return xh_val(xh_get_int(&pic->globals, rename), pic_value); + return pic_dict_ref(pic, pic->globals, rename); } void pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) { - pic_sym sym, rename; + pic_sym *sym, *rename; sym = pic_intern_cstr(pic, name); - if (! pic_find_rename(pic, lib->env, sym, &rename)) { + if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } - xh_put_int(&pic->globals, rename, &val); + pic_dict_set(pic, pic->globals, rename, val); } pic_value @@ -502,6 +476,23 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) pic_define(pic, name, pic_obj_value(proc)); } +void +pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) +{ + struct pic_proc *proc; + pic_sym *sym; + + proc = pic_make_proc(pic, func, name); + + sym = pic_intern_cstr(pic, name); + + pic_put_rename(pic, pic->lib->env, sym, rename); + + pic_dict_set(pic, pic->globals, rename, pic_obj_value(proc)); + + pic_export(pic, sym); +} + void pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) { @@ -509,33 +500,33 @@ pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *co } static void -vm_push_env(pic_state *pic) +vm_push_cxt(pic_state *pic) { pic_callinfo *ci = pic->ci; - ci->env = (struct pic_env *)pic_obj_alloc(pic, offsetof(struct pic_env, storage) + sizeof(pic_value) * (size_t)(ci->regc), PIC_TT_ENV); - ci->env->up = ci->up; - ci->env->regc = ci->regc; - ci->env->regs = ci->regs; + ci->cxt = (struct pic_context *)pic_obj_alloc(pic, sizeof(struct pic_context) + sizeof(pic_value) * (size_t)(ci->regc), PIC_TT_CXT); + ci->cxt->up = ci->up; + ci->cxt->regc = ci->regc; + ci->cxt->regs = ci->regs; } static void vm_tear_off(pic_callinfo *ci) { - struct pic_env *env; + struct pic_context *cxt; int i; - assert(ci->env != NULL); + assert(ci->cxt != NULL); - env = ci->env; + cxt = ci->cxt; - if (env->regs == env->storage) { + if (cxt->regs == cxt->storage) { return; /* is torn off */ } - for (i = 0; i < env->regc; ++i) { - env->storage[i] = env->regs[i]; + for (i = 0; i < cxt->regc; ++i) { + cxt->storage[i] = cxt->regs[i]; } - env->regs = env->storage; + cxt->regs = cxt->storage; } void @@ -544,12 +535,29 @@ pic_vm_tear_off(pic_state *pic) pic_callinfo *ci; for (ci = pic->ci; ci > pic->cibase; ci--) { - if (ci->env != NULL) { + if (ci->cxt != NULL) { vm_tear_off(ci); } } } +static struct pic_irep * +vm_get_irep(pic_state *pic) +{ + pic_value self; + struct pic_irep *irep; + + self = pic->ci->fp[0]; + if (! pic_proc_p(self)) { + pic_errorf(pic, "logic flaw"); + } + irep = pic_proc_ptr(self)->u.i.irep; + if (! pic_proc_irep_p(pic_proc_ptr(self))) { + pic_errorf(pic, "logic flaw"); + } + return irep; +} + pic_value pic_apply0(pic_state *pic, struct pic_proc *proc) { @@ -648,24 +656,25 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2 #if VM_DEBUG # define VM_CALL_PRINT \ do { \ + short i; \ puts("\n== calling proc..."); \ printf(" proc = "); \ pic_debug(pic, pic_obj_value(proc)); \ puts(""); \ printf(" argv = ("); \ - for (short i = 1; i < c.u.i; ++i) { \ + for (i = 1; i < c.u.i; ++i) { \ if (i > 1) \ printf(" "); \ pic_debug(pic, pic->sp[-c.u.i + i]); \ } \ puts(")"); \ if (! pic_proc_func_p(proc)) { \ - printf(" irep = %p\n", proc->u.irep); \ + printf(" irep = %p\n", proc->u.i.irep); \ printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ - pic_dump_irep(proc->u.irep); \ + pic_dump_irep(proc->u.i.irep); \ } \ else { \ - printf(" cfunc = %p\n", (void *)proc->u.func.f); \ + printf(" cfunc = %p\n", (void *)proc->u.f.func); \ printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ } \ puts("== end\n"); \ @@ -682,13 +691,13 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) pic_code boot[2]; #if PIC_DIRECT_THREADED_VM - static void *oplabels[] = { - &&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, - &&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST, + static const void *oplabels[] = { + &&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHUNDEF, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, + &&L_OP_PUSHFALSE, &&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST, &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET, &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP, - &&L_OP_SYMBOL_P, &&L_OP_PAIR_P, + &&L_OP_SYMBOLP, &&L_OP_PAIRP, &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_MINUS, &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP }; @@ -730,6 +739,10 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) (void)(POP()); NEXT; } + CASE(OP_PUSHUNDEF) { + PUSH(pic_undef_value()); + NEXT; + } CASE(OP_PUSHNIL) { PUSH(pic_nil_value()); NEXT; @@ -751,44 +764,41 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) NEXT; } CASE(OP_PUSHCONST) { - pic_value self; - struct pic_irep *irep; + struct pic_irep *irep = vm_get_irep(pic); - self = pic->ci->fp[0]; - if (! pic_proc_p(self)) { - pic_errorf(pic, "logic flaw"); - } - irep = pic_proc_ptr(self)->u.irep; - if (! pic_proc_irep_p(pic_proc_ptr(self))) { - pic_errorf(pic, "logic flaw"); - } PUSH(irep->pool[c.u.i]); NEXT; } CASE(OP_GREF) { - xh_entry *e; + struct pic_irep *irep = vm_get_irep(pic); + pic_sym *sym; - if ((e = xh_get_int(&pic->globals, c.u.i)) == NULL) { - pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, c.u.i)); + sym = irep->syms[c.u.i]; + if (! pic_dict_has(pic, pic->globals, sym)) { + pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, sym)); } - PUSH(xh_val(e, pic_value)); + PUSH(pic_dict_ref(pic, pic->globals, sym)); NEXT; } CASE(OP_GSET) { + struct pic_irep *irep = vm_get_irep(pic); + pic_sym *sym; pic_value val; + sym = irep->syms[c.u.i]; + val = POP(); - xh_put_int(&pic->globals, c.u.i, &val); + pic_dict_set(pic, pic->globals, sym, val); NEXT; } CASE(OP_LREF) { pic_callinfo *ci = pic->ci; struct pic_irep *irep; - if (ci->env != NULL && ci->env->regs == ci->env->storage) { - irep = pic_get_proc(pic)->u.irep; + if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) { + irep = pic_get_proc(pic)->u.i.irep; if (c.u.i >= irep->argc + irep->localc) { - PUSH(ci->env->regs[c.u.i - (ci->regs - ci->fp)]); + PUSH(ci->cxt->regs[c.u.i - (ci->regs - ci->fp)]); NEXT; } } @@ -799,10 +809,10 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) pic_callinfo *ci = pic->ci; struct pic_irep *irep; - if (ci->env != NULL && ci->env->regs == ci->env->storage) { - irep = pic_get_proc(pic)->u.irep; + if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) { + irep = pic_get_proc(pic)->u.i.irep; if (c.u.i >= irep->argc + irep->localc) { - ci->env->regs[c.u.i - (ci->regs - ci->fp)] = POP(); + ci->cxt->regs[c.u.i - (ci->regs - ci->fp)] = POP(); NEXT; } } @@ -811,24 +821,24 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) } CASE(OP_CREF) { int depth = c.u.r.depth; - struct pic_env *env; + struct pic_context *cxt; - env = pic->ci->up; + cxt = pic->ci->up; while (--depth) { - env = env->up; + cxt = cxt->up; } - PUSH(env->regs[c.u.r.idx]); + PUSH(cxt->regs[c.u.r.idx]); NEXT; } CASE(OP_CSET) { int depth = c.u.r.depth; - struct pic_env *env; + struct pic_context *cxt; - env = pic->ci->up; + cxt = pic->ci->up; while (--depth) { - env = env->up; + cxt = cxt->up; } - env->regs[c.u.r.idx] = POP(); + cxt->regs[c.u.r.idx] = POP(); NEXT; } CASE(OP_JMP) { @@ -879,11 +889,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) ci->retc = 1; ci->ip = pic->ip; ci->fp = pic->sp - c.u.i; - ci->env = NULL; + ci->cxt = NULL; if (pic_proc_func_p(pic_proc_ptr(x))) { /* invoke! */ - v = proc->u.func.f(pic); + v = proc->u.f.func(pic); pic->sp[0] = v; pic->sp += pic->ci->retc; @@ -891,13 +901,13 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) goto L_RET; } else { - struct pic_irep *irep = proc->u.irep; + struct pic_irep *irep = proc->u.i.irep; int i; pic_value rest; if (ci->argc != irep->argc) { if (! (irep->varg && ci->argc >= irep->argc)) { - pic_errorf(pic, "wrong number of arguments (%d for %d%s)", ci->argc - 1, irep->argc - 1, (irep->varg ? "+" : "")); + pic_errorf(pic, "wrong number of arguments (%d for %s%d)", ci->argc - 1, (irep->varg ? "at least " : ""), irep->argc - 1); } } /* prepare rest args */ @@ -920,8 +930,12 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) } } - /* prepare env */ - ci->up = proc->env; + /* prepare cxt */ + if (pic_proc_irep_p(proc)) { + ci->up = proc->u.i.cxt; + } else { + ci->up = NULL; + } ci->regc = irep->capturec; ci->regs = ci->fp + irep->argc + irep->localc; @@ -935,7 +949,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) pic_value *argv; pic_callinfo *ci; - if (pic->ci->env != NULL) { + if (pic->ci->cxt != NULL) { vm_tear_off(pic->ci); } @@ -961,7 +975,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) pic_value *retv; pic_callinfo *ci; - if (pic->ci->env != NULL) { + if (pic->ci->cxt != NULL) { vm_tear_off(pic->ci); } @@ -990,16 +1004,16 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) if (! pic_proc_p(self)) { pic_errorf(pic, "logic flaw"); } - irep = pic_proc_ptr(self)->u.irep; + irep = pic_proc_ptr(self)->u.i.irep; if (! pic_proc_irep_p(pic_proc_ptr(self))) { pic_errorf(pic, "logic flaw"); } - if (pic->ci->env == NULL) { - vm_push_env(pic); + if (pic->ci->cxt == NULL) { + vm_push_cxt(pic); } - proc = pic_make_proc_irep(pic, irep->irep[c.u.i], pic->ci->env); + proc = pic_make_proc_irep(pic, irep->irep[c.u.i], pic->ci->cxt); PUSH(pic_obj_value(proc)); pic_gc_arena_restore(pic, ai); NEXT; @@ -1031,14 +1045,14 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) NEXT; } - CASE(OP_SYMBOL_P) { + CASE(OP_SYMBOLP) { pic_value p; p = POP(); PUSH(pic_bool_value(pic_sym_p(p))); NEXT; } - CASE(OP_PAIR_P) { + CASE(OP_PAIRP) { pic_value p; p = POP(); PUSH(pic_bool_value(pic_pair_p(p))); @@ -1074,10 +1088,31 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) NEXT; \ } +#define DEFINE_ARITH_OP2(opcode, op) \ + CASE(opcode) { \ + pic_value a, b; \ + b = POP(); \ + a = POP(); \ + if (pic_int_p(a) && pic_int_p(b)) { \ + PUSH(pic_int_value(pic_int(a) op pic_int(b))); \ + } \ + else { \ + pic_errorf(pic, #op " got non-number operands"); \ + } \ + NEXT; \ + } + +#if PIC_ENABLE_FLOAT DEFINE_ARITH_OP(OP_ADD, +, true); DEFINE_ARITH_OP(OP_SUB, -, true); DEFINE_ARITH_OP(OP_MUL, *, true); DEFINE_ARITH_OP(OP_DIV, /, f == round(f)); +#else + DEFINE_ARITH_OP2(OP_ADD, +); + DEFINE_ARITH_OP2(OP_SUB, -); + DEFINE_ARITH_OP2(OP_MUL, *); + DEFINE_ARITH_OP2(OP_DIV, /); +#endif CASE(OP_MINUS) { pic_value n; @@ -1085,9 +1120,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) if (pic_int_p(n)) { PUSH(pic_int_value(-pic_int(n))); } +#if PIC_ENABLE_FLOAT else if (pic_float_p(n)) { PUSH(pic_float_value(-pic_float(n))); } +#endif else { pic_errorf(pic, "unary - got a non-number operand"); } @@ -1117,9 +1154,29 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) NEXT; \ } +#define DEFINE_COMP_OP2(opcode, op) \ + CASE(opcode) { \ + pic_value a, b; \ + b = POP(); \ + a = POP(); \ + if (pic_int_p(a) && pic_int_p(b)) { \ + PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \ + } \ + else { \ + pic_errorf(pic, #op " got non-number operands"); \ + } \ + NEXT; \ + } + +#if PIC_ENABLE_FLOAT DEFINE_COMP_OP(OP_EQ, ==); DEFINE_COMP_OP(OP_LT, <); DEFINE_COMP_OP(OP_LE, <=); +#else + DEFINE_COMP_OP2(OP_EQ, ==); + DEFINE_COMP_OP2(OP_LT, <); + DEFINE_COMP_OP2(OP_LE, <=); +#endif CASE(OP_STOP) { @@ -1133,28 +1190,26 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) pic_value pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) { - static const pic_code iseq[2] = { - { OP_NOP, { .i = 0 } }, - { OP_TAILCALL, { .i = -1 } } - }; - - pic_value v, *sp; + pic_value v, it, *sp; pic_callinfo *ci; + PIC_INIT_CODE_I(pic->iseq[0], OP_NOP, 0); + PIC_INIT_CODE_I(pic->iseq[1], OP_TAILCALL, -1); + *pic->sp++ = pic_obj_value(proc); sp = pic->sp; - pic_for_each (v, args) { + pic_for_each (v, args, it) { *sp++ = v; } ci = PUSHCI(); - ci->ip = (pic_code *)iseq; + ci->ip = pic->iseq; ci->fp = pic->sp; ci->retc = (int)pic_length(pic, args); if (ci->retc == 0) { - return pic_none_value(); + return pic_undef_value(); } else { return pic_car(pic, args); } diff --git a/extlib/benz/write.c b/extlib/benz/write.c index e35d6eee..73ee11f5 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -3,21 +3,13 @@ */ #include "picrin.h" -#include "picrin/port.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/vector.h" -#include "picrin/blob.h" -#include "picrin/dict.h" -#include "picrin/record.h" -#include "picrin/proc.h" static bool -is_tagged(pic_state *pic, pic_sym tag, pic_value pair) +is_tagged(pic_state *pic, pic_sym *tag, pic_value pair) { return pic_pair_p(pic_cdr(pic, pair)) && pic_nil_p(pic_cddr(pic, pair)) - && pic_eq_p(pic_car(pic, pair), pic_symbol_value(tag)); + && pic_eq_p(pic_car(pic, pair), pic_obj_value(tag)); } static bool @@ -160,11 +152,9 @@ static void write_str(pic_state *pic, struct pic_string *str, xFILE *file) { size_t i; - const char *cstr = pic_str_cstr(str); + const char *cstr = pic_str_cstr(pic, str); - PIC_UNUSED(pic); - - for (i = 0; i < pic_strlen(str); ++i) { + for (i = 0; i < pic_str_len(str); ++i) { if (cstr[i] == '"' || cstr[i] == '\\') { xfputc('\\', file); } @@ -175,7 +165,7 @@ write_str(pic_state *pic, struct pic_string *str, xFILE *file) static void write_record(pic_state *pic, struct pic_record *rec, xFILE *file) { - const pic_sym sWRITER = pic_intern_cstr(pic, "writer"); + pic_sym *sWRITER = pic_intern_cstr(pic, "writer"); pic_value type, writer, str; #if DEBUG @@ -196,7 +186,7 @@ write_record(pic_state *pic, struct pic_record *rec, xFILE *file) if (! pic_str_p(str)) { pic_errorf(pic, "return value from writer procedure is not of string type"); } - xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(str))); + xfprintf(file, "%s", pic_str_cstr(pic, pic_str_ptr(str))); #endif } @@ -209,7 +199,9 @@ write_core(struct writer_control *p, pic_value obj) size_t i; xh_entry *e, *it; int c; +#if PIC_ENABLE_FLOAT double f; +#endif /* shared objects */ if (pic_vtype(obj) == PIC_VTYPE_HEAP @@ -228,7 +220,7 @@ write_core(struct writer_control *p, pic_value obj) switch (pic_type(obj)) { case PIC_TT_UNDEF: - xfprintf(file, "#"); + xfprintf(file, "#undefined"); break; case PIC_TT_NIL: xfprintf(file, "()"); @@ -265,7 +257,7 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(file, ")"); break; case PIC_TT_SYMBOL: - xfprintf(file, "%s", pic_symbol_name(pic, pic_sym(obj))); + xfprintf(file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); break; case PIC_TT_CHAR: if (p->mode == DISPLAY_MODE) { @@ -284,6 +276,7 @@ write_core(struct writer_control *p, pic_value obj) case '\t': xfprintf(file, "#\\tab"); break; } break; +#if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: f = pic_float(obj); if (isnan(f)) { @@ -294,6 +287,7 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(file, "%f", pic_float(obj)); } break; +#endif case PIC_TT_INT: xfprintf(file, "%d", pic_int(obj)); break; @@ -302,7 +296,7 @@ write_core(struct writer_control *p, pic_value obj) break; case PIC_TT_STRING: if (p->mode == DISPLAY_MODE) { - xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(obj))); + xfprintf(file, "%s", pic_str_cstr(pic, pic_str_ptr(obj))); break; } xfprintf(file, "\""); @@ -332,7 +326,7 @@ write_core(struct writer_control *p, pic_value obj) case PIC_TT_DICT: xfprintf(file, "#.(dictionary"); for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) { - xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym))); + xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym *))); write_core(p, xh_val(it, pic_value)); } xfprintf(file, ")"); @@ -405,7 +399,7 @@ display(pic_state *pic, pic_value obj, xFILE *file) pic_value pic_write(pic_state *pic, pic_value obj) { - return pic_fwrite(pic, obj, xstdout); + return pic_fwrite(pic, obj, pic_stdout(pic)->file); } pic_value @@ -419,7 +413,7 @@ pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) pic_value pic_display(pic_state *pic, pic_value obj) { - return pic_fdisplay(pic, obj, xstdout); + return pic_fdisplay(pic, obj, pic_stdout(pic)->file); } pic_value @@ -433,6 +427,7 @@ pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) void pic_printf(pic_state *pic, const char *fmt, ...) { + xFILE *file = pic_stdout(pic)->file; va_list ap; pic_str *str; @@ -442,8 +437,8 @@ pic_printf(pic_state *pic, const char *fmt, ...) va_end(ap); - xprintf("%s", pic_str_cstr(str)); - xfflush(xstdout); + xfprintf(file, "%s", pic_str_cstr(pic, str)); + xfflush(file); } static pic_value @@ -454,7 +449,7 @@ pic_write_write(pic_state *pic) pic_get_args(pic, "o|p", &v, &port); write(pic, v, port->file); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -465,7 +460,7 @@ pic_write_write_simple(pic_state *pic) pic_get_args(pic, "o|p", &v, &port); write_simple(pic, v, port->file); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -476,7 +471,7 @@ pic_write_write_shared(pic_state *pic) pic_get_args(pic, "o|p", &v, &port); write_shared(pic, v, port->file); - return pic_none_value(); + return pic_undef_value(); } static pic_value @@ -487,7 +482,7 @@ pic_write_display(pic_state *pic) pic_get_args(pic, "o|p", &v, &port); display(pic, v, port->file); - return pic_none_value(); + return pic_undef_value(); } void diff --git a/extlib/benz/xfile.c b/extlib/benz/xfile.c new file mode 100644 index 00000000..b28bf060 --- /dev/null +++ b/extlib/benz/xfile.c @@ -0,0 +1,478 @@ +#include "picrin.h" + +static int file_read(void *cookie, char *ptr, int size) { + FILE *file = cookie; + int r; + + size = 1; /* override size */ + + 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 int 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; + } + fflush(cookie); + return r; +} + +static long file_seek(void *cookie, long pos, int whence) { + switch (whence) { + case XSEEK_CUR: + whence = SEEK_CUR; + break; + case XSEEK_SET: + whence = SEEK_SET; + break; + case XSEEK_END: + whence = SEEK_END; + break; + } + return fseek(cookie, pos, whence); +} + +static int file_close(void *cookie) { + return fclose(cookie); +} + +xFILE *xfopen(const char *name, const char *mode) { + FILE *fp; + + if ((fp = fopen(name, mode)) == NULL) { + return NULL; + } + + switch (*mode) { + case 'r': + return xfunopen(fp, file_read, NULL, file_seek, file_close); + default: + return xfunopen(fp, NULL, file_write, file_seek, file_close); + } +} + +#define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close } + +xFILE x_iob[XOPEN_MAX] = { + { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_READ }, + { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_LNBUF }, + { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_UNBUF } +}; + +xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*close)(void *)) { + xFILE *fp; + + for (fp = x_iob; fp < x_iob + XOPEN_MAX; fp++) + if ((fp->flag & (X_READ | X_WRITE)) == 0) + break; /* found free slot */ + + if (fp >= x_iob + XOPEN_MAX) /* no free slots */ + return NULL; + + fp->cnt = 0; + fp->base = NULL; + fp->flag = read? X_READ : X_WRITE; + + fp->vtable.cookie = cookie; + fp->vtable.read = read; + fp->vtable.write = write; + fp->vtable.seek = seek; + fp->vtable.close = close; + + return fp; +} + +int xfclose(xFILE *fp) { + extern void free(void *); /* FIXME */ + + xfflush(fp); + fp->flag = 0; + if (fp->base != fp->buf) + free(fp->base); + return fp->vtable.close(fp->vtable.cookie); +} + +int x_fillbuf(xFILE *fp) { + extern void *malloc(size_t); /* FIXME */ + int bufsize; + + if ((fp->flag & (X_READ|X_EOF|X_ERR)) != X_READ) + return EOF; + if (fp->base == NULL) { + if ((fp->flag & X_UNBUF) == 0) { + /* no buffer yet */ + if ((fp->base = malloc(XBUFSIZ)) == NULL) { + /* can't get buffer, try unbuffered */ + fp->flag |= X_UNBUF; + } + } + if (fp->flag & X_UNBUF) { + fp->base = fp->buf; + } + } + bufsize = (fp->flag & X_UNBUF) ? sizeof(fp->buf) : XBUFSIZ; + + fp->ptr = fp->base; + fp->cnt = fp->vtable.read(fp->vtable.cookie, fp->ptr, bufsize); + + if (--fp->cnt < 0) { + if (fp->cnt == -1) + fp->flag |= X_EOF; + else + fp->flag |= X_ERR; + fp->cnt = 0; + return EOF; + } + + return (unsigned char) *fp->ptr++; +} + +int x_flushbuf(int x, xFILE *fp) { + extern void *malloc(size_t); /* FIXME */ + int num_written=0, bufsize=0; + char c = x; + + if ((fp->flag & (X_WRITE|X_EOF|X_ERR)) != X_WRITE) + return EOF; + if (fp->base == NULL && ((fp->flag & X_UNBUF) == 0)) { + /* no buffer yet */ + if ((fp->base = malloc(XBUFSIZ)) == NULL) { + /* couldn't allocate a buffer, so try unbuffered */ + fp->flag |= X_UNBUF; + } else { + fp->ptr = fp->base; + fp->cnt = XBUFSIZ - 1; + } + } + if (fp->flag & X_UNBUF) { + /* unbuffered write */ + fp->ptr = fp->base = NULL; + fp->cnt = 0; + if (x == EOF) + return EOF; + num_written = fp->vtable.write(fp->vtable.cookie, (const char *) &c, 1); + bufsize = 1; + } else { + /* buffered write */ + assert(fp->ptr); + if (x != EOF) { + *fp->ptr++ = (unsigned char) c; + } + bufsize = (int)(fp->ptr - fp->base); + while(bufsize - num_written > 0) { + int t; + t = fp->vtable.write(fp->vtable.cookie, fp->base + num_written, bufsize - num_written); + if (t < 0) + break; + num_written += t; + } + + fp->ptr = fp->base; + fp->cnt = BUFSIZ - 1; + } + + if (num_written == bufsize) { + return x; + } else { + fp->flag |= X_ERR; + return EOF; + } +} + +int xfflush(xFILE *f) { + int retval; + int i; + + retval = 0; + if (f == NULL) { + /* flush all output streams */ + for (i = 0; i < XOPEN_MAX; i++) { + if ((x_iob[i].flag & X_WRITE) && (xfflush(&x_iob[i]) == -1)) + retval = -1; + } + } else { + if ((f->flag & X_WRITE) == 0) + return -1; + x_flushbuf(EOF, f); + if (f->flag & X_ERR) + retval = -1; + } + return retval; +} + +int xfputc(int x, xFILE *fp) { + return xputc(x, fp); +} + +int xfgetc(xFILE *fp) { + return xgetc(fp); +} + +int xfputs(const char *s, xFILE *stream) { + const char *ptr = s; + while(*ptr != '\0') { + if (xputc(*ptr, stream) == EOF) + return EOF; + ++ptr; + } + return (int)(ptr - s); +} + +char *xfgets(char *s, int size, xFILE *stream) { + int c; + char *buf; + + xfflush(NULL); + + if (size == 0) { + return NULL; + } + buf = s; + while (--size > 0 && (c = xgetc(stream)) != EOF) { + if ((*buf++ = c) == '\n') + break; + } + *buf = '\0'; + + return (c == EOF && buf == s) ? NULL : s; +} + +int xputs(const char *s) { + int i = 1; + + while(*s != '\0') { + if (xputchar(*s++) == EOF) + return EOF; + i++; + } + if (xputchar('\n') == EOF) { + return EOF; + } + return i; +} + +char *xgets(char *s) { + int c; + char *buf; + + xfflush(NULL); + + buf = s; + while ((c = xgetchar()) != EOF && c != '\n') { + *buf++ = c; + } + *buf = '\0'; + + return (c == EOF && buf == s) ? NULL : s; +} + +int xungetc(int c, xFILE *fp) { + unsigned char uc = c; + + if (c == EOF || fp->base == fp->ptr) { + return EOF; + } + fp->cnt++; + return *--fp->ptr = uc; +} + +size_t xfread(void *ptr, size_t size, size_t count, xFILE *fp) { + char *bptr = ptr; + long nbytes; + int c; + + nbytes = size * count; + while (nbytes > fp->cnt) { + memcpy(bptr, fp->ptr, fp->cnt); + fp->ptr += fp->cnt; + bptr += fp->cnt; + nbytes -= fp->cnt; + if ((c = x_fillbuf(fp)) == EOF) { + return (size * count - nbytes) / size; + } else { + xungetc(c, fp); + } + } + memcpy(bptr, fp->ptr, nbytes); + fp->ptr += nbytes; + fp->cnt -= nbytes; + return count; +} + +size_t xfwrite(const void *ptr, size_t size, size_t count, xFILE *fp) { + const char *bptr = ptr; + long nbytes; + + nbytes = size * count; + while (nbytes > fp->cnt) { + memcpy(fp->ptr, bptr, fp->cnt); + fp->ptr += fp->cnt; + bptr += fp->cnt; + nbytes -= fp->cnt; + if (x_flushbuf(EOF, fp) == EOF) { + return (size * count - nbytes) / size; + } + } + memcpy(fp->ptr, bptr, nbytes); + fp->ptr += nbytes; + fp->cnt -= nbytes; + return count; +} + +long xfseek(xFILE *fp, long offset, int whence) { + long s; + + xfflush(fp); + + fp->ptr = fp->base; + fp->cnt = 0; + + if ((s = fp->vtable.seek(fp->vtable.cookie, offset, whence)) != 0) + return s; + fp->flag &= ~X_EOF; + return 0; +} + +long xftell(xFILE *fp) { + return xfseek(fp, 0, XSEEK_CUR); +} + +void xrewind(xFILE *fp) { + xfseek(fp, 0, XSEEK_SET); + xclearerr(fp); +} + +int xprintf(const char *fmt, ...) { + va_list ap; + int n; + + va_start(ap, fmt); + n = xvfprintf(xstdout, fmt, ap); + va_end(ap); + return n; +} + +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 int print_int(xFILE *stream, long x, int base) { + static const char digits[] = "0123456789abcdef"; + char buf[20]; + int i, c, neg; + + neg = 0; + if (x < 0) { + neg = 1; + x = -x; + } + + i = 0; + do { + buf[i++] = digits[x % base]; + } while ((x /= base) != 0); + + if (neg) { + buf[i++] = '-'; + } + + c = i; + while (i-- > 0) { + xputc(buf[i], stream); + } + return c; +} + +int xvfprintf(xFILE *stream, const char *fmt, va_list ap) { + const char *p; + char *sval; + int ival; +#if PIC_ENABLE_FLOAT + double dval; +#endif + void *vp; + int cnt = 0; + + for (p = fmt; *p; p++) { + if (*p != '%') { + xputc(*p, stream); + cnt++; + continue; + } + switch (*++p) { + case 'd': + case 'i': + ival = va_arg(ap, int); + cnt += print_int(stream, ival, 10); + break; +#if PIC_ENABLE_FLOAT + case 'f': + dval = va_arg(ap, double); + cnt += print_int(stream, dval, 10); + xputc('.', stream); + cnt++; + if ((ival = fabs((dval - floor(dval)) * 1e4) + 0.5) == 0) { + cnt += xfputs("0000", stream); + } else { + int i; + for (i = 0; i < 3 - (int)log10(ival); ++i) { + xputc('0', stream); + cnt++; + } + cnt += print_int(stream, ival, 10); + } + break; +#endif + case 's': + sval = va_arg(ap, char*); + cnt += xfputs(sval, stream); + break; + case 'p': + vp = va_arg(ap, void*); + cnt += xfputs("0x", stream); + cnt += print_int(stream, (long)vp, 16); + break; + case '%': + xputc(*(p-1), stream); + cnt++; + break; + default: + xputc('%', stream); + xputc(*(p-1), stream); + cnt += 2; + break; + } + } + return cnt; +} + +#if 0 +int main() +{ + char buf[256]; + + xgets(buf); + + xprintf("%s\n", buf); + xprintf("hello\n"); + xprintf("hello\n"); + // xfflush(0); +} +#endif diff --git a/.gitmodules b/lib/.gitkeep similarity index 100% rename from .gitmodules rename to lib/.gitkeep diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt deleted file mode 100644 index 5e734f4a..00000000 --- a/piclib/CMakeLists.txt +++ /dev/null @@ -1,10 +0,0 @@ -list(APPEND PICLIB_SCHEME_LIBS - ${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/experimental/lambda.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/syntax-rules.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm - ) diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index baf00023..c81744a2 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -37,6 +37,8 @@ eqv? equal?) + (export undefined?) + (export boolean? boolean=? not) @@ -176,7 +178,6 @@ dictionary dictionary-ref dictionary-set! - dictionary-delete! dictionary-size dictionary-map dictionary-for-each diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm deleted file mode 100644 index 1a789c7f..00000000 --- a/piclib/picrin/dictionary.scm +++ /dev/null @@ -1,14 +0,0 @@ -(define-library (picrin dictionary) - (import (picrin base)) - - (export dictionary? - dictionary - make-dictionary - dictionary-ref - dictionary-set! - dictionary-delete! - dictionary-size - dictionary->plist - plist->dictionary - dictionary->alist - alist->dictionary)) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index 22bdf097..e11d4eb7 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -1,6 +1,19 @@ (define-library (picrin macro) (import (picrin base)) + (export identifier? + identifier=? + make-identifier + make-syntactic-closure + close-syntax + capture-syntactic-environment + sc-macro-transformer + rsc-macro-transformer + er-macro-transformer + ir-macro-transformer + ;; strip-syntax + define-macro) + ;; assumes no derived expressions are provided yet (define (walk proc expr) @@ -20,14 +33,13 @@ "memoize on symbols" (define cache (make-dictionary)) (lambda (sym) - (call-with-values (lambda () (dictionary-ref cache sym)) - (lambda (value exists) - (if exists - value - (begin - (define val (f sym)) - (dictionary-set! cache sym val) - val)))))) + (define value (dictionary-ref cache sym)) + (if (not (undefined? value)) + value + (begin + (define val (f sym)) + (dictionary-set! cache sym val) + val)))) (define (make-syntactic-closure env free form) @@ -47,65 +59,69 @@ (make-syntactic-closure env '() form)) (define-syntax capture-syntactic-environment - (lambda (form use-env mac-env) - (list (cadr form) (list (make-identifier 'quote mac-env) mac-env)))) + (lambda (mac-env) + (lambda (form use-env) + (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))) (define (sc-macro-transformer f) - (lambda (expr use-env mac-env) - (make-syntactic-closure mac-env '() (f expr use-env)))) + (lambda (mac-env) + (lambda (expr use-env) + (make-syntactic-closure mac-env '() (f expr use-env))))) (define (rsc-macro-transformer f) - (lambda (expr use-env mac-env) - (make-syntactic-closure use-env '() (f expr mac-env)))) + (lambda (mac-env) + (lambda (expr use-env) + (make-syntactic-closure use-env '() (f expr mac-env))))) (define (er-macro-transformer f) - (lambda (expr use-env mac-env) + (lambda (mac-env) + (lambda (expr use-env) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? use-env x use-env y)))) + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? use-env x use-env y)))) - (f expr rename compare))) + (f expr rename compare)))) (define (ir-macro-transformer f) - (lambda (expr use-env mac-env) + (lambda (mac-env) + (lambda (expr use-env) - (define icache* (make-dictionary)) + (define icache* (make-dictionary)) - (define inject - (memoize - (lambda (sym) - (define id (make-identifier sym use-env)) - (dictionary-set! icache* id sym) - id))) + (define inject + (memoize + (lambda (sym) + (define id (make-identifier sym use-env)) + (dictionary-set! icache* id sym) + id))) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? mac-env x mac-env y)))) + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? mac-env x mac-env y)))) - (walk (lambda (sym) - (call-with-values (lambda () (dictionary-ref icache* sym)) - (lambda (value exists) - (if exists - value - (rename sym))))) - (f (walk inject expr) inject compare)))) + (walk (lambda (sym) + (let ((value (dictionary-ref icache* sym))) + (if (undefined? value) + (rename sym) + value))) + (f (walk inject expr) inject compare))))) ;; (define (strip-syntax form) ;; (walk ungensym form)) @@ -122,17 +138,4 @@ (list (r 'define-macro) (car formal) (cons (r 'lambda) (cons (cdr formal) - body))))))) - - (export identifier? - identifier=? - make-identifier - make-syntactic-closure - close-syntax - capture-syntactic-environment - sc-macro-transformer - rsc-macro-transformer - er-macro-transformer - ir-macro-transformer - ;; strip-syntax - define-macro)) + body)))))))) diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm index 6784524b..7559cbbe 100644 --- a/piclib/picrin/record.scm +++ b/piclib/picrin/record.scm @@ -80,16 +80,16 @@ `(define (,accessor record) (if (,pred record) (record-ref record ',field-name) - (error "wrong record type"))) + (error (string-append (symbol->string ',accessor) ": wrong record type") record))) `(begin (define (,accessor record) (if (,pred record) (record-ref record ',field-name) - (error "wrong record type"))) + (error (string-append (symbol->string ',accessor) ": wrong record type") record))) (define (,(car modifier?) record val) (if (,pred record) (record-set! record ',field-name val) - (error "wrong record type"))))))))) + (error (string-append (symbol->string ',(car modifier?)) ": wrong record type") record))))))))) (define-syntax define-record-type (ir-macro-transformer diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 342650a5..6eeef05b 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -1,5 +1,6 @@ (define-library (picrin syntax-rules) (import (picrin base) + (picrin control) (picrin macro)) (define-syntax define-auxiliary-syntax @@ -7,7 +8,8 @@ (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 _) (define-auxiliary-syntax ...) @@ -73,7 +75,7 @@ (define _unquote (r 'unquote)) (define _unquote-splicing (r 'unquote-splicing)) (define _syntax-error (r 'syntax-error)) - (define _call/cc (r 'call/cc)) + (define _escape (r 'escape)) (define _er-macro-transformer (r 'er-macro-transformer)) (define (var->sym v) @@ -302,7 +304,7 @@ (match (list-ref (car clauses) 1)) (expand (list-ref (car clauses) 2))) `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) - (,_let ((result (,_call/cc (,_lambda (exit) ,match)))) + (,_let ((result (,_escape (,_lambda (exit) ,match)))) (,_if result ,expand ,(expand-clauses (cdr clauses) rename)))))))) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt deleted file mode 100644 index 0ca3b949..00000000 --- a/src/CMakeLists.txt +++ /dev/null @@ -1,47 +0,0 @@ -### libpicrin ### - -find_package(Perl REQUIRED) - -# benz -file(GLOB BENZ_SOURCES extlib/benz/*.c) - -# srcs -file(GLOB PICRIN_SOURCES src/*.c) - -# piclib -set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c) -add_custom_command( - OUTPUT ${PICLIB_SOURCE} - COMMAND ${PERL_EXECUTABLE} etc/mkloader.pl ${PICLIB_SCHEME_LIBS} ${PICLIB_CONTRIB_LIBS} > ${PICLIB_SOURCE} - DEPENDS ${PICLIB_SCHEME_LIBS} ${PICLIB_CONTRIB_LIBS} - WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} - ) - -# contrib -set(CONTRIB_INIT ${PROJECT_SOURCE_DIR}/src/init_contrib.c) -add_custom_command( - OUTPUT ${CONTRIB_INIT} - COMMAND ${PERL_EXECUTABLE} etc/mkinit.pl ${PICRIN_CONTRIB_INITS} > ${CONTRIB_INIT} - DEPENDS ${PICRIN_CONTRIB_SOURCES} - WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} - ) - -add_library(picrin SHARED ${BENZ_SOURCES} ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT}) -target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES}) - -# install -set(CMAKE_INSTALL_RPATH ${CMAKE_INSTALL_PREFIX}/lib) -install(TARGETS picrin DESTINATION lib) -install(DIRECTORY extlib/benz/include/ DESTINATION include FILES_MATCHING PATTERN "*.h") - -### picrin ### - -list(APPEND REPL_LIBRARIES picrin) - -# build -add_executable(repl src/main.c) -set_target_properties(repl PROPERTIES OUTPUT_NAME picrin) -target_link_libraries(repl ${REPL_LIBRARIES}) - -# install -install(TARGETS repl RUNTIME DESTINATION bin) diff --git a/src/main.c b/src/main.c index 7d4f6fd1..fbdae10c 100644 --- a/src/main.c +++ b/src/main.c @@ -3,8 +3,6 @@ */ #include "picrin.h" -#include "picrin/pair.h" -#include "picrin/error.h" void pic_init_contrib(pic_state *); void pic_load_piclib(pic_state *); @@ -20,11 +18,11 @@ pic_features(pic_state *pic) static pic_value pic_libraries(pic_state *pic) { - pic_value libs = pic_nil_value(), lib; + pic_value libs = pic_nil_value(), lib, it; pic_get_args(pic, ""); - pic_for_each (lib, pic->libs) { + pic_for_each (lib, pic->libs, it) { libs = pic_cons(pic, pic_car(pic, lib), libs); } @@ -42,10 +40,10 @@ pic_init_picrin(pic_state *pic) pic_deflibrary (pic, "(scheme base)") { pic_defun(pic, "features", pic_features); - - pic_init_contrib(pic); - pic_load_piclib(pic); } + + pic_init_contrib(pic); + pic_load_piclib(pic); } int @@ -55,7 +53,7 @@ main(int argc, char *argv[], char **envp) struct pic_lib *PICRIN_MAIN; int status = 0; - pic = pic_open(argc, argv, envp); + pic = pic_open(argc, argv, envp, pic_default_allocf); pic_init_picrin(pic); @@ -65,7 +63,7 @@ main(int argc, char *argv[], char **envp) pic_funcall(pic, PICRIN_MAIN, "main", pic_nil_value()); } pic_catch { - pic_print_backtrace(pic); + pic_print_backtrace(pic, xstderr); status = 1; } diff --git a/t/escape.scm b/t/escape.scm new file mode 100644 index 00000000..8f495a95 --- /dev/null +++ b/t/escape.scm @@ -0,0 +1,16 @@ +(import (scheme base) + (picrin control) + (picrin test)) + +(test-begin) + +(test 1 (escape (lambda (exit) (begin (exit 1) 2)))) + +(define cont #f) + +(test "calling dead escape continuation" + (guard (c ((error-object? c) (error-object-message c))) + (escape (lambda (exit) (set! cont exit))) + (cont 3))) + +(test-end) diff --git a/t/issue/250.scm b/t/issue/250.scm new file mode 100644 index 00000000..38c1fe72 --- /dev/null +++ b/t/issue/250.scm @@ -0,0 +1,5 @@ +(import (scheme base) + (scheme file)) + +(with-output-to-file "test.txt" + (write "TEST")) diff --git a/t/issue/257.scm b/t/issue/257.scm new file mode 100644 index 00000000..8872be72 --- /dev/null +++ b/t/issue/257.scm @@ -0,0 +1,4 @@ +(import (scheme base) + (picrin test)) + +(map +)