From a1281a8e8c5ea2df2ff730c4fd4e3a7c55e45035 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 13:38:09 +0900 Subject: [PATCH 001/232] first commit --- AUTHORS | 7 + CMakeLists.txt | 32 + LICENSE | 18 + README.md | 95 + blob.c | 196 ++ bool.c | 201 ++ char.c | 43 + codegen.c | 1458 ++++++++++++ cont.c | 371 +++ data.c | 15 + debug.c | 74 + dict.c | 176 ++ error.c | 286 +++ eval.c | 39 + file.c | 119 + gc.c | 872 ++++++++ include/.dir-locals.el | 3 + include/picrin.h | 223 ++ include/picrin/.dir-locals.el | 4 + include/picrin/blob.h | 27 + include/picrin/config.h | 115 + include/picrin/cont.h | 62 + include/picrin/data.h | 37 + include/picrin/dict.h | 32 + include/picrin/error.h | 60 + include/picrin/gc.h | 24 + include/picrin/irep.h | 206 ++ include/picrin/lib.h | 25 + include/picrin/macro.h | 47 + include/picrin/pair.h | 76 + include/picrin/port.h | 50 + include/picrin/proc.h | 62 + include/picrin/read.h | 39 + include/picrin/record.h | 30 + include/picrin/string.h | 42 + include/picrin/util.h | 51 + include/picrin/value.h | 484 ++++ include/picrin/var.h | 32 + include/picrin/vector.h | 29 + init.c | 124 + init_contrib.c | 17 + lib.c | 273 +++ load.c | 87 + load_piclib.c | 3978 +++++++++++++++++++++++++++++++++ macro.c | 494 ++++ number.c | 944 ++++++++ pair.c | 767 +++++++ port.c | 749 +++++++ proc.c | 183 ++ read.c | 976 ++++++++ record.c | 115 + state.c | 205 ++ string.c | 424 ++++ symbol.c | 161 ++ system.c | 136 ++ time.c | 49 + var.c | 134 ++ vector.c | 283 +++ vm.c | 1057 +++++++++ write.c | 506 +++++ 60 files changed, 17424 insertions(+) create mode 100644 AUTHORS create mode 100644 CMakeLists.txt create mode 100644 LICENSE create mode 100644 README.md create mode 100644 blob.c create mode 100644 bool.c create mode 100644 char.c create mode 100644 codegen.c create mode 100644 cont.c create mode 100644 data.c create mode 100644 debug.c create mode 100644 dict.c create mode 100644 error.c create mode 100644 eval.c create mode 100644 file.c create mode 100644 gc.c create mode 100644 include/.dir-locals.el create mode 100644 include/picrin.h create mode 100644 include/picrin/.dir-locals.el create mode 100644 include/picrin/blob.h create mode 100644 include/picrin/config.h create mode 100644 include/picrin/cont.h create mode 100644 include/picrin/data.h create mode 100644 include/picrin/dict.h create mode 100644 include/picrin/error.h create mode 100644 include/picrin/gc.h create mode 100644 include/picrin/irep.h create mode 100644 include/picrin/lib.h create mode 100644 include/picrin/macro.h create mode 100644 include/picrin/pair.h create mode 100644 include/picrin/port.h create mode 100644 include/picrin/proc.h create mode 100644 include/picrin/read.h create mode 100644 include/picrin/record.h create mode 100644 include/picrin/string.h create mode 100644 include/picrin/util.h create mode 100644 include/picrin/value.h create mode 100644 include/picrin/var.h create mode 100644 include/picrin/vector.h create mode 100644 init.c create mode 100644 init_contrib.c create mode 100644 lib.c create mode 100644 load.c create mode 100644 load_piclib.c create mode 100644 macro.c create mode 100644 number.c create mode 100644 pair.c create mode 100644 port.c create mode 100644 proc.c create mode 100644 read.c create mode 100644 record.c create mode 100644 state.c create mode 100644 string.c create mode 100644 symbol.c create mode 100644 system.c create mode 100644 time.c create mode 100644 var.c create mode 100644 vector.c create mode 100644 vm.c create mode 100644 write.c diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..eb796f59 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,7 @@ +Yuichi Nishiwaki (yuichi@idylls.jp) +Masanori Ogino (masanori.ogino@gmail.com) +Yuito Murase (themamedaifuku@gmail.com) +Hiromu Yakura (hiromu1996@gmail.com) +Wataru Nakanishi (stibear1996@gmail.com) +Hiroki Kobayashi (silentkiddie-2013@yahoo.co.jp) +Sunrim Kim (3han5chou7@gmail.com) diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 00000000..f3e51499 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,32 @@ +find_package(Perl REQUIRED) + +# xfile +set(XFILE_SOURCES extlib/xfile/xfile.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} + ) + +# build! +file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c) +add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${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 include/ DESTINATION include FILES_MATCHING PATTERN "*.h") diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..15ab73e5 --- /dev/null +++ b/LICENSE @@ -0,0 +1,18 @@ +Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors + +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: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +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. diff --git a/README.md b/README.md new file mode 100644 index 00000000..dceed0be --- /dev/null +++ b/README.md @@ -0,0 +1,95 @@ +# Picrin [![Build Status](https://travis-ci.org/wasabiz/picrin.png)](https://travis-ci.org/wasabiz/picrin) + +Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not requires any special external libraries installed on the platform. + +## Features + +- 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`) + +## Documentation + +See http://picrin.readthedocs.org/ + +## Homepage + +Currently picrin is hosted on Github. You can freely send a bug report or pull-request, and fork the repository. + +https://github.com/wasabiz/picrin + +## IRC + +There is a chat room on chat.freenode.org, channel #picrin. IRC logs here: https://botbot.me/freenode/picrin/ + +## How to use it + +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/. + + $ 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 ccmake. + + $ 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 .. + + +## Requirement + +Picrin scheme depends on some external libraries to build the binary: + +- perl +- getopt +- 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 :( + +## Authors + +See `AUTHORS` diff --git a/blob.c b/blob.c new file mode 100644 index 00000000..0bb28713 --- /dev/null +++ b/blob.c @@ -0,0 +1,196 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/blob.h" + +char * +pic_strndup(pic_state *pic, const char *s, size_t n) +{ + char *r; + + r = pic_alloc(pic, n + 1); + memcpy(r, s, n); + r[n] = '\0'; + return r; +} + +char * +pic_strdup(pic_state *pic, const char *s) +{ + return pic_strndup(pic, s, strlen(s)); +} + +struct pic_blob * +pic_blob_new(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->len = len; + return bv; +} + +static pic_value +pic_blob_bytevector_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_blob_p(v)); +} + +static pic_value +pic_blob_make_bytevector(pic_state *pic) +{ + pic_blob *blob; + int k, b = 0, i; + + pic_get_args(pic, "i|i", &k, &b); + + if (b < 0 || b > 255) + pic_error(pic, "byte out of range"); + + blob = pic_blob_new(pic, k); + for (i = 0; i < k; ++i) { + blob->data[i] = b; + } + + return pic_obj_value(blob); +} + +static pic_value +pic_blob_bytevector_length(pic_state *pic) +{ + struct pic_blob *bv; + + pic_get_args(pic, "b", &bv); + + return pic_int_value(bv->len); +} + +static pic_value +pic_blob_bytevector_u8_ref(pic_state *pic) +{ + struct pic_blob *bv; + int k; + + pic_get_args(pic, "bi", &bv, &k); + + return pic_int_value(bv->data[k]); +} + +static pic_value +pic_blob_bytevector_u8_set(pic_state *pic) +{ + struct pic_blob *bv; + int k, v; + + pic_get_args(pic, "bii", &bv, &k, &v); + + if (v < 0 || v > 255) + pic_error(pic, "byte out of range"); + + bv->data[k] = v; + return pic_none_value(); +} + +static pic_value +pic_blob_bytevector_copy_i(pic_state *pic) +{ + pic_blob *to, *from; + int n, at, start, end; + + n = pic_get_args(pic, "bib|ii", &to, &at, &from, &start, &end); + + switch (n) { + case 3: + start = 0; + case 4: + end = from->len; + } + + if (to == from && (start <= at && at < end)) { + /* copy in reversed order */ + at += end - start; + while (start < end) { + to->data[--at] = from->data[--end]; + } + return pic_none_value(); + } + + while (start < end) { + to->data[at++] = from->data[start++]; + } + + return pic_none_value(); +} + +static pic_value +pic_blob_bytevector_copy(pic_state *pic) +{ + pic_blob *from, *to; + int n, start, end, i = 0; + + n = pic_get_args(pic, "b|ii", &from, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = from->len; + } + + to = pic_blob_new(pic, end - start); + while (start < end) { + to->data[i++] = from->data[start++]; + } + + return pic_obj_value(to); +} + +static pic_value +pic_blob_bytevector_append(pic_state *pic) +{ + size_t argc, i, j, len; + pic_value *argv; + pic_blob *blob; + + pic_get_args(pic, "*", &argc, &argv); + + len = 0; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], blob); + len += pic_blob_ptr(argv[i])->len; + } + + blob = pic_blob_new(pic, len); + + len = 0; + for (i = 0; i < argc; ++i) { + for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) { + blob->data[len + j] = pic_blob_ptr(argv[i])->data[j]; + } + len += pic_blob_ptr(argv[i])->len; + } + + return pic_obj_value(blob); +} + +void +pic_init_blob(pic_state *pic) +{ + pic_defun(pic, "bytevector?", pic_blob_bytevector_p); + pic_defun(pic, "make-bytevector", pic_blob_make_bytevector); + pic_defun(pic, "bytevector-length", pic_blob_bytevector_length); + pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref); + pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set); + pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i); + pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy); + pic_defun(pic, "bytevector-append", pic_blob_bytevector_append); +} diff --git a/bool.c b/bool.c new file mode 100644 index 00000000..8f8c75f1 --- /dev/null +++ b/bool.c @@ -0,0 +1,201 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#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) +{ + return pic_strcmp(str1, str2) == 0; +} + +static bool +blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2) +{ + size_t i; + + if (blob1->len != blob2->len) { + return false; + } + for (i = 0; i < blob1->len; ++i) { + if (blob1->data[i] != blob2->data[i]) + return false; + } + return true; +} + +static bool +internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht) +{ + pic_value local = pic_nil_value(); + size_t c; + + if (depth > 10) { + if (depth > 200) { + pic_errorf(pic, "Stack overflow in equal\n"); + } + if (pic_pair_p(x) || pic_vec_p(x)) { + if (xh_get_ptr(ht, pic_obj_ptr(x)) != NULL) { + return true; /* `x' was seen already. */ + } else { + xh_put_ptr(ht, pic_obj_ptr(x), NULL); + } + } + } + + c = 0; + + LOOP: + + if (pic_eqv_p(x, y)) + return true; + + if (pic_type(x) != pic_type(y)) + return false; + + switch (pic_type(x)) { + case PIC_TT_STRING: + return str_equal_p(pic_str_ptr(x), pic_str_ptr(y)); + + case PIC_TT_BLOB: + return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y)); + + case PIC_TT_PAIR: { + if (pic_nil_p(local)) { + local = x; + } + if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) { + x = pic_cdr(pic, x); + y = pic_cdr(pic, y); + + c++; + + if (c == 2) { + c = 0; + local = pic_cdr(pic, local); + if (pic_eq_p(local, x)) { + return true; + } + } + goto LOOP; + } else { + return false; + } + } + case PIC_TT_VECTOR: { + size_t i; + struct pic_vector *u, *v; + + u = pic_vec_ptr(x); + v = pic_vec_ptr(y); + + if (u->len != v->len) { + return false; + } + for (i = 0; i < u->len; ++i) { + if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht)) + return false; + } + return true; + } + default: + return false; + } +} + +bool +pic_equal_p(pic_state *pic, pic_value x, pic_value y){ + xhash ht; + + xh_init_ptr(&ht, 0); + + return internal_equal_p(pic, x, y, 0, &ht); +} + +static pic_value +pic_bool_eq_p(pic_state *pic) +{ + pic_value x, y; + + pic_get_args(pic, "oo", &x, &y); + + return pic_bool_value(pic_eq_p(x, y)); +} + +static pic_value +pic_bool_eqv_p(pic_state *pic) +{ + pic_value x, y; + + pic_get_args(pic, "oo", &x, &y); + + return pic_bool_value(pic_eqv_p(x, y)); +} + +static pic_value +pic_bool_equal_p(pic_state *pic) +{ + pic_value x, y; + + pic_get_args(pic, "oo", &x, &y); + + return pic_bool_value(pic_equal_p(pic, x, y)); +} + +static pic_value +pic_bool_not(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_false_p(v) ? pic_true_value() : pic_false_value(); +} + +static pic_value +pic_bool_boolean_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return (pic_true_p(v) || pic_false_p(v)) ? pic_true_value() : pic_false_value(); +} + +static pic_value +pic_bool_boolean_eq_p(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! (pic_true_p(argv[i]) || pic_false_p(argv[i]))) { + return pic_false_value(); + } + if (! pic_eq_p(argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); +} + +void +pic_init_bool(pic_state *pic) +{ + 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(pic, "boolean?", pic_bool_boolean_p); + pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p); +} diff --git a/char.c b/char.c new file mode 100644 index 00000000..6ec81c92 --- /dev/null +++ b/char.c @@ -0,0 +1,43 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" + +static pic_value +pic_char_char_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_char_p(v) ? pic_true_value() : pic_false_value(); +} + +static pic_value +pic_char_char_to_integer(pic_state *pic) +{ + char c; + + pic_get_args(pic, "c", &c); + + return pic_int_value(c); +} + +static pic_value +pic_char_integer_to_char(pic_state *pic) +{ + int i; + + pic_get_args(pic, "i", &i); + + return pic_char_value(i); +} + +void +pic_init_char(pic_state *pic) +{ + pic_defun(pic, "char?", pic_char_char_p); + pic_defun(pic, "char->integer", pic_char_char_to_integer); + pic_defun(pic, "integer->char", pic_char_integer_to_char); +} diff --git a/codegen.c b/codegen.c new file mode 100644 index 00000000..c1264dfb --- /dev/null +++ b/codegen.c @@ -0,0 +1,1458 @@ +/** + * See Copyright Notice in picrin.h + */ + +#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 + +/** + * scope object + */ + +typedef struct analyze_scope { + int depth; + bool varg; + xvect args, locals, captures; /* rest args variable is counted as a local */ + struct analyze_scope *up; +} analyze_scope; + +/** + * global analyzer state + */ + +typedef struct analyze_state { + pic_state *pic; + analyze_scope *scope; + pic_sym rCONS, rCAR, rCDR, rNILP; + 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_error(pic, "internal error! native VM procedure not found"); \ + } \ + state->slot = gsym; \ + } while (0) + +static analyze_state * +new_analyze_state(pic_state *pic) +{ + analyze_state *state; + xh_iter it; + struct pic_lib *stdlib, *listlib; + + state = pic_alloc(pic, sizeof(analyze_state)); + state->pic = pic; + state->scope = NULL; + + stdlib = pic_find_library(pic, pic_read_cstr(pic, "(scheme base)")); + listlib = pic_find_library(pic, pic_read_cstr(pic, "(picrin base list)")); + + /* native VM procedures */ + register_renamed_symbol(pic, state, rCONS, listlib, "cons"); + register_renamed_symbol(pic, state, rCAR, listlib, "car"); + register_renamed_symbol(pic, state, rCDR, listlib, "cdr"); + register_renamed_symbol(pic, state, rNILP, listlib, "null?"); + register_renamed_symbol(pic, state, rADD, stdlib, "+"); + register_renamed_symbol(pic, state, rSUB, stdlib, "-"); + register_renamed_symbol(pic, state, rMUL, stdlib, "*"); + register_renamed_symbol(pic, state, rDIV, stdlib, "/"); + register_renamed_symbol(pic, state, rEQ, stdlib, "="); + register_renamed_symbol(pic, state, rLT, stdlib, "<"); + register_renamed_symbol(pic, state, rLE, stdlib, "<="); + register_renamed_symbol(pic, state, rGT, stdlib, ">"); + register_renamed_symbol(pic, state, rGE, stdlib, ">="); + register_renamed_symbol(pic, state, rNOT, stdlib, "not"); + register_renamed_symbol(pic, state, rVALUES, stdlib, "values"); + register_renamed_symbol(pic, state, rCALL_WITH_VALUES, stdlib, "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()); + + xh_begin(&it, &pic->globals); + while (xh_next(&it)) { + pic_sym sym = xh_key(it.e, pic_sym); + xv_push(&state->scope->locals, &sym); + } + + return state; +} + +static void +destroy_analyze_state(analyze_state *state) +{ + pop_scope(state); + pic_free(state->pic, state); +} + +static bool +analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) +{ + pic_value v, sym; + + for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { + sym = pic_car(pic, v); + if (! pic_sym_p(sym)) { + return false; + } + xv_push(args, &pic_sym(sym)); + } + if (pic_nil_p(v)) { + *varg = false; + } + else if (pic_sym_p(v)) { + *varg = true; + xv_push(locals, &pic_sym(v)); + } + else { + return false; + } + + return true; +} + +static bool +push_scope(analyze_state *state, pic_value formals) +{ + pic_state *pic = state->pic; + analyze_scope *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)); + + if (analyze_args(pic, formals, &varg, &args, &locals)) { + scope = pic_alloc(pic, sizeof(analyze_scope)); + 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; + + state->scope = scope; + + return true; + } + else { + xv_destroy(&args); + xv_destroy(&locals); + return false; + } +} + +static void +pop_scope(analyze_state *state) +{ + analyze_scope *scope; + + scope = state->scope; + xv_destroy(&scope->args); + xv_destroy(&scope->locals); + xv_destroy(&scope->captures); + + scope = scope->up; + pic_free(state->pic, state->scope); + state->scope = scope; +} + +static bool +lookup_scope(analyze_scope *scope, pic_sym sym) +{ + pic_sym *arg, *local; + size_t i; + + /* args */ + for (i = 0; i < scope->args.size; ++i) { + arg = xv_get(&scope->args, i); + if (*arg == sym) + return true; + } + /* locals */ + for (i = 0; i < scope->locals.size; ++i) { + local = xv_get(&scope->locals, i); + if (*local == sym) + return true; + } + return false; +} + +static void +capture_var(analyze_scope *scope, pic_sym sym) +{ + pic_sym *var; + size_t i; + + for (i = 0; i < scope->captures.size; ++i) { + var = xv_get(&scope->captures, i); + if (*var == sym) { + break; + } + } + if (i == scope->captures.size) { + xv_push(&scope->captures, &sym); + } +} + +static int +find_var(analyze_state *state, pic_sym sym) +{ + analyze_scope *scope = state->scope; + int depth = 0; + + while (scope) { + if (lookup_scope(scope, sym)) { + if (depth > 0) { + capture_var(scope, sym); + } + return depth; + } + depth++; + scope = scope->up; + } + return -1; +} + +static void +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)); + return; + } + + xv_push(&scope->locals, &sym); +} + +static pic_value analyze_node(analyze_state *, pic_value, bool); + +static pic_value +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; + + res = analyze_node(state, obj, tailpos); + + tag = pic_sym(pic_car(pic, res)); + if (tailpos) { + if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sTAILCALL_WITH_VALUES || tag == state->sRETURN) { + /* pass through */ + } + else { + res = pic_list2(pic, pic_symbol_value(state->sRETURN), res); + } + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, res); + return res; +} + +static pic_value +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)); +} + +static pic_value +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)); +} + +static pic_value +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)); +} + +static pic_value +analyze_var(analyze_state *state, pic_sym sym) +{ + pic_state *pic = state->pic; + int depth; + + if ((depth = find_var(state, sym)) == -1) { + pic_errorf(pic, "unbound variable %s", pic_symbol_name(pic, sym)); + } + + if (depth == state->scope->depth) { + return analyze_global_var(state, sym); + } else if (depth == 0) { + return analyze_local_var(state, sym); + } else { + return analyze_free_var(state, sym, depth); + } +} + +static pic_value +analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_value body_exprs) +{ + pic_state *pic = state->pic; + pic_value args, locals, varg, captures, body; + + assert(pic_sym_p(name) || pic_false_p(name)); + + if (push_scope(state, formals)) { + analyze_scope *scope = state->scope; + pic_sym *var; + size_t i; + + args = pic_nil_value(); + for (i = scope->args.size; i > 0; --i) { + var = xv_get(&scope->args, i - 1); + pic_push(pic, pic_sym_value(*var), args); + } + + varg = scope->varg + ? pic_true_value() + : 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); + + locals = pic_nil_value(); + for (i = scope->locals.size; i > 0; --i) { + var = xv_get(&scope->locals, i - 1); + pic_push(pic, pic_sym_value(*var), locals); + } + + captures = pic_nil_value(); + for (i = scope->captures.size; i > 0; --i) { + var = xv_get(&scope->captures, i - 1); + pic_push(pic, pic_sym_value(*var), captures); + } + + pop_scope(state); + } + else { + pic_errorf(pic, "invalid formal syntax: ~s", args); + } + + return pic_list7(pic, pic_sym_value(pic->sLAMBDA), name, args, locals, varg, captures, body); +} + +static pic_value +analyze_lambda(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value formals, body_exprs; + + if (pic_length(pic, obj) < 2) { + pic_error(pic, "syntax error"); + } + + formals = pic_list_ref(pic, obj, 1); + body_exprs = pic_list_tail(pic, obj, 2); + + return analyze_procedure(state, pic_false_value(), formals, body_exprs); +} + +static pic_value +analyze_declare(analyze_state *state, pic_sym var) +{ + define_var(state, var); + + return analyze_var(state, var); +} + +static pic_value +analyze_define(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value var, val; + pic_sym sym; + + if (pic_length(pic, obj) != 3) { + pic_error(pic, "syntax error"); + } + + var = pic_list_ref(pic, obj, 1); + if (! pic_sym_p(var)) { + pic_error(pic, "syntax error"); + } else { + sym = pic_sym(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_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_procedure(state, pic_sym_value(sym), formals, body_exprs); + } else { + if (pic_length(pic, obj) != 3) { + pic_error(pic, "syntax error"); + } + val = analyze(state, pic_list_ref(pic, obj, 2), false); + } + + return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); +} + +static pic_value +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(); + switch (pic_length(pic, obj)) { + default: + pic_error(pic, "syntax error"); + break; + case 4: + if_false = pic_list_ref(pic, obj, 3); + FALLTHROUGH; + case 3: + if_true = pic_list_ref(pic, obj, 2); + } + + /* analyze in order */ + cond = analyze(state, pic_list_ref(pic, obj, 1), false); + 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); +} + +static pic_value +analyze_begin(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value seq; + bool tail; + + switch (pic_length(pic, obj)) { + case 1: + return analyze(state, pic_none_value(), tailpos); + case 2: + return analyze(state, pic_list_ref(pic, obj, 1), tailpos); + default: + seq = pic_list1(pic, pic_symbol_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; + } else { + tail = false; + } + seq = pic_cons(pic, analyze(state, pic_car(pic, obj), tail), seq); + } + return pic_reverse(pic, seq); + } +} + +static pic_value +analyze_set(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value var, val; + + if (pic_length(pic, obj) != 3) { + pic_error(pic, "syntax error"); + } + + var = pic_list_ref(pic, obj, 1); + if (! pic_sym_p(var)) { + pic_error(pic, "syntax error"); + } + + val = pic_list_ref(pic, obj, 2); + + var = analyze(state, var, false); + val = analyze(state, val, false); + + return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); +} + +static pic_value +analyze_quote(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + + if (pic_length(pic, obj) != 2) { + pic_error(pic, "syntax error"); + } + return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); +} + +#define ARGC_ASSERT_GE(n) do { \ + if (pic_length(pic, obj) < (n) + 1) { \ + pic_error(pic, "wrong number of arguments"); \ + } \ + } 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) + +static pic_value +analyze_add(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value args, arg; + + ARGC_ASSERT_GE(0); + switch (pic_length(pic, obj)) { + case 1: + return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(0)); + case 2: + return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); + default: + args = pic_cdr(pic, obj); + FOLD_ARGS(pic->sADD); + return obj; + } +} + +static pic_value +analyze_sub(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value args, arg; + + ARGC_ASSERT_GE(1); + switch (pic_length(pic, obj)) { + case 2: + return pic_list2(pic, pic_symbol_value(pic->sMINUS), + analyze(state, pic_car(pic, pic_cdr(pic, obj)), false)); + default: + args = pic_cdr(pic, obj); + FOLD_ARGS(pic->sSUB); + return obj; + } +} + +static pic_value +analyze_mul(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value args, arg; + + ARGC_ASSERT_GE(0); + switch (pic_length(pic, obj)) { + case 1: + return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(1)); + case 2: + return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); + default: + args = pic_cdr(pic, obj); + FOLD_ARGS(pic->sMUL); + return obj; + } +} + +static pic_value +analyze_div(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value args, arg; + + ARGC_ASSERT_GE(1); + switch (pic_length(pic, obj)) { + case 2: + args = pic_cdr(pic, obj); + obj = pic_list3(pic, pic_car(pic, obj), pic_float_value(1), pic_car(pic, args)); + return analyze(state, obj, false); + default: + args = pic_cdr(pic, obj); + FOLD_ARGS(pic->sDIV); + return obj; + } +} + +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; + + if (! tailpos) { + call = state->sCALL; + } else { + call = state->sTAILCALL; + } + seq = pic_list1(pic, pic_symbol_value(call)); + pic_for_each (elt, obj) { + seq = pic_cons(pic, analyze(state, elt, false), seq); + } + return pic_reverse(pic, seq); +} + +static pic_value +analyze_values(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value v, seq; + + 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_cons(pic, analyze(state, v, false), seq); + } + return pic_reverse(pic, seq); +} + +static pic_value +analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value prod, cnsm; + pic_sym call; + + if (pic_length(pic, obj) != 3) { + pic_error(pic, "wrong number of arguments"); + } + + if (! tailpos) { + call = state->sCALL_WITH_VALUES; + } else { + call = state->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); +} + +#define ARGC_ASSERT(n) do { \ + if (pic_length(pic, obj) != (n) + 1) { \ + pic_error(pic, "wrong number of arguments"); \ + } \ + } 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_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)) + +static pic_value +analyze_node(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + + switch (pic_type(obj)) { + case PIC_TT_SYMBOL: { + return analyze_var(state, pic_sym(obj)); + } + case PIC_TT_PAIR: { + pic_value proc; + + if (! pic_list_p(obj)) { + pic_errorf(pic, "invalid expression given: ~s", obj); + } + + proc = pic_list_ref(pic, obj, 0); + if (pic_sym_p(proc)) { + pic_sym sym = pic_sym(proc); + + if (sym == pic->rDEFINE) { + return analyze_define(state, obj); + } + else if (sym == pic->rLAMBDA) { + return analyze_lambda(state, obj); + } + else if (sym == pic->rIF) { + return analyze_if(state, obj, tailpos); + } + else if (sym == pic->rBEGIN) { + return analyze_begin(state, obj, tailpos); + } + else if (sym == pic->rSETBANG) { + return analyze_set(state, obj); + } + else if (sym == pic->rQUOTE) { + return analyze_quote(state, obj); + } + else if (sym == state->rCONS) { + ARGC_ASSERT(2); + return CONSTRUCT_OP2(pic->sCONS); + } + else if (sym == state->rCAR) { + ARGC_ASSERT(1); + return CONSTRUCT_OP1(pic->sCAR); + } + else if (sym == state->rCDR) { + ARGC_ASSERT(1); + return CONSTRUCT_OP1(pic->sCDR); + } + else if (sym == state->rNILP) { + ARGC_ASSERT(1); + return CONSTRUCT_OP1(pic->sNILP); + } + else if (sym == state->rADD) { + return analyze_add(state, obj, tailpos); + } + else if (sym == state->rSUB) { + return analyze_sub(state, obj); + } + else if (sym == state->rMUL) { + return analyze_mul(state, obj, tailpos); + } + else if (sym == state->rDIV) { + return analyze_div(state, obj); + } + else if (sym == state->rEQ) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sEQ); + } + else if (sym == state->rLT) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sLT); + } + else if (sym == state->rLE) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sLE); + } + else if (sym == state->rGT) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sGT); + } + else if (sym == state->rGE) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sGE); + } + else if (sym == state->rNOT) { + ARGC_ASSERT(1); + return CONSTRUCT_OP1(pic->sNOT); + } + else if (sym == state->rVALUES) { + return analyze_values(state, obj, tailpos); + } + else if (sym == state->rCALL_WITH_VALUES) { + return analyze_call_with_values(state, obj, tailpos); + } + } + fallback: + + return analyze_call(state, obj, tailpos); + } + default: + return pic_list2(pic, pic_symbol_value(pic->sQUOTE), obj); + } +} + +pic_value +pic_analyze(pic_state *pic, pic_value obj) +{ + analyze_state *state; + + state = new_analyze_state(pic); + + obj = analyze(state, obj, true); + + destroy_analyze_state(state); + return obj; +} + +/** + * scope object + */ + +typedef struct codegen_context { + pic_sym name; + /* rest args variable is counted as a local */ + bool varg; + xvect args, locals, captures; + /* actual bit code sequence */ + pic_code *code; + size_t clen, ccapa; + /* child ireps */ + struct pic_irep **irep; + size_t ilen, icapa; + /* constant object pool */ + pic_value *pool; + size_t plen, pcapa; + + struct codegen_context *up; +} codegen_context; + +/** + * global codegen state + */ + +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); +static struct pic_irep *pop_codegen_context(codegen_state *); + +static codegen_state * +new_codegen_state(pic_state *pic) +{ + codegen_state *state; + + state = pic_alloc(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; +} + +static struct pic_irep * +destroy_codegen_state(codegen_state *state) +{ + pic_state *pic = state->pic; + struct pic_irep *irep; + + irep = pop_codegen_context(state); + pic_free(pic, state); + + return irep; +} + +static void +create_activation(codegen_context *cxt) +{ + size_t i, n; + xhash regs; + pic_sym *var; + size_t offset; + + xh_init_int(®s, sizeof(size_t)); + + offset = 1; + for (i = 0; i < cxt->args.size; ++i) { + var = xv_get(&cxt->args, i); + n = i + offset; + xh_put_int(®s, *var, &n); + } + offset += i; + for (i = 0; i < cxt->locals.size; ++i) { + var = xv_get(&cxt->locals, i); + n = i + offset; + xh_put_int(®s, *var, &n); + } + + for (i = 0; i < cxt->captures.size; ++i) { + var = xv_get(&cxt->captures, i); + if ((n = xh_val(xh_get_int(®s, *var), size_t)) <= cxt->args.size || (cxt->varg && n == cxt->args.size + 1)) { + /* copy arguments to capture variable area */ + cxt->code[cxt->clen].insn = OP_LREF; + cxt->code[cxt->clen].u.i = n; + cxt->clen++; + } else { + /* otherwise, just extend the stack */ + cxt->code[cxt->clen].insn = OP_PUSHNONE; + cxt->clen++; + } + } + + xh_destroy(®s); +} + +static void +push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_value locals, bool varg, pic_value captures) +{ + pic_state *pic = state->pic; + codegen_context *cxt; + pic_value var; + + assert(pic_sym_p(name) || pic_false_p(name)); + + cxt = pic_alloc(pic, sizeof(codegen_context)); + cxt->up = state->cxt; + cxt->name = pic_false_p(name) + ? pic_intern_cstr(pic, "(anonymous lambda)") + : pic_sym(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)); + + pic_for_each (var, args) { + xv_push(&cxt->args, &pic_sym(var)); + } + pic_for_each (var, locals) { + xv_push(&cxt->locals, &pic_sym(var)); + } + pic_for_each (var, captures) { + xv_push(&cxt->captures, &pic_sym(var)); + } + + cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); + cxt->clen = 0; + cxt->ccapa = PIC_ISEQ_SIZE; + + cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(struct pic_irep *)); + cxt->ilen = 0; + cxt->icapa = PIC_IREP_SIZE; + + cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(pic_value)); + cxt->plen = 0; + cxt->pcapa = PIC_POOL_SIZE; + + state->cxt = cxt; + + create_activation(cxt); +} + +static struct pic_irep * +pop_codegen_context(codegen_state *state) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + struct pic_irep *irep; + + /* create irep */ + 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 = state->cxt->args.size + 1; + irep->localc = state->cxt->locals.size; + irep->capturec = state->cxt->captures.size; + 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; + + /* finalize */ + xv_destroy(&cxt->args); + xv_destroy(&cxt->locals); + xv_destroy(&cxt->captures); + + /* destroy context */ + cxt = cxt->up; + pic_free(pic, state->cxt); + state->cxt = cxt; + + return irep; +} + +static int +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 < cxt->captures.size; ++i) { + var = xv_get(&cxt->captures, i); + if (*var == sym) + return i; + } + return -1; +} + +static int +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 < cxt->args.size; ++i) { + var = xv_get(&cxt->args, i); + if (*var == sym) + return i + offset; + } + offset += i; + for (i = 0; i < cxt->locals.size; ++i) { + var = xv_get(&cxt->locals, i); + if (*var == sym) + return i + offset; + } + return -1; +} + +static struct pic_irep *codegen_lambda(codegen_state *, pic_value); + +static void +codegen(codegen_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + 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++; + return; + } else if (sym == state->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++; + return; + } else if (sym == state->sLREF) { + pic_sym name; + int i; + + name = pic_sym(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 + cxt->args.size + cxt->locals.size + 1; + cxt->clen++; + return; + } + cxt->code[cxt->clen].insn = OP_LREF; + cxt->code[cxt->clen].u.i = index_local(state, name); + cxt->clen++; + return; + } else if (sym == pic->sSETBANG) { + pic_value var, val; + 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++; + return; + } + else if (type == state->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++; + return; + } + else if (type == state->sLREF) { + pic_sym name; + int i; + + name = pic_sym(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 + cxt->args.size + cxt->locals.size + 1; + cxt->clen++; + cxt->code[cxt->clen].insn = OP_PUSHNONE; + cxt->clen++; + 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++; + return; + } + } + else if (sym == pic->sLAMBDA) { + int k; + + if (cxt->ilen >= cxt->icapa) { + cxt->icapa *= 2; + cxt->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->icapa); + } + k = cxt->ilen++; + cxt->code[cxt->clen].insn = OP_LAMBDA; + cxt->code[cxt->clen].u.i = k; + cxt->clen++; + + cxt->irep[k] = codegen_lambda(state, obj); + return; + } + else if (sym == pic->sIF) { + int s, t; + + codegen(state, pic_list_ref(pic, obj, 1)); + + cxt->code[cxt->clen].insn = OP_JMPIF; + s = cxt->clen++; + + /* if false branch */ + codegen(state, pic_list_ref(pic, obj, 3)); + cxt->code[cxt->clen].insn = OP_JMP; + t = cxt->clen++; + + cxt->code[s].u.i = cxt->clen - s; + + /* if true branch */ + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[t].u.i = cxt->clen - t; + return; + } + else if (sym == pic->sBEGIN) { + pic_value elt; + int i = 0; + + pic_for_each (elt, pic_cdr(pic, obj)) { + if (i++ != 0) { + cxt->code[cxt->clen].insn = OP_POP; + cxt->clen++; + } + codegen(state, elt); + } + return; + } + else if (sym == pic->sQUOTE) { + int pidx; + + 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++; + return; + case PIC_TT_INT: + cxt->code[cxt->clen].insn = OP_PUSHINT; + cxt->code[cxt->clen].u.i = pic_int(obj); + cxt->clen++; + return; + case PIC_TT_NIL: + cxt->code[cxt->clen].insn = OP_PUSHNIL; + cxt->clen++; + return; + case PIC_TT_CHAR: + cxt->code[cxt->clen].insn = OP_PUSHCHAR; + cxt->code[cxt->clen].u.c = pic_char(obj); + cxt->clen++; + return; + default: + if (cxt->plen >= cxt->pcapa) { + cxt->pcapa *= 2; + cxt->pool = pic_realloc(pic, cxt->pool, sizeof(pic_value) * cxt->pcapa); + } + pidx = cxt->plen++; + cxt->pool[pidx] = obj; + cxt->code[cxt->clen].insn = OP_PUSHCONST; + cxt->code[cxt->clen].u.i = pidx; + cxt->clen++; + 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++; + return; + } + else if (sym == pic->sCAR) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_CAR; + cxt->clen++; + return; + } + else if (sym == pic->sCDR) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_CDR; + cxt->clen++; + return; + } + else if (sym == pic->sNILP) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_NILP; + cxt->clen++; + 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++; + 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++; + 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++; + 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++; + return; + } + else if (sym == pic->sMINUS) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_MINUS; + cxt->clen++; + 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++; + 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++; + 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++; + 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++; + 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++; + return; + } + else if (sym == pic->sNOT) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_NOT; + cxt->clen++; + return; + } + else if (sym == state->sCALL || sym == state->sTAILCALL) { + int len = pic_length(pic, obj); + pic_value elt; + + pic_for_each (elt, pic_cdr(pic, obj)) { + 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++; + return; + } + else if (sym == state->sCALL_WITH_VALUES || sym == state->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++; + /* 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++; + return; + } + else if (sym == state->sRETURN) { + int len = pic_length(pic, obj); + pic_value elt; + + pic_for_each (elt, pic_cdr(pic, obj)) { + codegen(state, elt); + } + cxt->code[cxt->clen].insn = OP_RET; + cxt->code[cxt->clen].u.i = len - 1; + cxt->clen++; + return; + } + pic_error(pic, "codegen: unknown AST type"); +} + +static struct pic_irep * +codegen_lambda(codegen_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value name, args, locals, closes, body; + bool varg; + + name = pic_list_ref(pic, obj, 1); + args = pic_list_ref(pic, obj, 2); + locals = pic_list_ref(pic, obj, 3); + varg = pic_true_p(pic_list_ref(pic, obj, 4)); + closes = pic_list_ref(pic, obj, 5); + body = pic_list_ref(pic, obj, 6); + + /* inner environment */ + push_codegen_context(state, name, args, locals, varg, closes); + { + /* body */ + codegen(state, body); + } + return pop_codegen_context(state); +} + +struct pic_irep * +pic_codegen(pic_state *pic, pic_value obj) +{ + codegen_state *state; + + state = new_codegen_state(pic); + + codegen(state, obj); + + return destroy_codegen_state(state); +} + +struct pic_proc * +pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) +{ + struct pic_irep *irep; + size_t ai = pic_gc_arena_preserve(pic); + +#if DEBUG + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); + + fprintf(stdout, "# input expression\n"); + pic_debug(pic, obj); + fprintf(stdout, "\n"); + + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); +#endif + + /* macroexpand */ + obj = pic_macroexpand(pic, obj, lib); +#if DEBUG + fprintf(stdout, "## macroexpand completed\n"); + pic_debug(pic, obj); + fprintf(stdout, "\n"); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); +#endif + + /* analyze */ + obj = pic_analyze(pic, obj); +#if DEBUG + fprintf(stdout, "## analyzer completed\n"); + pic_debug(pic, obj); + fprintf(stdout, "\n"); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); +#endif + + /* codegen */ + irep = pic_codegen(pic, obj); +#if DEBUG + fprintf(stdout, "## codegen completed\n"); + pic_dump_irep(irep); +#endif + +#if DEBUG + fprintf(stdout, "# compilation finished\n"); + puts(""); +#endif + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, pic_obj_value(irep)); + + return pic_proc_new_irep(pic, irep, NULL); +} diff --git a/cont.c b/cont.c new file mode 100644 index 00000000..30d26568 --- /dev/null +++ b/cont.c @@ -0,0 +1,371 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/proc.h" +#include "picrin/cont.h" +#include "picrin/pair.h" +#include "picrin/error.h" + +pic_value +pic_values0(pic_state *pic) +{ + return pic_values_by_list(pic, pic_nil_value()); +} + +pic_value +pic_values1(pic_state *pic, pic_value arg1) +{ + return pic_values_by_list(pic, pic_list1(pic, arg1)); +} + +pic_value +pic_values2(pic_state *pic, pic_value arg1, pic_value arg2) +{ + return pic_values_by_list(pic, pic_list2(pic, arg1, arg2)); +} + +pic_value +pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3) +{ + return pic_values_by_list(pic, pic_list3(pic, arg1, arg2, arg3)); +} + +pic_value +pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) +{ + return pic_values_by_list(pic, pic_list4(pic, arg1, arg2, arg3, arg4)); +} + +pic_value +pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) +{ + return pic_values_by_list(pic, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); +} + +pic_value +pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv) +{ + size_t i; + + for (i = 0; i < argc; ++i) { + pic->sp[i] = argv[i]; + } + pic->ci->retc = argc; + + return argc == 0 ? pic_none_value() : pic->sp[0]; +} + +pic_value +pic_values_by_list(pic_state *pic, pic_value list) +{ + pic_value v; + size_t i; + + i = 0; + pic_for_each (v, list) { + pic->sp[i++] = v; + } + pic->ci->retc = i; + + return pic_nil_p(list) ? pic_none_value() : pic->sp[0]; +} + +size_t +pic_receive(pic_state *pic, size_t n, pic_value *argv) +{ + pic_callinfo *ci; + size_t i, retc; + + /* take info from discarded frame */ + ci = pic->ci + 1; + retc = ci->retc; + + for (i = 0; i < retc && i < n; ++i) { + argv[i] = ci->fp[i]; + } + + return retc; +} + +static void save_cont(pic_state *, struct pic_cont **); +static void restore_cont(pic_state *, struct pic_cont *); + +static ptrdiff_t +native_stack_length(pic_state *pic, char **pos) +{ + char t; + + *pos = (pic->native_stack_start > &t) + ? &t + : pic->native_stack_start; + + return (pic->native_stack_start > &t) + ? pic->native_stack_start - &t + : &t - pic->native_stack_start; +} + +static void +save_cont(pic_state *pic, struct pic_cont **c) +{ + struct pic_cont *cont; + char *pos; + + cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT); + + cont->blk = pic->blk; + + 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); + 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_value *)pic_alloc(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_callinfo *)pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len); + memcpy(cont->ci_ptr, pic->cibase, sizeof(pic_callinfo) * cont->ci_len); + + cont->ip = pic->ip; + + cont->arena_idx = pic->arena_idx; + cont->arena_size = pic->arena_size; + cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size); + memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size); + + cont->try_jmp_idx = pic->try_jmp_idx; + cont->try_jmp_size = pic->try_jmp_size; + cont->try_jmps = pic_alloc(pic, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + memcpy(cont->try_jmps, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + + cont->results = pic_undef_value(); +} + +static void +native_stack_extend(pic_state *pic, struct pic_cont *cont) +{ + volatile pic_value v[1024]; + + ((void)v); + restore_cont(pic, cont); +} + +noreturn static void +restore_cont(pic_state *pic, struct pic_cont *cont) +{ + void pic_vm_tear_off(pic_state *); + char v; + struct pic_cont *tmp = cont; + struct pic_block *blk; + + pic_vm_tear_off(pic); /* tear off */ + + if (&v < pic->native_stack_start) { + if (&v > cont->stk_pos) native_stack_extend(pic, cont); + } + else { + if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); + } + + blk = pic->blk; + pic->blk = cont->blk; + + pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len); + memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len); + pic->sp = pic->stbase + cont->sp_offset; + pic->stend = pic->stbase + cont->st_len; + + pic->cibase = (pic_callinfo *)pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len); + memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * cont->ci_len); + pic->ci = pic->cibase + cont->ci_offset; + pic->ciend = pic->cibase + cont->ci_len; + + pic->ip = cont->ip; + + pic->arena = (struct pic_object **)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; + pic->arena_idx = cont->arena_idx; + + pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size); + memcpy(pic->try_jmps, cont->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size); + pic->try_jmp_size = cont->try_jmp_size; + pic->try_jmp_idx = cont->try_jmp_idx; + + memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len); + + longjmp(tmp->jmp, 1); +} + +static void +walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there) +{ + if (here == there) + return; + + if (here->depth < there->depth) { + walk_to_block(pic, here, there->prev); + pic_apply0(pic, there->in); + } + else { + pic_apply0(pic, there->out); + walk_to_block(pic, here->prev, there); + } +} + +static pic_value +pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out) +{ + struct pic_block *here; + pic_value val; + + if (in != NULL) { + pic_apply0(pic, in); /* enter */ + } + + here = pic->blk; + pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK); + pic->blk->prev = here; + pic->blk->depth = here->depth + 1; + pic->blk->in = in; + pic->blk->out = out; + + val = pic_apply0(pic, thunk); + + pic->blk = here; + + if (out != NULL) { + pic_apply0(pic, out); /* exit */ + } + + return val; +} + +noreturn static pic_value +cont_call(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc; + pic_value *argv; + struct pic_cont *cont; + + proc = pic_get_proc(pic); + pic_get_args(pic, "*", &argc, &argv); + + cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont")); + cont->results = pic_list_by_array(pic, argc, argv); + + /* execute guard handlers */ + walk_to_block(pic, pic->blk, cont->blk); + + restore_cont(pic, cont); +} + +pic_value +pic_callcc(pic_state *pic, struct pic_proc *proc) +{ + struct pic_cont *cont; + + save_cont(pic, &cont); + if (setjmp(cont->jmp)) { + return pic_values_by_list(pic, cont->results); + } + else { + struct pic_proc *c; + + c = pic_proc_new(pic, cont_call, ""); + + /* save the continuation object in proc */ + pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); + + return pic_apply1(pic, proc, pic_obj_value(c)); + } +} + +static pic_value +pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc) +{ + struct pic_cont *cont; + + save_cont(pic, &cont); + if (setjmp(cont->jmp)) { + return pic_values_by_list(pic, cont->results); + } + else { + struct pic_proc *c; + + c = pic_proc_new(pic, cont_call, ""); + + /* save the continuation object in proc */ + pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); + + return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c))); + } +} + +static pic_value +pic_cont_callcc(pic_state *pic) +{ + struct pic_proc *cb; + + pic_get_args(pic, "l", &cb); + + return pic_callcc_trampoline(pic, cb); +} + +static pic_value +pic_cont_dynamic_wind(pic_state *pic) +{ + struct pic_proc *in, *thunk, *out; + + pic_get_args(pic, "lll", &in, &thunk, &out); + + return pic_dynamic_wind(pic, in, thunk, out); +} + +static pic_value +pic_cont_values(pic_state *pic) +{ + size_t argc; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + return pic_values_by_array(pic, argc, argv); +} + +static pic_value +pic_cont_call_with_values(pic_state *pic) +{ + struct pic_proc *producer, *consumer; + size_t argc; + pic_value args[256]; + + pic_get_args(pic, "ll", &producer, &consumer); + + pic_apply(pic, producer, pic_nil_value()); + + argc = pic_receive(pic, 256, args); + + return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args)); +} + +void +pic_init_cont(pic_state *pic) +{ + 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); +} diff --git a/data.c b/data.c new file mode 100644 index 00000000..5d586c56 --- /dev/null +++ b/data.c @@ -0,0 +1,15 @@ +#include "picrin.h" +#include "picrin/data.h" + +struct pic_data * +pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata) +{ + struct pic_data *data; + + data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA); + data->type = type; + data->data = userdata; + xh_init_str(&data->storage, sizeof(pic_value)); + + return data; +} diff --git a/debug.c b/debug.c new file mode 100644 index 00000000..f59a4125 --- /dev/null +++ b/debug.c @@ -0,0 +1,74 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/string.h" +#include "picrin/error.h" +#include "picrin/proc.h" + +pic_str * +pic_get_backtrace(pic_state *pic) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_callinfo *ci; + pic_str *trace; + + trace = pic_str_new(pic, NULL, 0); + + for (ci = pic->ci; ci != pic->cibase; --ci) { + struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); + + trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " at ")); + trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc)))); + + if (pic_proc_func_p(proc)) { + trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (native function)\n")); + } else if (pic_proc_irep_p(proc)) { + trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (unknown location)\n")); /* TODO */ + } + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, pic_obj_value(trace)); + + return trace; +} + +void +pic_print_backtrace(pic_state *pic, struct pic_error *e) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_str *trace; + + assert(pic->err != NULL); + + trace = pic_str_new(pic, NULL, 0); + + switch (e->type) { + case PIC_ERROR_OTHER: + trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "error: ")); + break; + case PIC_ERROR_FILE: + trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "file error: ")); + break; + case PIC_ERROR_READ: + trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "read error: ")); + break; + case PIC_ERROR_RAISED: + trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "raised: ")); + break; + } + + trace = pic_strcat(pic, trace, e->msg); + + /* TODO: print error irritants */ + + trace = pic_strcat(pic, trace, pic_str_new(pic, "\n", 1)); + trace = pic_strcat(pic, trace, e->stack); + + /* print! */ + printf("%s", pic_str_cstr(trace)); + + pic_gc_arena_restore(pic, ai); +} diff --git a/dict.c b/dict.c new file mode 100644 index 00000000..1018834e --- /dev/null +++ b/dict.c @@ -0,0 +1,176 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/dict.h" + +struct pic_dict * +pic_dict_new(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)); + + return dict; +} + +pic_value +pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym key) +{ + xh_entry *e; + + e = xh_get_int(&dict->hash, key); + if (! e) { + pic_errorf(pic, "element not found for a key: ~s", pic_sym_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) +{ + UNUSED(pic); + + xh_put_int(&dict->hash, key, &val); +} + +size_t +pic_dict_size(pic_state *pic, struct pic_dict *dict) +{ + UNUSED(pic); + + return dict->hash.count; +} + +bool +pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key) +{ + UNUSED(pic); + + return xh_get_int(&dict->hash, key) != NULL; +} + +void +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)); + } + + xh_del_int(&dict->hash, key); +} + +static pic_value +pic_dict_dict(pic_state *pic) +{ + struct pic_dict *dict; + + pic_get_args(pic, ""); + + dict = pic_dict_new(pic); + + return pic_obj_value(dict); +} + +static pic_value +pic_dict_dict_p(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_bool_value(pic_dict_p(obj)); +} + +static pic_value +pic_dict_dict_ref(pic_state *pic) +{ + struct pic_dict *dict; + pic_sym key; + + pic_get_args(pic, "dm", &dict, &key); + + return pic_dict_ref(pic, dict , key); +} + +static pic_value +pic_dict_dict_set(pic_state *pic) +{ + struct pic_dict *dict; + 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_dict_has_p(pic_state *pic) +{ + struct pic_dict *dict; + pic_sym key; + + pic_get_args(pic, "dm", &dict, &key); + + return pic_bool_value(pic_dict_has(pic, dict, key)); +} + +static pic_value +pic_dict_dict_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(); +} + +static pic_value +pic_dict_dict_size(pic_state *pic) +{ + struct pic_dict *dict; + + pic_get_args(pic, "d", &dict); + + return pic_int_value(pic_dict_size(pic, dict)); +} + +static pic_value +pic_dict_dict_for_each(pic_state *pic) +{ + struct pic_proc *proc; + struct pic_dict *dict; + xh_iter it; + + pic_get_args(pic, "ld", &proc, &dict); + + xh_begin(&it, &dict->hash); + while (xh_next(&it)) { + pic_apply2(pic, proc, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); + } + + return pic_none_value(); +} + +void +pic_init_dict(pic_state *pic) +{ + pic_deflibrary (pic, "(picrin dictionary)") { + pic_defun(pic, "make-dictionary", pic_dict_dict); + pic_defun(pic, "dictionary?", pic_dict_dict_p); + pic_defun(pic, "dictionary-has?", pic_dict_dict_has_p); + pic_defun(pic, "dictionary-ref", pic_dict_dict_ref); + pic_defun(pic, "dictionary-set!", pic_dict_dict_set); + pic_defun(pic, "dictionary-delete", pic_dict_dict_del); + pic_defun(pic, "dictionary-size", pic_dict_dict_size); + pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each); + } +} diff --git a/error.c b/error.c new file mode 100644 index 00000000..f4d46f5e --- /dev/null +++ b/error.c @@ -0,0 +1,286 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/string.h" +#include "picrin/error.h" + +void +pic_abort(pic_state *pic, const char *msg) +{ + UNUSED(pic); + + fprintf(stderr, "abort: %s\n", msg); + abort(); +} + +void +pic_warnf(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_value err_line; + + va_start(ap, fmt); + err_line = pic_vformat(pic, fmt, ap); + va_end(ap); + + fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)))); +} + +void +pic_push_try(pic_state *pic, struct pic_proc *handler) +{ + struct pic_jmpbuf *try_jmp; + + if (pic->try_jmp_idx >= pic->try_jmp_size) { + pic->try_jmp_size *= 2; + pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + } + + try_jmp = pic->try_jmps + pic->try_jmp_idx++; + + try_jmp->handler = handler; + + try_jmp->ci_offset = pic->ci - pic->cibase; + try_jmp->sp_offset = pic->sp - pic->stbase; + try_jmp->ip = pic->ip; + + try_jmp->prev_jmp = pic->jmp; + pic->jmp = &try_jmp->here; +} + +void +pic_pop_try(pic_state *pic) +{ + struct pic_jmpbuf *try_jmp; + + try_jmp = pic->try_jmps + --pic->try_jmp_idx; + + /* assert(pic->jmp == &try_jmp->here); */ + + pic->ci = try_jmp->ci_offset + pic->cibase; + pic->sp = try_jmp->sp_offset + pic->stbase; + pic->ip = try_jmp->ip; + + pic->jmp = try_jmp->prev_jmp; +} + +static struct pic_error * +error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs) +{ + struct pic_error *e; + pic_str *stack; + + stack = pic_get_backtrace(pic); + + e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR); + e->type = type; + e->msg = msg; + e->irrs = irrs; + e->stack = stack; + + return e; +} + +noreturn void +pic_throw_error(pic_state *pic, struct pic_error *e) +{ + void pic_vm_tear_off(pic_state *); + + pic_vm_tear_off(pic); /* tear off */ + + pic->err = e; + if (! pic->jmp) { + puts(pic_errmsg(pic)); + abort(); + } + + longjmp(*pic->jmp, 1); +} + +noreturn void +pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs) +{ + struct pic_error *e; + + e = error_new(pic, type, pic_str_new_cstr(pic, msg), irrs); + + pic_throw_error(pic, e); +} + +const char * +pic_errmsg(pic_state *pic) +{ + assert(pic->err != NULL); + + return pic_str_cstr(pic->err->msg); +} + +void +pic_errorf(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_value err_line, irrs; + const char *msg; + + va_start(ap, fmt); + err_line = pic_vformat(pic, fmt, ap); + va_end(ap); + + msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))); + irrs = pic_cdr(pic, err_line); + + pic_throw(pic, PIC_ERROR_OTHER, msg, irrs); +} + +static pic_value +pic_error_with_exception_handler(pic_state *pic) +{ + struct pic_proc *handler, *thunk; + pic_value v; + + pic_get_args(pic, "ll", &handler, &thunk); + + pic_try_with_handler(handler) { + v = pic_apply0(pic, thunk); + } + pic_catch { + struct pic_error *e = pic->err; + + pic->err = NULL; + + if (e->type == PIC_ERROR_RAISED) { + v = pic_list_ref(pic, e->irrs, 0); + } else { + v = pic_obj_value(e); + } + v = pic_apply1(pic, handler, v); + pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e)); + } + return v; +} + +noreturn static pic_value +pic_error_raise(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v)); +} + +static pic_value +pic_error_raise_continuable(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic->try_jmp_idx == 0) { + pic_errorf(pic, "no exception handler registered"); + } + if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) { + pic_errorf(pic, "uncontinuable exception handler is on top"); + } + else { + pic->try_jmp_idx--; + v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v); + ++pic->try_jmp_idx; + } + return v; +} + +noreturn static pic_value +pic_error_error(pic_state *pic) +{ + const char *str; + size_t argc; + pic_value *argv; + + pic_get_args(pic, "z*", &str, &argc, &argv); + + pic_throw(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv)); +} + +static pic_value +pic_error_error_object_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_error_p(v)); +} + +static pic_value +pic_error_error_object_message(pic_state *pic) +{ + struct pic_error *e; + + pic_get_args(pic, "e", &e); + + return pic_obj_value(e->msg); +} + +static pic_value +pic_error_error_object_irritants(pic_state *pic) +{ + struct pic_error *e; + + pic_get_args(pic, "e", &e); + + return e->irrs; +} + +static pic_value +pic_error_read_error_p(pic_state *pic) +{ + pic_value v; + struct pic_error *e; + + pic_get_args(pic, "o", &v); + + if (! pic_error_p(v)) { + return pic_false_value(); + } + + e = pic_error_ptr(v); + return pic_bool_value(e->type == PIC_ERROR_READ); +} + +static pic_value +pic_error_file_error_p(pic_state *pic) +{ + pic_value v; + struct pic_error *e; + + pic_get_args(pic, "o", &v); + + if (! pic_error_p(v)) { + return pic_false_value(); + } + + e = pic_error_ptr(v); + return pic_bool_value(e->type == PIC_ERROR_FILE); +} + +void +pic_init_error(pic_state *pic) +{ + pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler); + pic_defun(pic, "raise", pic_error_raise); + pic_defun(pic, "raise-continuable", pic_error_raise_continuable); + pic_defun(pic, "error", pic_error_error); + pic_defun(pic, "error-object?", pic_error_error_object_p); + pic_defun(pic, "error-object-message", pic_error_error_object_message); + pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants); + pic_defun(pic, "read-error?", pic_error_read_error_p); + pic_defun(pic, "file-error?", pic_error_file_error_p); +} diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..5a037c94 --- /dev/null +++ b/eval.c @@ -0,0 +1,39 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/macro.h" + +pic_value +pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) +{ + struct pic_proc *proc; + + proc = pic_compile(pic, program, lib); + + return pic_apply(pic, proc, pic_nil_value()); +} + +static pic_value +pic_eval_eval(pic_state *pic) +{ + pic_value program, spec; + struct pic_lib *lib; + + pic_get_args(pic, "oo", &program, &spec); + + lib = pic_find_library(pic, spec); + if (lib == NULL) { + pic_errorf(pic, "no library found: ~s", spec); + } + return pic_eval(pic, program, lib); +} + +void +pic_init_eval(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme eval)") { + pic_defun(pic, "eval", pic_eval_eval); + } +} diff --git a/file.c b/file.c new file mode 100644 index 00000000..befac195 --- /dev/null +++ b/file.c @@ -0,0 +1,119 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/port.h" +#include "picrin/error.h" + +static noreturn void +file_error(pic_state *pic, const char *msg) +{ + pic_throw(pic, PIC_ERROR_FILE, msg, pic_nil_value()); +} + +static pic_value +generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) +{ + struct pic_port *port; + xFILE *file; + + file = xfopen(fname, mode); + if (! file) { + file_error(pic, "could not open file"); + } + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = flags; + port->status = PIC_PORT_OPEN; + + return pic_obj_value(port); +} + +pic_value +pic_file_open_input_file(pic_state *pic) +{ + static const short flags = PIC_PORT_IN | PIC_PORT_TEXT; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "r", flags); +} + +pic_value +pic_file_open_input_binary_file(pic_state *pic) +{ + static const short flags = PIC_PORT_IN | PIC_PORT_BINARY; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "rb", flags); +} + +pic_value +pic_file_open_output_file(pic_state *pic) +{ + static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "w", flags); +} + +pic_value +pic_file_open_output_binary_file(pic_state *pic) +{ + static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "wb", flags); +} + +pic_value +pic_file_exists_p(pic_state *pic) +{ + char *fname; + FILE *fp; + + pic_get_args(pic, "z", &fname); + + fp = fopen(fname, "r"); + if (fp) { + fclose(fp); + return pic_true_value(); + } else { + return pic_false_value(); + } +} + +pic_value +pic_file_delete(pic_state *pic) +{ + char *fname; + + pic_get_args(pic, "z", &fname); + + if (remove(fname) != 0) { + file_error(pic, "file cannot be deleted"); + } + return pic_none_value(); +} + +void +pic_init_file(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme file)") { + pic_defun(pic, "open-input-file", pic_file_open_input_file); + pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file); + pic_defun(pic, "open-output-file", pic_file_open_output_file); + pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file); + pic_defun(pic, "file-exists?", pic_file_exists_p); + pic_defun(pic, "delete-file", pic_file_delete); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..9a947837 --- /dev/null +++ b/gc.c @@ -0,0 +1,872 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#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/var.h" +#include "picrin/data.h" +#include "picrin/dict.h" +#include "picrin/record.h" +#include "picrin/read.h" + +#if GC_DEBUG +# include +#endif + +union header { + struct { + union header *ptr; + size_t size; + unsigned int mark : 1; + } s; + long alignment[4]; +}; + +struct heap_page { + union header *basep, *endp; + struct heap_page *next; +}; + +struct pic_heap { + union header base, *freep; + struct heap_page *pages; +}; + + +static void +heap_init(struct pic_heap *heap) +{ + heap->base.s.ptr = &heap->base; + heap->base.s.size = 0; /* not 1, since it must never be used for allocation */ + heap->base.s.mark = PIC_GC_UNMARK; + + heap->freep = &heap->base; + heap->pages = NULL; + +#if GC_DEBUG + printf("freep = %p\n", (void *)heap->freep); +#endif +} + +struct pic_heap * +pic_heap_open() +{ + struct pic_heap *heap; + + heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap)); + heap_init(heap); + return heap; +} + +void +pic_heap_close(struct pic_heap *heap) +{ + struct heap_page *page; + + while (heap->pages) { + page = heap->pages; + heap->pages = heap->pages->next; + free(page); + } +} + +static void gc_free(pic_state *, union header *); + +static void +add_heap_page(pic_state *pic) +{ + union header *up, *np; + struct heap_page *page; + size_t nu; + +#if GC_DEBUG + puts("adding heap page!"); +#endif + + 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->s.size = nu + 1; + up->s.mark = PIC_GC_UNMARK; + gc_free(pic, up); + + np = up + 1; + np->s.size = nu; + np->s.ptr = up->s.ptr; + up->s.size = 1; + up->s.ptr = np; + + page = (struct heap_page *)pic_alloc(pic, sizeof(struct heap_page)); + page->basep = up; + page->endp = up + nu + 1; + page->next = pic->heap->pages; + + pic->heap->pages = page; +} + +static void * +alloc(void *ptr, size_t size) +{ + if (size == 0) { + if (ptr) { + free(ptr); + } + return NULL; + } + if (ptr) { + return realloc(ptr, size); + } else { + return malloc(size); + } +} + +void * +pic_alloc(pic_state *pic, size_t size) +{ + void *ptr; + + ptr = alloc(NULL, size); + if (ptr == NULL && size > 0) { + pic_abort(pic, "memory exhausted"); + } + return ptr; +} + +void * +pic_realloc(pic_state *pic, void *ptr, size_t size) +{ + ptr = alloc(ptr, size); + if (ptr == NULL && size > 0) { + pic_abort(pic, "memory exhausted"); + } + return ptr; +} + +void * +pic_calloc(pic_state *pic, size_t count, size_t size) +{ + void *ptr; + + size *= count; + ptr = alloc(NULL, size); + if (ptr == NULL && size > 0) { + pic_abort(pic, "memory exhausted"); + } + memset(ptr, 0, size); + return ptr; +} + +void +pic_free(pic_state *pic, void *ptr) +{ + UNUSED(pic); + + free(ptr); +} + +static void +gc_protect(pic_state *pic, struct pic_object *obj) +{ + if (pic->arena_idx >= pic->arena_size) { + pic->arena_size = pic->arena_size * 2 + 1; + pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * pic->arena_size); + } + pic->arena[pic->arena_idx++] = obj; +} + +pic_value +pic_gc_protect(pic_state *pic, pic_value v) +{ + struct pic_object *obj; + + if (pic_vtype(v) != PIC_VTYPE_HEAP) { + return v; + } + obj = pic_obj_ptr(v); + + gc_protect(pic, obj); + + return v; +} + +size_t +pic_gc_arena_preserve(pic_state *pic) +{ + return pic->arena_idx; +} + +void +pic_gc_arena_restore(pic_state *pic, size_t state) +{ + pic->arena_idx = state; +} + +static void * +gc_alloc(pic_state *pic, size_t size) +{ + union header *freep, *p, *prevp; + size_t nunits; + +#if GC_DEBUG + assert(size > 0); +#endif + + nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1; + + prevp = freep = pic->heap->freep; + for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) { + if (p->s.size >= nunits) + break; + if (p == freep) { + return NULL; + } + } + +#if GC_DEBUG + { + unsigned char *c; + size_t s, i, j; + if (p->s.size == nunits) { + c = (unsigned char *)(p + p->s.size - nunits + 1); + s = nunits - 1; + } else { + c = (unsigned char *)(p + p->s.size - nunits); + s = nunits; + } + + for (i = 0; i < s; ++i) { + for (j = 0; j < sizeof(union header); ++j) { + assert(c[i * sizeof(union header) + j] == 0xAA); + } + } + } +#endif + + if (p->s.size == nunits) { + prevp->s.ptr = p->s.ptr; + } + else { + p->s.size -= nunits; + p += p->s.size; + p->s.size = nunits; + } + pic->heap->freep = prevp; + + p->s.mark = PIC_GC_UNMARK; + +#if GC_DEBUG + memset(p+1, 0, sizeof(union header) * (nunits - 1)); + p->s.ptr = (union header *)0xcafebabe; +#endif + + return (void *)(p + 1); +} + +static void +gc_free(pic_state *pic, union header *bp) +{ + union header *freep, *p; + +#if GC_DEBUG + assert(bp != NULL); + assert(bp->s.size > 1); +#endif + +#if GC_DEBUG + memset(bp + 1, 0xAA, (bp->s.size - 1) * sizeof(union header)); +#endif + + freep = pic->heap->freep; + for (p = freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) { + if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) { + break; + } + } + if (bp + bp->s.size == p->s.ptr) { + bp->s.size += p->s.ptr->s.size; + bp->s.ptr = p->s.ptr->s.ptr; + +#if GC_DEBUG + memset(p->s.ptr, 0xAA, sizeof(union header)); +#endif + } + else { + bp->s.ptr = p->s.ptr; + } + if (p + p->s.size == bp && p->s.size > 1) { + p->s.size += bp->s.size; + p->s.ptr = bp->s.ptr; + +#if GC_DEBUG + memset(bp, 0xAA, sizeof(union header)); +#endif + } + else { + p->s.ptr = bp; + } + pic->heap->freep = p; +} + +static void gc_mark(pic_state *, pic_value); +static void gc_mark_object(pic_state *pic, struct pic_object *obj); + +static bool +gc_is_marked(union header *p) +{ + return p->s.mark == PIC_GC_MARK; +} + +static void +gc_unmark(union header *p) +{ + p->s.mark = PIC_GC_UNMARK; +} + +static void +gc_mark_object(pic_state *pic, struct pic_object *obj) +{ + union header *p; + + p = ((union header *)obj) - 1; + + if (gc_is_marked(p)) + return; + p->s.mark = PIC_GC_MARK; + + switch (obj->tt) { + case PIC_TT_PAIR: { + gc_mark(pic, ((struct pic_pair *)obj)->car); + gc_mark(pic, ((struct pic_pair *)obj)->cdr); + break; + } + case PIC_TT_ENV: { + struct pic_env *env = (struct pic_env *)obj; + int i; + + for (i = 0; i < env->regc; ++i) { + gc_mark(pic, env->regs[i]); + } + if (env->up) { + gc_mark_object(pic, (struct pic_object *)env->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 (proc->attr) { + gc_mark_object(pic, (struct pic_object *)proc->attr); + } + if (pic_proc_irep_p(proc)) { + gc_mark_object(pic, (struct pic_object *)proc->u.irep); + } + break; + } + case PIC_TT_PORT: { + break; + } + case PIC_TT_ERROR: { + struct pic_error *err = (struct pic_error *)obj; + gc_mark_object(pic,(struct pic_object *)err->msg); + gc_mark(pic, err->irrs); + gc_mark_object(pic, (struct pic_object *)err->stack); + break; + } + case PIC_TT_STRING: { + break; + } + case PIC_TT_VECTOR: { + size_t i; + for (i = 0; i < ((struct pic_vector *)obj)->len; ++i) { + gc_mark(pic, ((struct pic_vector *)obj)->data[i]); + } + break; + } + case PIC_TT_BLOB: { + break; + } + case PIC_TT_CONT: { + struct pic_cont *cont = (struct pic_cont *)obj; + pic_value *stack; + pic_callinfo *ci; + size_t i; + + /* block */ + gc_mark_object(pic, (struct pic_object *)cont->blk); + + /* stack */ + for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) { + gc_mark(pic, *stack); + } + + /* callinfo */ + for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) { + if (ci->env) { + gc_mark_object(pic, (struct pic_object *)ci->env); + } + } + + /* arena */ + for (i = 0; i < (size_t)cont->arena_idx; ++i) { + gc_mark_object(pic, cont->arena[i]); + } + + /* error handlers */ + for (i = 0; i < cont->try_jmp_idx; ++i) { + if (cont->try_jmps[i].handler) { + gc_mark_object(pic, (struct pic_object *)cont->try_jmps[i].handler); + } + } + + /* result values */ + gc_mark(pic, cont->results); + break; + } + case PIC_TT_MACRO: { + struct pic_macro *mac = (struct pic_macro *)obj; + + if (mac->proc) { + gc_mark_object(pic, (struct pic_object *)mac->proc); + } + 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); + } + 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); + break; + } + case PIC_TT_VAR: { + struct pic_var *var = (struct pic_var *)obj; + gc_mark(pic, var->stack); + if (var->conv) { + gc_mark_object(pic, (struct pic_object *)var->conv); + } + break; + } + case PIC_TT_IREP: { + struct pic_irep *irep = (struct pic_irep *)obj; + size_t i; + + 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]); + } + break; + } + case PIC_TT_DATA: { + struct pic_data *data = (struct pic_data *)obj; + xh_iter it; + + xh_begin(&it, &data->storage); + while (xh_next(&it)) { + gc_mark(pic, xh_val(it.e, pic_value)); + } + break; + } + case PIC_TT_DICT: { + struct pic_dict *dict = (struct pic_dict *)obj; + xh_iter it; + + xh_begin(&it, &dict->hash); + while (xh_next(&it)) { + gc_mark(pic, xh_val(it.e, pic_value)); + } + break; + } + case PIC_TT_RECORD: { + struct pic_record *rec = (struct pic_record *)obj; + xh_iter it; + + xh_begin(&it, &rec->hash); + while (xh_next(&it)) { + gc_mark(pic, xh_val(it.e, pic_value)); + } + break; + } + case PIC_TT_BLK: { + struct pic_block *blk = (struct pic_block *)obj; + + if (blk->prev) { + gc_mark_object(pic, (struct pic_object *)blk->prev); + } + if (blk->in) { + gc_mark_object(pic, (struct pic_object *)blk->in); + } + if (blk->out) { + gc_mark_object(pic, (struct pic_object *)blk->out); + } + break; + } + case PIC_TT_NIL: + case PIC_TT_BOOL: + case PIC_TT_FLOAT: + case PIC_TT_INT: + case PIC_TT_SYMBOL: + case PIC_TT_CHAR: + case PIC_TT_EOF: + case PIC_TT_UNDEF: + pic_abort(pic, "logic flaw"); + } +} + +static void +gc_mark(pic_state *pic, pic_value v) +{ + struct pic_object *obj; + + if (pic_vtype(v) != PIC_VTYPE_HEAP) + return; + obj = pic_obj_ptr(v); + + gc_mark_object(pic, obj); +} + +static void +gc_mark_trie(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) { + gc_mark_trie(pic, trie->table[i]); + } + } + if (trie->proc != NULL) { + gc_mark_object(pic, (struct pic_object *)trie->proc); + } +} + +static void +gc_mark_phase(pic_state *pic) +{ + pic_value *stack; + pic_callinfo *ci; + size_t i, j; + xh_iter it; + + /* block */ + if (pic->blk) { + gc_mark_object(pic, (struct pic_object *)pic->blk); + } + + /* stack */ + for (stack = pic->stbase; stack != pic->sp; ++stack) { + gc_mark(pic, *stack); + } + + /* callinfo */ + for (ci = pic->ci; ci != pic->cibase; --ci) { + if (ci->env) { + gc_mark_object(pic, (struct pic_object *)ci->env); + } + } + + /* error object */ + if (pic->err) { + gc_mark_object(pic, (struct pic_object *)pic->err); + } + + /* arena */ + for (j = 0; j < pic->arena_idx; ++j) { + gc_mark_object(pic, pic->arena[j]); + } + + /* global variables */ + xh_begin(&it, &pic->globals); + while (xh_next(&it)) { + gc_mark(pic, xh_val(it.e, pic_value)); + } + + /* macro objects */ + xh_begin(&it, &pic->macros); + while (xh_next(&it)) { + gc_mark_object(pic, xh_val(it.e, struct pic_object *)); + } + + /* error handlers */ + for (i = 0; i < pic->try_jmp_idx; ++i) { + if (pic->try_jmps[i].handler) { + gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler); + } + } + + /* readers */ + gc_mark_trie(pic, pic->reader->trie); + + /* library table */ + gc_mark(pic, pic->libs); +} + +static void +gc_finalize_object(pic_state *pic, struct pic_object *obj) +{ +#if GC_DEBUG + printf("* finalizing object: %s", pic_type_repr(pic_type(pic_obj_value(obj)))); + // pic_debug(pic, pic_obj_value(obj)); + puts(""); +#endif + + switch (obj->tt) { + case PIC_TT_PAIR: { + break; + } + case PIC_TT_ENV: { + break; + } + case PIC_TT_PROC: { + break; + } + case PIC_TT_VECTOR: { + pic_free(pic, ((struct pic_vector *)obj)->data); + break; + } + case PIC_TT_BLOB: { + pic_free(pic, ((struct pic_blob *)obj)->data); + break; + } + case PIC_TT_STRING: { + XROPE_DECREF(((struct pic_string *)obj)->rope); + break; + } + case PIC_TT_PORT: { + break; + } + case PIC_TT_ERROR: { + break; + } + case PIC_TT_CONT: { + struct pic_cont *cont = (struct pic_cont *)obj; + pic_free(pic, cont->stk_ptr); + pic_free(pic, cont->st_ptr); + pic_free(pic, cont->ci_ptr); + pic_free(pic, cont->arena); + pic_free(pic, cont->try_jmps); + break; + } + case PIC_TT_SENV: { + struct pic_senv *senv = (struct pic_senv *)obj; + xh_destroy(&senv->map); + break; + } + case PIC_TT_MACRO: { + break; + } + case PIC_TT_LIB: { + struct pic_lib *lib = (struct pic_lib *)obj; + xh_destroy(&lib->exports); + break; + } + case PIC_TT_VAR: { + break; + } + case PIC_TT_IREP: { + struct pic_irep *irep = (struct pic_irep *)obj; + pic_free(pic, irep->code); + pic_free(pic, irep->irep); + pic_free(pic, irep->pool); + break; + } + case PIC_TT_DATA: { + struct pic_data *data = (struct pic_data *)obj; + data->type->dtor(pic, data->data); + xh_destroy(&data->storage); + break; + } + case PIC_TT_DICT: { + struct pic_dict *dict = (struct pic_dict *)obj; + xh_destroy(&dict->hash); + break; + } + case PIC_TT_RECORD: { + struct pic_record *rec = (struct pic_record *)obj; + xh_destroy(&rec->hash); + break; + } + case PIC_TT_BLK: { + break; + } + case PIC_TT_NIL: + case PIC_TT_BOOL: + case PIC_TT_FLOAT: + case PIC_TT_INT: + case PIC_TT_SYMBOL: + case PIC_TT_CHAR: + case PIC_TT_EOF: + case PIC_TT_UNDEF: + pic_abort(pic, "logic flaw"); + } +} + +static void +gc_sweep_page(pic_state *pic, struct heap_page *page) +{ +#if GC_DEBUG + static union header *NIL = (union header *)0xdeadbeef; +#else + static union header *NIL = NULL; +#endif + union header *bp, *p, *s = NIL, *t; + +#if GC_DEBUG + int c = 0; +#endif + + for (bp = page->basep; ; bp = bp->s.ptr) { + for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) { + if (p == page->endp) { + goto escape; + } + if (! gc_is_marked(p)) { + if (s == NIL) { + s = p; + } + else { + t->s.ptr = p; + } + t = p; + t->s.ptr = NIL; /* For dead objects we can safely reuse ptr field */ + } + gc_unmark(p); + } + } + escape: + + /* free! */ + while (s != NIL) { + t = s->s.ptr; + gc_finalize_object(pic, (struct pic_object *)(s + 1)); + gc_free(pic, s); + s = t; + +#if GC_DEBUG + c++; +#endif + } + +#if GC_DEBUG + printf("freed objects count: %d\n", c); +#endif +} + +static void +gc_sweep_phase(pic_state *pic) +{ + struct heap_page *page = pic->heap->pages; + + while (page) { + gc_sweep_page(pic, page); + page = page->next; + } +} + +void +pic_gc_run(pic_state *pic) +{ +#if GC_DEBUG + struct heap_page *page; +#endif + +#if DEBUG + puts("gc run!"); +#endif + + gc_mark_phase(pic); + gc_sweep_phase(pic); + +#if GC_DEBUG + for (page = pic->heap->pages; page; page = page->next) { + union header *bp, *p; + unsigned char *c; + + for (bp = page->basep; ; bp = bp->s.ptr) { + for (c = (unsigned char *)(bp+1); c != (unsigned char *)(bp + bp->s.size); ++c) { + assert(*c == 0xAA); + } + for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) { + if (p == page->endp) { + /* if (page->next) */ + /* assert(bp->s.ptr == page->next->basep); */ + /* else */ + /* assert(bp->s.ptr == &pic->heap->base); */ + goto escape; + } + assert(! gc_is_marked(p)); + } + } + escape: + ((void)0); + } + + puts("not error on heap found! gc successfully finished"); +#endif +} + +struct pic_object * +pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt) +{ + struct pic_object *obj; + +#if GC_DEBUG + printf("*allocating: %s\n", pic_type_repr(tt)); +#endif + +#if GC_STRESS + pic_gc_run(pic); +#endif + + obj = (struct pic_object *)gc_alloc(pic, size); + if (obj == NULL) { + pic_gc_run(pic); + obj = (struct pic_object *)gc_alloc(pic, size); + if (obj == NULL) { + add_heap_page(pic); + obj = (struct pic_object *)gc_alloc(pic, size); + if (obj == NULL) + pic_abort(pic, "GC memory exhausted"); + } + } + obj->tt = tt; + + return obj; +} + +struct pic_object * +pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt) +{ + struct pic_object *obj; + + obj = pic_obj_alloc_unsafe(pic, size, tt); + + gc_protect(pic, obj); + return obj; +} diff --git a/include/.dir-locals.el b/include/.dir-locals.el new file mode 100644 index 00000000..02363d3f --- /dev/null +++ b/include/.dir-locals.el @@ -0,0 +1,3 @@ +((c-mode . ((flycheck-clang-include-path . ( "../extlib")) + (flycheck-clang-warnings . ("all" "extra")) + (flycheck-clang-language-standard . "c99")))) diff --git a/include/picrin.h b/include/picrin.h new file mode 100644 index 00000000..e58d5a61 --- /dev/null +++ b/include/picrin.h @@ -0,0 +1,223 @@ +/** + * Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors. + * + * 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: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * 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. + */ + +#ifndef PICRIN_H__ +#define PICRIN_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include +#include +#include +#include +#include + +#include "xvect/xvect.h" +#include "xhash/xhash.h" +#include "xfile/xfile.h" +#include "xrope/xrope.h" + +#include "picrin/config.h" +#include "picrin/util.h" +#include "picrin/value.h" + +typedef struct pic_code pic_code; + +typedef struct { + int argc, retc; + pic_code *ip; + pic_value *fp; + struct pic_env *env; + int regc; + pic_value *regs; + struct pic_env *up; +} pic_callinfo; + +typedef struct { + int argc; + char **argv, **envp; + + struct pic_block *blk; + + pic_value *sp; + pic_value *stbase, *stend; + + pic_callinfo *ci; + pic_callinfo *cibase, *ciend; + + pic_code *ip; + + struct pic_lib *lib; + + 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 sCONS, sCAR, sCDR, sNILP; + pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; + pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; + + pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; + pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT; + pic_sym rDEFINE_LIBRARY, rIN_LIBRARY; + + xhash syms; /* name to symbol */ + xhash sym_names; /* symbol to name */ + int sym_cnt; + int uniq_sym_cnt; + + xhash globals; + xhash macros; + pic_value libs; + + struct pic_reader *reader; + + jmp_buf *jmp; + struct pic_error *err; + struct pic_jmpbuf *try_jmps; + size_t try_jmp_size, try_jmp_idx; + + struct pic_heap *heap; + struct pic_object **arena; + size_t arena_size, arena_idx; + + 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_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); +struct pic_object *pic_obj_alloc_unsafe(pic_state *, size_t, enum pic_tt); +void pic_free(pic_state *, void *); + +void pic_gc_run(pic_state *); +pic_value pic_gc_protect(pic_state *, pic_value); +size_t pic_gc_arena_preserve(pic_state *); +void pic_gc_arena_restore(pic_state *, size_t); +#define pic_void(exec) \ + pic_void_(GENSYM(ai), exec) +#define pic_void_(ai,exec) do { \ + size_t ai = pic_gc_arena_preserve(pic); \ + exec; \ + pic_gc_arena_restore(pic, ai); \ + } while (0) + +pic_state *pic_open(int argc, char *argv[], char **envp); +void pic_close(pic_state *); + +void pic_define(pic_state *, const char *, pic_value); /* automatic export */ +pic_value pic_ref(pic_state *, const char *); +void pic_set(pic_state *, const char *, pic_value); + +pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); + +struct pic_proc *pic_get_proc(pic_state *); +int pic_get_args(pic_state *, const char *, ...); +void pic_defun(pic_state *, const char *, pic_func_t); + +bool pic_equal_p(pic_state *, pic_value, pic_value); + +pic_sym pic_intern(pic_state *, const char *, size_t); +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); + +char *pic_strdup(pic_state *, const char *); +char *pic_strndup(pic_state *, const char *, size_t); + +pic_value pic_read(pic_state *, struct pic_port *); +pic_value pic_read_cstr(pic_state *, const char *); +pic_list pic_parse_file(pic_state *, FILE *); /* #f for incomplete input */ +pic_list pic_parse_cstr(pic_state *, const char *); + +pic_value pic_load(pic_state *, const char *); +pic_value pic_load_cstr(pic_state *, const char *); + +pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); +pic_value pic_apply0(pic_state *, struct pic_proc *); +pic_value pic_apply1(pic_state *, struct pic_proc *, pic_value); +pic_value pic_apply2(pic_state *, struct pic_proc *, pic_value, pic_value); +pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value); +pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value); +pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value); +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_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, GENSYM(i), 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_make_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib) + +void pic_import(pic_state *, pic_value); +void pic_export(pic_state *, pic_sym); + +noreturn void pic_abort(pic_state *, const char *); +noreturn void pic_errorf(pic_state *, const char *, ...); +void pic_warnf(pic_state *, const char *, ...); +pic_str *pic_get_backtrace(pic_state *); +void pic_print_backtrace(pic_state *, struct pic_error *); + +/* obsoleted */ +noreturn static inline void pic_error(pic_state *pic, const char *msg) +{ + pic_errorf(pic, msg); +} +static inline void pic_warn(pic_state *pic, const char *msg) +{ + pic_warnf(pic, msg); +} + +const char *pic_errmsg(pic_state *); + +pic_value pic_write(pic_state *, pic_value); /* returns given obj */ +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 defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/.dir-locals.el b/include/picrin/.dir-locals.el new file mode 100644 index 00000000..24adc5af --- /dev/null +++ b/include/picrin/.dir-locals.el @@ -0,0 +1,4 @@ +((c-mode . ((flycheck-clang-includes . ("../picrin.h")) + (flycheck-clang-include-path . ( "../../extlib")) + (flycheck-clang-warnings . ("all" "extra")) + (flycheck-clang-language-standard . "c99")))) diff --git a/include/picrin/blob.h b/include/picrin/blob.h new file mode 100644 index 00000000..f61f588d --- /dev/null +++ b/include/picrin/blob.h @@ -0,0 +1,27 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_BLOB_H__ +#define PICRIN_BLOB_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_blob { + PIC_OBJECT_HEADER + char *data; + size_t len; +}; + +#define pic_blob_p(v) (pic_type(v) == PIC_TT_BLOB) +#define pic_blob_ptr(v) ((struct pic_blob *)pic_ptr(v)) + +struct pic_blob *pic_blob_new(pic_state *, size_t); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/config.h b/include/picrin/config.h new file mode 100644 index 00000000..79b8fc3c --- /dev/null +++ b/include/picrin/config.h @@ -0,0 +1,115 @@ +/** + * See Copyright Notice in picrin.h + */ + +/** contribution libraries */ +/* #define PIC_CONTRIB_INITS */ + +/** switch normal VM and direct threaded VM */ +/* #define PIC_DIRECT_THREADED_VM 1 */ + +/** switch internal value representation */ +/* #define PIC_NAN_BOXING 1 */ + +/** enable readline module */ +/* #define PIC_ENABLE_READLINE 1 */ + +/** treat false value as none */ +/* #define PIC_NONE_IS_FALSE 1 */ + +/** initial memory size (to be dynamically extended if necessary) */ +/* #define PIC_ARENA_SIZE 1000 */ + +/* #define PIC_HEAP_PAGE_SIZE 10000 */ + +/* #define PIC_STACK_SIZE 1024 */ + +/* #define PIC_RESCUE_SIZE 30 */ + +/* #define PIC_SYM_POOL_SIZE 128 */ + +/* #define PIC_IREP_SIZE 8 */ + +/* #define PIC_POOL_SIZE 8 */ + +/* #define PIC_ISEQ_SIZE 1024 */ + +/** enable all debug flags */ +/* #define DEBUG 1 */ + +/** auxiliary debug flags */ +/* #define GC_STRESS 1 */ +/* #define VM_DEBUG 1 */ +/* #define GC_DEBUG 1 */ +/* #define GC_DEBUG_DETAIL 1 */ + +#if __STDC_VERSION__ < 199901L +# error please activate c99 features +#endif + +#ifndef PIC_CONTRIB_INITS +# define PIC_CONTRIB_INITS +#endif + +#ifndef PIC_DIRECT_THREADED_VM +# if defined(__GNUC__) || defined(__CLANG__) +# define PIC_DIRECT_THREADED_VM 1 +# endif +#endif + +#ifndef PIC_NAN_BOXING +# if __x86_64__ && __STDC_VERSION__ >= 201112L +# define PIC_NAN_BOXING 1 +# endif +#endif + +#ifndef PIC_ENABLE_READLINE +# if PIC_READLINE_FOUND +# define PIC_ENABLE_READLINE 1 +# else +# define PIC_ENABLE_READLINE 0 +# endif +#endif + +#ifndef PIC_NONE_IS_FALSE +# define PIC_NONE_IS_FALSE 1 +#endif + +#ifndef PIC_ARENA_SIZE +# define PIC_ARENA_SIZE 1000 +#endif + +#ifndef PIC_HEAP_PAGE_SIZE +# define PIC_HEAP_PAGE_SIZE 10000 +#endif + +#ifndef PIC_STACK_SIZE +# define PIC_STACK_SIZE 1024 +#endif + +#ifndef PIC_RESCUE_SIZE +# define PIC_RESCUE_SIZE 30 +#endif + +#ifndef PIC_SYM_POOL_SIZE +# define PIC_SYM_POOL_SIZE 128 +#endif + +#ifndef PIC_IREP_SIZE +# define PIC_IREP_SIZE 8 +#endif + +#ifndef PIC_POOL_SIZE +# define PIC_POOL_SIZE 8 +#endif + +#ifndef PIC_ISEQ_SIZE +# define PIC_ISEQ_SIZE 1024 +#endif + +#if DEBUG +# define GC_STRESS 0 +# define VM_DEBUG 1 +# define GC_DEBUG 0 +# define GC_DEBUG_DETAIL 0 +#endif diff --git a/include/picrin/cont.h b/include/picrin/cont.h new file mode 100644 index 00000000..0a0da9f1 --- /dev/null +++ b/include/picrin/cont.h @@ -0,0 +1,62 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_CONT_H__ +#define PICRIN_CONT_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_block { + PIC_OBJECT_HEADER + struct pic_block *prev; + int depth; + struct pic_proc *in, *out; +}; + +struct pic_cont { + PIC_OBJECT_HEADER + jmp_buf jmp; + + struct pic_block *blk; + + char *stk_pos, *stk_ptr; + ptrdiff_t stk_len; + + pic_value *st_ptr; + size_t sp_offset, st_len; + + pic_callinfo *ci_ptr; + size_t ci_offset, ci_len; + + pic_code *ip; + + struct pic_object **arena; + size_t arena_size; + int arena_idx; + + struct pic_jmpbuf *try_jmps; + size_t try_jmp_idx, try_jmp_size; + + pic_value results; +}; + +pic_value pic_values0(pic_state *); +pic_value pic_values1(pic_state *, pic_value); +pic_value pic_values2(pic_state *, pic_value, pic_value); +pic_value pic_values3(pic_state *, pic_value, pic_value, pic_value); +pic_value pic_values4(pic_state *, pic_value, pic_value, pic_value, pic_value); +pic_value pic_values5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); +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_callcc(pic_state *, struct pic_proc *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/data.h b/include/picrin/data.h new file mode 100644 index 00000000..a80ff209 --- /dev/null +++ b/include/picrin/data.h @@ -0,0 +1,37 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_DATA_H__ +#define PICRIN_DATA_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +typedef struct { + const char *type_name; + void (*dtor)(pic_state *, void *); +} pic_data_type; + +struct pic_data { + PIC_OBJECT_HEADER; + const pic_data_type *type; + xhash storage; /* const char * to pic_value table */ + void *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) { + return pic_data_p(obj) && pic_data_ptr(obj)->type == type; +} + +struct pic_data *pic_data_alloc(pic_state *, const pic_data_type *, void *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/dict.h b/include/picrin/dict.h new file mode 100644 index 00000000..8bc58ad8 --- /dev/null +++ b/include/picrin/dict.h @@ -0,0 +1,32 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_DICT_H__ +#define PICRIN_DICT_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_dict { + PIC_OBJECT_HEADER + xhash hash; +}; + +#define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT) +#define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v)) + +struct pic_dict *pic_dict_new(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); +size_t pic_dict_size(pic_state *, struct pic_dict *); +bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/error.h b/include/picrin/error.h new file mode 100644 index 00000000..bea590e2 --- /dev/null +++ b/include/picrin/error.h @@ -0,0 +1,60 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_ERROR_H__ +#define PICRIN_ERROR_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_jmpbuf { + jmp_buf here; + struct pic_proc *handler; + ptrdiff_t ci_offset; + ptrdiff_t sp_offset; + pic_code *ip; + jmp_buf *prev_jmp; +}; + +/* do not return from try block! */ + +#define pic_try \ + pic_try_with_handler(NULL) +#define pic_try_with_handler(handler) \ + pic_push_try(pic, handler); \ + if (setjmp(*pic->jmp) == 0) \ + do +#define pic_catch \ + while (pic_pop_try(pic), 0); \ + else \ + if (pic_pop_try(pic), 1) + +void pic_push_try(pic_state *, struct pic_proc *); +void pic_pop_try(pic_state *); + +noreturn void pic_throw(pic_state *, short, const char *, pic_value); +noreturn void pic_throw_error(pic_state *, struct pic_error *); + +struct pic_error { + PIC_OBJECT_HEADER + enum pic_error_kind { + PIC_ERROR_OTHER, + PIC_ERROR_FILE, + PIC_ERROR_READ, + PIC_ERROR_RAISED + } type; + struct pic_string *msg; + pic_value irrs; + pic_str *stack; +}; + +#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR) +#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v)) + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/gc.h b/include/picrin/gc.h new file mode 100644 index 00000000..c5f33e6a --- /dev/null +++ b/include/picrin/gc.h @@ -0,0 +1,24 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_GC_H__ +#define PICRIN_GC_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +#define PIC_GC_UNMARK 0 +#define PIC_GC_MARK 1 + +struct pic_heap; + +struct pic_heap *pic_heap_open(); +void pic_heap_close(struct pic_heap *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/irep.h b/include/picrin/irep.h new file mode 100644 index 00000000..4cb1cfba --- /dev/null +++ b/include/picrin/irep.h @@ -0,0 +1,206 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_IREP_H__ +#define PICRIN_IREP_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +enum pic_opcode { + OP_NOP, + OP_POP, + OP_PUSHNIL, + OP_PUSHTRUE, + OP_PUSHFALSE, + OP_PUSHINT, + OP_PUSHCHAR, + OP_PUSHCONST, + OP_GREF, + OP_GSET, + OP_LREF, + OP_LSET, + OP_CREF, + OP_CSET, + OP_JMP, + OP_JMPIF, + OP_NOT, + OP_CALL, + OP_TAILCALL, + OP_RET, + OP_LAMBDA, + OP_CONS, + OP_CAR, + OP_CDR, + OP_NILP, + OP_ADD, + OP_SUB, + OP_MUL, + OP_DIV, + OP_MINUS, + OP_EQ, + OP_LT, + OP_LE, + OP_STOP +}; + +struct pic_code { + enum pic_opcode insn; + union { + int i; + char c; + struct { + short depth; + short idx; + } r; + } u; +}; + +struct pic_irep { + PIC_OBJECT_HEADER + 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_value pic_analyze(pic_state *, pic_value); +struct pic_irep *pic_codegen(pic_state *, pic_value); + +static inline void +pic_dump_code(pic_code c) +{ + printf("[%2d] ", c.insn); + switch (c.insn) { + case OP_NOP: + puts("OP_NOP"); + break; + case OP_POP: + puts("OP_POP"); + break; + case OP_PUSHNIL: + puts("OP_PUSHNIL"); + break; + case OP_PUSHTRUE: + puts("OP_PUSHTRUE"); + break; + case OP_PUSHFALSE: + puts("OP_PUSHFALSE"); + break; + case OP_PUSHINT: + printf("OP_PUSHINT\t%d\n", c.u.i); + break; + case OP_PUSHCHAR: + printf("OP_PUSHCHAR\t%c\n", c.u.c); + break; + case OP_PUSHCONST: + printf("OP_PUSHCONST\t%d\n", c.u.i); + break; + case OP_GREF: + printf("OP_GREF\t%i\n", c.u.i); + break; + case OP_GSET: + printf("OP_GSET\t%i\n", c.u.i); + break; + case OP_LREF: + printf("OP_LREF\t%d\n", c.u.i); + break; + case OP_LSET: + printf("OP_LSET\t%d\n", c.u.i); + break; + case OP_CREF: + printf("OP_CREF\t%d\t%d\n", c.u.r.depth, c.u.r.idx); + break; + case OP_CSET: + printf("OP_CSET\t%d\t%d\n", c.u.r.depth, c.u.r.idx); + break; + case OP_JMP: + printf("OP_JMP\t%x\n", c.u.i); + break; + case OP_JMPIF: + printf("OP_JMPIF\t%x\n", c.u.i); + break; + case OP_NOT: + puts("OP_NOT"); + break; + case OP_CALL: + printf("OP_CALL\t%d\n", c.u.i); + break; + case OP_TAILCALL: + printf("OP_TAILCALL\t%d\n", c.u.i); + break; + case OP_RET: + printf("OP_RET\t%d\n", c.u.i); + break; + case OP_LAMBDA: + printf("OP_LAMBDA\t%d\n", c.u.i); + break; + case OP_CONS: + puts("OP_CONS"); + break; + case OP_CAR: + puts("OP_CAR"); + break; + case OP_NILP: + puts("OP_NILP"); + break; + case OP_CDR: + puts("OP_CDR"); + break; + case OP_ADD: + puts("OP_ADD"); + break; + case OP_SUB: + puts("OP_SUB"); + break; + case OP_MUL: + puts("OP_MUL"); + break; + case OP_DIV: + puts("OP_DIV"); + break; + case OP_MINUS: + puts("OP_MINUS"); + break; + case OP_EQ: + puts("OP_EQ"); + break; + case OP_LT: + puts("OP_LT"); + break; + case OP_LE: + puts("OP_LE"); + break; + case OP_STOP: + puts("OP_STOP"); + break; + } +} + +static inline void +pic_dump_irep(struct pic_irep *irep) +{ + unsigned i; + + printf("## irep %p\n", (void *)irep); + printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec); + for (i = 0; i < irep->clen; ++i) { + printf("%02x ", i); + pic_dump_code(irep->code[i]); + } + + for (i = 0; i < irep->ilen; ++i) { + pic_dump_irep(irep->irep[i]); + } +} + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/lib.h b/include/picrin/lib.h new file mode 100644 index 00000000..ba43e49d --- /dev/null +++ b/include/picrin/lib.h @@ -0,0 +1,25 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_LIB_H__ +#define PICRIN_LIB_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_lib { + PIC_OBJECT_HEADER + pic_value name; + struct pic_senv *env; + xhash exports; +}; + +#define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o)) + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/macro.h b/include/picrin/macro.h new file mode 100644 index 00000000..d655a735 --- /dev/null +++ b/include/picrin/macro.h @@ -0,0 +1,47 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_MACRO_H__ +#define PICRIN_MACRO_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_senv { + PIC_OBJECT_HEADER + xhash map; + struct pic_senv *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 *); + +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); + +struct pic_senv *pic_senv_new(pic_state *, struct pic_senv *); + +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); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/pair.h b/include/picrin/pair.h new file mode 100644 index 00000000..49de01cc --- /dev/null +++ b/include/picrin/pair.h @@ -0,0 +1,76 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_PAIR_H__ +#define PICRIN_PAIR_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_pair { + PIC_OBJECT_HEADER + pic_value car; + pic_value cdr; +}; + +#define pic_pair_p(v) (pic_type(v) == PIC_TT_PAIR) +#define pic_pair_ptr(o) ((struct pic_pair *)pic_ptr(o)) + +pic_value pic_cons(pic_state *, pic_value, pic_value); +pic_value pic_car(pic_state *, pic_value); +pic_value pic_cdr(pic_state *, pic_value); +void pic_set_car(pic_state *, pic_value, pic_value); +void pic_set_cdr(pic_state *, pic_value, pic_value); + +bool pic_list_p(pic_value); +pic_value pic_list1(pic_state *, pic_value); +pic_value pic_list2(pic_state *, pic_value, pic_value); +pic_value pic_list3(pic_state *, pic_value, pic_value, pic_value); +pic_value pic_list4(pic_state *, pic_value, pic_value, pic_value, pic_value); +pic_value pic_list5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_list6(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_list_by_array(pic_state *, size_t, pic_value *); +pic_value pic_make_list(pic_state *, int, pic_value); + +#define pic_for_each(var, list) \ + pic_for_each_helper__(var, 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_push(pic, item, place) (place = pic_cons(pic, item, place)) +#define pic_pop(pic, place) (place = pic_cdr(pic, place)) + +int pic_length(pic_state *, pic_value); +pic_value pic_reverse(pic_state *, pic_value); +pic_value pic_append(pic_state *, pic_value, pic_value); + +pic_value pic_memq(pic_state *, pic_value key, pic_value list); +pic_value pic_memv(pic_state *, pic_value key, pic_value list); +pic_value pic_member(pic_state *, pic_value key, pic_value list, struct pic_proc * /* = NULL */); + +pic_value pic_assq(pic_state *, pic_value key, pic_value assoc); +pic_value pic_assv(pic_state *, pic_value key, pic_value assoc); +pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc, struct pic_proc * /* = NULL */); + +pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc); + +pic_value pic_caar(pic_state *, pic_value); +pic_value pic_cadr(pic_state *, pic_value); +pic_value pic_cdar(pic_state *, pic_value); +pic_value pic_cddr(pic_state *, pic_value); + +pic_value pic_list_tail(pic_state *, pic_value, int); +pic_value pic_list_ref(pic_state *, pic_value, int); +void pic_list_set(pic_state *, pic_value, int, pic_value); +pic_value pic_list_copy(pic_state *, pic_value); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/port.h b/include/picrin/port.h new file mode 100644 index 00000000..e51d8759 --- /dev/null +++ b/include/picrin/port.h @@ -0,0 +1,50 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_PORT_H__ +#define PICRIN_PORT_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +enum pic_port_flag { + PIC_PORT_IN = 1, + PIC_PORT_OUT = 2, + PIC_PORT_TEXT = 4, + PIC_PORT_BINARY = 8, +}; + +enum pic_port_status { + PIC_PORT_OPEN, + PIC_PORT_CLOSE, +}; + +struct pic_port { + PIC_OBJECT_HEADER + xFILE *file; + int flags; + int status; +}; + +#define pic_port_p(v) (pic_type(v) == PIC_TT_PORT) +#define pic_port_ptr(v) ((struct pic_port *)pic_ptr(v)) + +pic_value pic_eof_object(); + +struct pic_port *pic_stdin(pic_state *); +struct pic_port *pic_stdout(pic_state *); +struct pic_port *pic_stderr(pic_state *); + +struct pic_port *pic_open_input_string(pic_state *, const char *); +struct pic_port *pic_open_output_string(pic_state *); +struct pic_string *pic_get_output_string(pic_state *, struct pic_port *); + +void pic_close_port(pic_state *pic, struct pic_port *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/proc.h b/include/picrin/proc.h new file mode 100644 index 00000000..b91960de --- /dev/null +++ b/include/picrin/proc.h @@ -0,0 +1,62 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_PROC_H__ +#define PICRIN_PROC_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +/* native C function */ +struct pic_func { + pic_func_t f; + pic_sym name; +}; + +struct pic_env { + PIC_OBJECT_HEADER + pic_value *regs; + int regc; + struct pic_env *up; + pic_value storage[]; +}; + +struct pic_proc { + PIC_OBJECT_HEADER + char kind; + union { + struct pic_func func; + struct pic_irep *irep; + } u; + struct pic_env *env; + struct pic_dict *attr; +}; + +#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_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)) + +struct pic_proc *pic_proc_new(pic_state *, pic_func_t, const char *); +struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_env *); + +pic_sym pic_proc_name(struct pic_proc *); + +struct pic_dict *pic_attr(pic_state *, struct pic_proc *); +pic_value pic_attr_ref(pic_state *, struct pic_proc *, const char *); +void pic_attr_set(pic_state *, struct pic_proc *, const char *, pic_value); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/read.h b/include/picrin/read.h new file mode 100644 index 00000000..8b977d58 --- /dev/null +++ b/include/picrin/read.h @@ -0,0 +1,39 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_READ_H__ +#define PICRIN_READ_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +enum pic_typecase { + PIC_CASE_DEFAULT, + PIC_CASE_FOLD, +}; + +struct pic_trie { + struct pic_trie *table[256]; + struct pic_proc *proc; +}; + +struct pic_reader { + short typecase; + xhash labels; + struct pic_trie *trie; +}; + +void pic_init_reader(pic_state *); + +void pic_define_reader(pic_state *, const char *, pic_func_t); + +struct pic_trie *pic_trie_new(pic_state *); +void pic_trie_delete(pic_state *, struct pic_trie *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/record.h b/include/picrin/record.h new file mode 100644 index 00000000..bf8698f1 --- /dev/null +++ b/include/picrin/record.h @@ -0,0 +1,30 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_RECORD_H +#define PICRIN_RECORD_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_record { + PIC_OBJECT_HEADER + xhash hash; +}; + +#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD) +#define pic_record_ptr(v) ((struct pic_record *)pic_ptr(v)) + +struct pic_record *pic_record_new(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); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/string.h b/include/picrin/string.h new file mode 100644 index 00000000..c2564ffe --- /dev/null +++ b/include/picrin/string.h @@ -0,0 +1,42 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_STRING_H__ +#define PICRIN_STRING_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_string { + PIC_OBJECT_HEADER + xrope *rope; +}; + +#define pic_str_p(v) (pic_type(v) == PIC_TT_STRING) +#define pic_str_ptr(o) ((struct pic_string *)pic_ptr(o)) + +pic_str *pic_str_new(pic_state *, const char * /* nullable */, size_t); +pic_str *pic_str_new_cstr(pic_state *, const char *); +pic_str *pic_str_new_fill(pic_state *, size_t, char); + +size_t pic_strlen(pic_str *); +char pic_str_ref(pic_state *, pic_str *, size_t); +void pic_str_set(pic_state *, pic_str *, size_t, char); + +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 *); + +pic_value pic_format(pic_state *, const char *, ...); +pic_value pic_vformat(pic_state *, const char *, va_list); +pic_value pic_vfformat(pic_state *, xFILE *, const char *, va_list); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/util.h b/include/picrin/util.h new file mode 100644 index 00000000..f2f5e719 --- /dev/null +++ b/include/picrin/util.h @@ -0,0 +1,51 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_UTIL_H__ +#define PICRIN_UTIL_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +#if __STDC_VERSION__ >= 201112L +# include +#elif __GNUC__ || __clang__ +# define noreturn __attribute__((noreturn)) +#else +# define noreturn +#endif + +#define FALLTHROUGH ((void)0) +#define UNUSED(v) ((void)(v)) + +#define GENSYM2__(x,y) G##x##_##y##__ +#define GENSYM1__(x,y) GENSYM2__(x,y) +#if defined(__COUNTER__) +# define GENSYM(x) GENSYM1__(__COUNTER__,x) +#else +# define GENSYM(x) GENSYM1__(__LINE__,x) +#endif + +#if GCC_VERSION >= 40500 || __clang__ +# define UNREACHABLE() (__builtin_unreachable()) +#else +# include +# define UNREACHABLE() (assert(false)) +#endif + +#define SWAP(type,a,b) \ + SWAP_HELPER__(type,GENSYM(tmp),a,b) +#define SWAP_HELPER__(type,tmp,a,b) \ + do { \ + type tmp = (a); \ + (a) = (b); \ + (b) = tmp; \ + } while (0) + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/value.h b/include/picrin/value.h new file mode 100644 index 00000000..6137c2eb --- /dev/null +++ b/include/picrin/value.h @@ -0,0 +1,484 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_VALUE_H__ +#define PICRIN_VALUE_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +/** + * pic_sym is just an alias to unsigned int. + */ + +typedef int pic_sym; + +/** + * `undef` values never seen from user-end: that is, + * it's used only for repsenting internal special state + */ + +enum pic_vtype { + PIC_VTYPE_NIL = 1, + PIC_VTYPE_TRUE, + PIC_VTYPE_FALSE, + PIC_VTYPE_UNDEF, + PIC_VTYPE_FLOAT, + PIC_VTYPE_INT, + PIC_VTYPE_SYMBOL, + PIC_VTYPE_CHAR, + PIC_VTYPE_EOF, + PIC_VTYPE_HEAP +}; + +#if PIC_NAN_BOXING + +/** + * 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 ................ + */ + +typedef struct { + union { + void *data; + double f; + struct { + union { + int i; + pic_sym sym; + char c; + }; + uint32_t type_; + }; + } u; +} pic_value; + +#define pic_ptr(v) ((void *)((uint64_t)0xffffffffffff & (uint64_t)(v).u.data)) +#define pic_init_value(v,vtype) (((v).u.type_ = (((uint32_t)0xfff00000)|((uint32_t)((vtype)<<16)))), (v).u.i = 0) + +static inline enum pic_vtype +pic_vtype(pic_value v) +{ + return 0xfff00000 >= v.u.type_ + ? PIC_VTYPE_FLOAT + : (v.u.type_ & 0xf0000)>>16; +} + +#else + +typedef struct { + enum pic_vtype type; + union { + void *data; + double f; + int i; + pic_sym sym; + char c; + } u; +} pic_value; + +#define pic_ptr(v) ((v).u.data) +#define pic_vtype(v) ((v).type) +#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL) + +#endif + +enum pic_tt { + /* immediate */ + PIC_TT_NIL, + PIC_TT_BOOL, + PIC_TT_FLOAT, + PIC_TT_INT, + PIC_TT_SYMBOL, + PIC_TT_CHAR, + PIC_TT_EOF, + PIC_TT_UNDEF, + /* heap */ + PIC_TT_PAIR, + PIC_TT_STRING, + PIC_TT_VECTOR, + PIC_TT_BLOB, + PIC_TT_PROC, + PIC_TT_PORT, + PIC_TT_ERROR, + PIC_TT_ENV, + PIC_TT_CONT, + PIC_TT_SENV, + PIC_TT_MACRO, + PIC_TT_LIB, + PIC_TT_VAR, + PIC_TT_IREP, + PIC_TT_DATA, + PIC_TT_DICT, + PIC_TT_RECORD, + PIC_TT_BLK, +}; + +#define PIC_OBJECT_HEADER \ + enum pic_tt tt; + +struct pic_object { + PIC_OBJECT_HEADER +}; + +struct pic_pair; +struct pic_string; +struct pic_vector; +struct pic_blob; + +struct pic_proc; +struct pic_port; + +/* set aliases to basic types */ +typedef pic_value pic_list; +typedef struct pic_pair pic_pair; +typedef struct pic_string pic_str; +typedef struct pic_vector pic_vec; +typedef struct pic_blob pic_blob; + +#define pic_float(v) ((v).u.f) +#define pic_int(v) ((v).u.i) +#define pic_sym(v) ((v).u.sym) +#define pic_char(v) ((v).u.c) + +#define pic_obj_p(v) (pic_vtype(v) == PIC_VTYPE_HEAP) +#define pic_obj_ptr(v) ((struct pic_object *)pic_ptr(v)) + +#define pic_nil_p(v) (pic_vtype(v) == PIC_VTYPE_NIL) +#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_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); + +#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); + +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_sym_value(pic_sym); +static inline pic_value pic_char_value(char c); +static inline pic_value pic_none_value(); + +#define pic_symbol_value(sym) pic_sym_value(sym) + +static inline bool pic_eq_p(pic_value, pic_value); +static inline bool pic_eqv_p(pic_value, pic_value); + +static inline enum pic_tt +pic_type(pic_value v) +{ + switch (pic_vtype(v)) { + case PIC_VTYPE_NIL: + return PIC_TT_NIL; + case PIC_VTYPE_TRUE: + return PIC_TT_BOOL; + case PIC_VTYPE_FALSE: + return PIC_TT_BOOL; + case PIC_VTYPE_UNDEF: + return PIC_TT_UNDEF; + case PIC_VTYPE_FLOAT: + return PIC_TT_FLOAT; + 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: + return PIC_TT_EOF; + case PIC_VTYPE_HEAP: + return ((struct pic_object *)pic_ptr(v))->tt; + default: + return -1; /* logic flaw */ + } +} + +static inline const char * +pic_type_repr(enum pic_tt tt) +{ + switch (tt) { + case PIC_TT_NIL: + return "nil"; + case PIC_TT_BOOL: + return "boolean"; + case PIC_TT_FLOAT: + return "float"; + case PIC_TT_INT: + return "int"; + case PIC_TT_SYMBOL: + return "symbol"; + case PIC_TT_CHAR: + return "char"; + case PIC_TT_EOF: + return "eof"; + case PIC_TT_UNDEF: + return "undef"; + case PIC_TT_PAIR: + return "pair"; + case PIC_TT_STRING: + return "string"; + case PIC_TT_VECTOR: + return "vector"; + case PIC_TT_BLOB: + return "blob"; + case PIC_TT_PORT: + return "port"; + case PIC_TT_ERROR: + return "error"; + case PIC_TT_ENV: + return "env"; + case PIC_TT_CONT: + return "cont"; + case PIC_TT_PROC: + return "proc"; + case PIC_TT_SENV: + return "senv"; + case PIC_TT_MACRO: + return "macro"; + case PIC_TT_LIB: + return "lib"; + case PIC_TT_VAR: + return "var"; + case PIC_TT_IREP: + return "irep"; + case PIC_TT_DATA: + return "data"; + case PIC_TT_DICT: + return "dict"; + case PIC_TT_RECORD: + return "record"; + case PIC_TT_BLK: + return "block"; + } + UNREACHABLE(); +} + +static inline bool +pic_valid_int(double v) +{ + return INT_MIN <= v && v <= INT_MAX; +} + +static inline pic_value +pic_nil_value() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_NIL); + return v; +} + +static inline pic_value +pic_true_value() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_TRUE); + return v; +} + +static inline pic_value +pic_false_value() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_FALSE); + return v; +} + +static inline pic_value +pic_bool_value(bool b) +{ + pic_value v; + + pic_init_value(v, b ? PIC_VTYPE_TRUE : PIC_VTYPE_FALSE); + return v; +} + +#if PIC_NAN_BOXING + +static inline pic_value +pic_obj_value(void *ptr) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_HEAP); + v.u.data = (void*)((long long)v.u.data | ((long long)ptr)); + return v; +} + +static inline pic_value +pic_float_value(double f) +{ + pic_value v; + + if (f != f) { + v.u.type_ = 0x7ff80000; + v.u.i = 0; + } else { + v.u.f = f; + } + return v; +} + +#else + +static inline pic_value +pic_obj_value(void *ptr) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_HEAP); + v.u.data = ptr; + return v; +} + +static inline pic_value +pic_float_value(double f) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_FLOAT); + v.u.f = f; + return v; +} + +#endif + +static inline pic_value +pic_int_value(int i) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_INT); + v.u.i = 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_char_value(char c) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_CHAR); + v.u.c = c; + return v; +} + +static inline pic_value +pic_undef_value() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_UNDEF); + return v; +} + +static inline pic_value +pic_none_value() +{ +#if PIC_NONE_IS_FALSE + return pic_false_value(); +#else +# error enable PIC_NONE_IS_FALSE +#endif +} + +#if PIC_NAN_BOXING + +static inline bool +pic_eq_p(pic_value x, pic_value y) +{ + return x.u.data == y.u.data; +} + +static inline bool +pic_eqv_p(pic_value x, pic_value y) +{ + return x.u.data == y.u.data; +} + +#else + +static inline bool +pic_eq_p(pic_value x, pic_value y) +{ + if (pic_type(x) != pic_type(y)) + return false; + + switch (pic_type(x)) { + case PIC_TT_NIL: + 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_eqv_p(pic_value x, pic_value y) +{ + if (pic_type(x) != pic_type(y)) + return false; + + switch (pic_type(x)) { + case PIC_TT_NIL: + return true; + case PIC_TT_BOOL: + return pic_vtype(x) == pic_vtype(y); + case PIC_TT_SYMBOL: + return pic_sym(x) == pic_sym(y); + case PIC_TT_FLOAT: + return pic_float(x) == pic_float(y); + case PIC_TT_INT: + return pic_int(x) == pic_int(y); + default: + return pic_ptr(x) == pic_ptr(y); + } +} + +#endif + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/var.h b/include/picrin/var.h new file mode 100644 index 00000000..d3bbaf4e --- /dev/null +++ b/include/picrin/var.h @@ -0,0 +1,32 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_VAR_H__ +#define PICRIN_VAR_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_var { + PIC_OBJECT_HEADER + pic_value stack; + struct pic_proc *conv; +}; + +#define pic_var_p(o) (pic_type(o) == PIC_TT_VAR) +#define pic_var_ptr(o) ((struct pic_var *)pic_ptr(o)) + +struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc * /* = NULL */); + +pic_value pic_var_ref(pic_state *, struct pic_var *); +void pic_var_set(pic_state *, struct pic_var *, pic_value); +void pic_var_push(pic_state *, struct pic_var *, pic_value); +void pic_var_pop(pic_state *, struct pic_var *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/vector.h b/include/picrin/vector.h new file mode 100644 index 00000000..80a4cb73 --- /dev/null +++ b/include/picrin/vector.h @@ -0,0 +1,29 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_VECTOR_H__ +#define PICRIN_VECTOR_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_vector { + PIC_OBJECT_HEADER + pic_value *data; + size_t len; +}; + +#define pic_vec_p(v) (pic_type(v) == PIC_TT_VECTOR) +#define pic_vec_ptr(o) ((struct pic_vector *)pic_ptr(o)) + +struct pic_vector *pic_vec_new(pic_state *, size_t); +struct pic_vector *pic_vec_new_from_list(pic_state *, pic_value); +void pic_vec_extend_ip(pic_state *, struct pic_vector *, size_t); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/init.c b/init.c new file mode 100644 index 00000000..0d345a01 --- /dev/null +++ b/init.c @@ -0,0 +1,124 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/read.h" +#include "picrin/lib.h" +#include "picrin/macro.h" +#include "picrin/error.h" + +static pic_value +pic_features(pic_state *pic) +{ + pic_value features = pic_nil_value(); + + pic_get_args(pic, ""); + + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features); + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features); + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features); + + return features; +} + +static pic_value +pic_libraries(pic_state *pic) +{ + pic_value libs = pic_nil_value(), lib; + + pic_get_args(pic, ""); + + pic_for_each (lib, pic->libs) { + libs = pic_cons(pic, pic_car(pic, lib), libs); + } + + return libs; +} + +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_time(pic_state *); +void pic_init_system(pic_state *); +void pic_init_file(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_load(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_contrib(pic_state *); + +void pic_load_piclib(pic_state *); + +#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_reader(pic); + + pic_deflibrary (pic, "(picrin base core)") { + 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_deflibrary (pic, "(picrin library)") { + pic_defun(pic, "libraries", pic_libraries); + } + + pic_deflibrary (pic, "(scheme base)") { + pic_defun(pic, "features", pic_features); + + pic_init_bool(pic); DONE; + pic_init_pair(pic); DONE; + pic_init_port(pic); DONE; + pic_init_number(pic); DONE; + pic_init_time(pic); DONE; + pic_init_system(pic); DONE; + pic_init_file(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_load(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_load_piclib(pic); DONE; + pic_init_contrib(pic); DONE; + } +} diff --git a/init_contrib.c b/init_contrib.c new file mode 100644 index 00000000..50542d47 --- /dev/null +++ b/init_contrib.c @@ -0,0 +1,17 @@ +/** + * !!NOTICE!! + * This file was automatically generated by mkinit.pl, and includes all of + * the prelude files required by Picrin. PLEASE DO NOT EDIT THIS FILE, changes + * will be overwritten the next time the script runs. + */ + +#include "picrin.h" + +void +pic_init_contrib(pic_state *pic) +{ + void pic_init_random(pic_state *); + void pic_init_regexp(pic_state *); + pic_init_random(pic); + pic_init_regexp(pic); +} diff --git a/lib.c b/lib.c new file mode 100644 index 00000000..45351083 --- /dev/null +++ b/lib.c @@ -0,0 +1,273 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/lib.h" +#include "picrin/pair.h" +#include "picrin/macro.h" +#include "picrin/error.h" +#include "picrin/dict.h" +#include "picrin/string.h" + +struct pic_lib * +pic_make_library(pic_state *pic, pic_value name) +{ + struct pic_lib *lib; + struct pic_senv *senv; + + if ((lib = pic_find_library(pic, name)) != NULL) { + +#if DEBUG + printf("* reopen library: "); + pic_debug(pic, name); + puts(""); +#endif + + return lib; + } + + senv = pic_null_syntactic_environment(pic); + + 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)); + + /* register! */ + pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs); + + 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) +{ + pic_value v; + + v = pic_assoc(pic, spec, pic->libs, NULL); + if (pic_false_p(v)) { + return NULL; + } + return pic_lib_ptr(pic_cdr(pic, v)); +} + +static struct pic_dict * +import_table(pic_state *pic, pic_value spec) +{ + const pic_sym sONLY = pic_intern_cstr(pic, "only"); + const pic_sym sRENAME = pic_intern_cstr(pic, "rename"); + const pic_sym sPREFIX = pic_intern_cstr(pic, "prefix"); + const pic_sym sEXCEPT = pic_intern_cstr(pic, "except"); + struct pic_lib *lib; + struct pic_dict *imports, *dict; + pic_value val, id; + xh_iter it; + + imports = pic_dict_new(pic); + + if (pic_list_p(spec)) { + if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sONLY))) { + dict = import_table(pic, pic_cadr(pic, spec)); + pic_for_each (val, pic_cddr(pic, spec)) { + pic_dict_set(pic, imports, pic_sym(val), pic_dict_ref(pic, dict, pic_sym(val))); + } + return imports; + } + if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) { + imports = import_table(pic, pic_cadr(pic, spec)); + pic_for_each (val, pic_cddr(pic, spec)) { + id = pic_dict_ref(pic, imports, pic_sym(pic_car(pic, val))); + pic_dict_del(pic, imports, pic_sym(pic_car(pic, val))); + pic_dict_set(pic, imports, pic_sym(pic_cadr(pic, val)), id); + } + return imports; + } + if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sPREFIX))) { + dict = import_table(pic, pic_cadr(pic, spec)); + xh_begin(&it, &dict->hash); + while (xh_next(&it)) { + pic_dict_set(pic, imports, pic_intern_cstr(pic, pic_str_cstr(pic_strcat(pic, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(pic_car(pic, pic_cddr(pic, spec))))), pic_str_new_cstr(pic, pic_symbol_name(pic, xh_key(it.e, pic_sym)))))), xh_val(it.e, pic_value)); + } + return imports; + } + if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sEXCEPT))) { + imports = import_table(pic, pic_cadr(pic, spec)); + pic_for_each (val, pic_cddr(pic, spec)) { + pic_dict_del(pic, imports, pic_sym(val)); + } + return imports; + } + } + lib = pic_find_library(pic, spec); + if (! lib) { + pic_errorf(pic, "library not found: ~a", spec); + } + xh_begin(&it, &lib->exports); + while (xh_next(&it)) { + pic_dict_set(pic, imports, xh_key(it.e, pic_sym), pic_sym_value(xh_val(it.e, pic_sym))); + } + return imports; +} + +static void +import(pic_state *pic, pic_value spec) +{ + struct pic_dict *imports; + xh_iter it; + + imports = import_table(pic, spec); + + xh_begin(&it, &imports->hash); + while (xh_next(&it)) { + +#if DEBUG + printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, pic_sym(xh_val(it.e, pic_value)))); +#endif + + pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), pic_sym(xh_val(it.e, pic_value))); + } +} + +static void +export(pic_state *pic, pic_value spec) +{ + const 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; + } else { /* (export (rename a b)) */ + if (! pic_list_p(spec)) + goto fail; + if (! pic_length(pic, spec) == 3) + goto fail; + if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) + goto fail; + if (! pic_sym_p(a = pic_list_ref(pic, spec, 1))) + goto fail; + if (! pic_sym_p(b = pic_list_ref(pic, spec, 2))) + 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)); +#endif + + xh_put_int(&pic->lib->exports, pic_sym(b), &rename); + + return; + + fail: + pic_errorf(pic, "illegal export spec: ~s", spec); +} + +void +pic_import(pic_state *pic, pic_value spec) +{ + import(pic, spec); +} + +void +pic_export(pic_state *pic, pic_sym sym) +{ + export(pic, pic_sym_value(sym)); +} + +static pic_value +pic_lib_import(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + import(pic, argv[i]); + } + + return pic_none_value(); +} + +static pic_value +pic_lib_export(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + export(pic, argv[i]); + } + + return pic_none_value(); +} + +static pic_value +pic_lib_define_library(pic_state *pic) +{ + struct pic_lib *prev = pic->lib; + size_t argc, i; + pic_value spec, *argv; + + pic_get_args(pic, "o*", &spec, &argc, &argv); + + pic_make_library(pic, spec); + + pic_try { + pic_in_library(pic, spec); + + for (i = 0; i < argc; ++i) { + pic_void(pic_eval(pic, argv[i], pic->lib)); + } + + pic_in_library(pic, prev->name); + } + pic_catch { + pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */ + pic_throw_error(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(); +} + +void +pic_init_lib(pic_state *pic) +{ + void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t); + + 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/load.c b/load.c new file mode 100644 index 00000000..440b45e2 --- /dev/null +++ b/load.c @@ -0,0 +1,87 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" + +pic_value +pic_load_cstr(pic_state *pic, const char *src) +{ + size_t ai; + pic_value v, exprs; + struct pic_proc *proc; + + exprs = pic_parse_cstr(pic, src); + if (pic_undef_p(exprs)) { + pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); + } + + pic_for_each (v, exprs) { + ai = pic_gc_arena_preserve(pic); + + proc = pic_compile(pic, v, pic->lib); + if (proc == NULL) { + pic_error(pic, "load: compilation failure"); + } + + pic_apply(pic, proc, pic_nil_value()); + + pic_gc_arena_restore(pic, ai); + } + + return pic_none_value(); +} + +pic_value +pic_load(pic_state *pic, const char *fn) +{ + FILE *file; + size_t ai; + pic_value v, exprs; + struct pic_proc *proc; + + file = fopen(fn, "r"); + if (file == NULL) { + pic_errorf(pic, "load: could not read file \"%s\"", fn); + } + + exprs = pic_parse_file(pic, file); + if (pic_undef_p(exprs)) { + pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); + } + + pic_for_each (v, exprs) { + ai = pic_gc_arena_preserve(pic); + + proc = pic_compile(pic, v, pic->lib); + if (proc == NULL) { + pic_error(pic, "load: compilation failure"); + } + + pic_apply(pic, proc, pic_nil_value()); + + pic_gc_arena_restore(pic, ai); + } + + return pic_none_value(); +} + +static pic_value +pic_load_load(pic_state *pic) +{ + pic_value envid; + char *fn; + + pic_get_args(pic, "z|o", &fn, &envid); + + return pic_load(pic, fn); +} + +void +pic_init_load(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme load)") { + pic_defun(pic, "load", pic_load_load); + } +} diff --git a/load_piclib.c b/load_piclib.c new file mode 100644 index 00000000..84e241a7 --- /dev/null +++ b/load_piclib.c @@ -0,0 +1,3978 @@ +/** + * !!NOTICE!! + * This file was automatically generated by mkloader.pl, and includes all of + * the prelude files required by Picrin. PLEASE DO NOT EDIT THIS FILE, changes + * will be overwritten the next time the script runs. + */ + +#include "picrin.h" +#include "picrin/error.h" + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_base = +"(define-library (picrin base)\n" +" (import (rename (picrin base core) (define define*))\n" +" (picrin base macro)\n" +" (picrin base list)\n" +" (picrin base symbol))\n" +"\n" +" (define-syntax define\n" +" (lambda (form use-env mac-env)\n" +" (if (symbol? (car (cdr form)))\n" +" (cons (make-identifier 'define* mac-env) (cdr form))\n" +" (cons (make-identifier 'define mac-env)\n" +" (cons (car (car (cdr form)))\n" +" (cons (cons (make-identifier 'lambda mac-env)\n" +" (cons (cdr (car (cdr form)))\n" +" (cdr (cdr form))))\n" +" '()))))))\n" +"\n" +" (export define\n" +" set!\n" +" quote\n" +" lambda\n" +" if\n" +" begin\n" +" define-syntax))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_list = +"(define-library (picrin list)\n" +" (import (picrin base list))\n" +"\n" +" (export pair?\n" +" cons\n" +" car\n" +" cdr\n" +" set-car!\n" +" set-cdr!\n" +" null?\n" +" caar\n" +" cadr\n" +" cdar\n" +" cddr\n" +" list?\n" +" make-list\n" +" list\n" +" length\n" +" append\n" +" reverse\n" +" list-tail\n" +" list-ref\n" +" list-set!\n" +" list-copy\n" +" memq\n" +" memv\n" +" member\n" +" assq\n" +" assv\n" +" assoc))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_symbol = +"(define-library (picrin symbol)\n" +" (import (picrin base symbol))\n" +"\n" +" (export symbol?\n" +" symbol=?\n" +" symbol->string\n" +" string->symbol))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_macro = +";;; Hygienic Macros\n" +"\n" +"(define-library (picrin macro)\n" +" (import (picrin base macro)\n" +" (picrin base)\n" +" (picrin list)\n" +" (picrin symbol)\n" +" (scheme base)\n" +" (picrin dictionary))\n" +"\n" +" ;; assumes no derived expressions are provided yet\n" +"\n" +" (define (walk proc expr)\n" +" \"walk on symbols\"\n" +" (if (null? expr)\n" +" '()\n" +" (if (pair? expr)\n" +" (cons (walk proc (car expr))\n" +" (walk proc (cdr expr)))\n" +" (if (vector? expr)\n" +" (list->vector (walk proc (vector->list expr)))\n" +" (if (symbol? expr)\n" +" (proc expr)\n" +" expr)))))\n" +"\n" +" (define (memoize f)\n" +" \"memoize on symbols\"\n" +" (define cache (make-dictionary))\n" +" (lambda (sym)\n" +" (if (dictionary-has? cache sym)\n" +" (dictionary-ref cache sym)\n" +" (begin\n" +" (define val (f sym))\n" +" (dictionary-set! cache sym val)\n" +" val))))\n" +"\n" +" (define (identifier=? env1 sym1 env2 sym2)\n" +"\n" +" (define (resolve sym env)\n" +" (define x (make-identifier sym env))\n" +" (define y (make-identifier sym env))\n" +" (if (eq? x y)\n" +" x\n" +" sym)) ; resolved to no variable\n" +"\n" +" (eq? (resolve sym1 env1)\n" +" (resolve sym2 env2)))\n" +"\n" +" (define (make-syntactic-closure env free form)\n" +"\n" +" (define resolve\n" +" (memoize\n" +" (lambda (sym)\n" +" (make-identifier sym env))))\n" +"\n" +" (walk\n" +" (lambda (sym)\n" +" (if (memq sym free)\n" +" sym\n" +" (resolve sym)))\n" +" form))\n" +"\n" +" (define (close-syntax form env)\n" +" (make-syntactic-closure env '() form))\n" +"\n" +" (define-syntax capture-syntactic-environment\n" +" (lambda (form use-env mac-env)\n" +" (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))\n" +"\n" +" (define (sc-macro-transformer f)\n" +" (lambda (expr use-env mac-env)\n" +" (make-syntactic-closure mac-env '() (f expr use-env))))\n" +"\n" +" (define (rsc-macro-transformer f)\n" +" (lambda (expr use-env mac-env)\n" +" (make-syntactic-closure use-env '() (f expr mac-env))))\n" +"\n" +" (define (er-macro-transformer f)\n" +" (lambda (expr use-env mac-env)\n" +"\n" +" (define rename\n" +" (memoize\n" +" (lambda (sym)\n" +" (make-identifier sym mac-env))))\n" +"\n" +" (define (compare x y)\n" +" (if (not (symbol? x))\n" +" #f\n" +" (if (not (symbol? y))\n" +" #f\n" +" (identifier=? use-env x use-env y))))\n" +"\n" +" (f expr rename compare)))\n" +"\n" +" (define (ir-macro-transformer f)\n" +" (lambda (expr use-env mac-env)\n" +"\n" +" (define icache* (make-dictionary))\n" +"\n" +" (define inject\n" +" (memoize\n" +" (lambda (sym)\n" +" (define id (make-identifier sym use-env))\n" +" (dictionary-set! icache* id sym)\n" +" id)))\n" +"\n" +" (define rename\n" +" (memoize\n" +" (lambda (sym)\n" +" (make-identifier sym mac-env))))\n" +"\n" +" (define (compare x y)\n" +" (if (not (symbol? x))\n" +" #f\n" +" (if (not (symbol? y))\n" +" #f\n" +" (identifier=? mac-env x mac-env y))))\n" +"\n" +" (walk (lambda (sym)\n" +" (if (dictionary-has? icache* sym)\n" +" (dictionary-ref icache* sym)\n" +" (rename sym)))\n" +" (f (walk inject expr) inject compare))))\n" +"\n" +" (define (strip-syntax form)\n" +" (walk ungensym form))\n" +"\n" +" (define-syntax define-macro\n" +" (er-macro-transformer\n" +" (lambda (expr r c)\n" +" (define formal (car (cdr expr)))\n" +" (define body (cdr (cdr expr)))\n" +" (if (symbol? formal)\n" +" (list (r 'define-syntax) formal\n" +" (list (r 'lambda) (list (r 'form) '_ '_)\n" +" (list (r 'apply) (car body) (list (r 'cdr) (r 'form)))))\n" +" (list (r 'define-macro) (car formal)\n" +" (cons (r 'lambda)\n" +" (cons (cdr formal)\n" +" body)))))))\n" +"\n" +" (export identifier?\n" +" identifier=?\n" +" make-identifier\n" +" make-syntactic-closure\n" +" close-syntax\n" +" capture-syntactic-environment\n" +" sc-macro-transformer\n" +" rsc-macro-transformer\n" +" er-macro-transformer\n" +" ir-macro-transformer\n" +" strip-syntax\n" +" define-macro))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_base = +"(define-library (scheme base)\n" +" (import (picrin base)\n" +" (picrin list)\n" +" (picrin symbol)\n" +" (picrin macro))\n" +"\n" +" (export define set! lambda quote\n" +" if begin define-syntax)\n" +"\n" +" ;; core syntax\n" +"\n" +" (define-syntax syntax-error\n" +" (er-macro-transformer\n" +" (lambda (expr rename compare)\n" +" (apply error (cdr expr)))))\n" +"\n" +" (define-syntax define-auxiliary-syntax\n" +" (er-macro-transformer\n" +" (lambda (expr r c)\n" +" (list (r 'define-syntax) (cadr expr)\n" +" (list (r 'lambda) '_\n" +" (list (r 'error) \"invalid use of auxiliary syntax\"))))))\n" +"\n" +" (define-auxiliary-syntax else)\n" +" (define-auxiliary-syntax =>)\n" +" (define-auxiliary-syntax _)\n" +" (define-auxiliary-syntax ...)\n" +" (define-auxiliary-syntax unquote)\n" +" (define-auxiliary-syntax unquote-splicing)\n" +"\n" +" (define-syntax let\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (if (symbol? (cadr expr))\n" +" (begin\n" +" (define name (car (cdr expr)))\n" +" (define bindings (car (cdr (cdr expr))))\n" +" (define body (cdr (cdr (cdr expr))))\n" +" (list (r 'let) '()\n" +" (list (r 'define) name\n" +" (cons (r 'lambda) (cons (map car bindings) body)))\n" +" (cons name (map cadr bindings))))\n" +" (begin\n" +" (set! bindings (cadr expr))\n" +" (set! body (cddr expr))\n" +" (cons (cons (r 'lambda) (cons (map car bindings) body))\n" +" (map cadr bindings)))))))\n" +"\n" +" (define-syntax cond\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((clauses (cdr expr)))\n" +" (if (null? clauses)\n" +" #f\n" +" (begin\n" +" (define clause (car clauses))\n" +" (if (compare (r 'else) (car clause))\n" +" (cons (r 'begin) (cdr clause))\n" +" (if (if (>= (length clause) 2)\n" +" (compare (r '=>) (list-ref clause 1))\n" +" #f)\n" +" (list (r 'let) (list (list (r 'x) (car clause)))\n" +" (list (r 'if) (r 'x)\n" +" (list (list-ref clause 2) (r 'x))\n" +" (cons (r 'cond) (cdr clauses))))\n" +" (list (r 'if) (car clause)\n" +" (cons (r 'begin) (cdr clause))\n" +" (cons (r 'cond) (cdr clauses)))))))))))\n" +"\n" +" (define-syntax and\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((exprs (cdr expr)))\n" +" (cond\n" +" ((null? exprs)\n" +" #t)\n" +" ((= (length exprs) 1)\n" +" (car exprs))\n" +" (else\n" +" (list (r 'let) (list (list (r 'it) (car exprs)))\n" +" (list (r 'if) (r 'it)\n" +" (cons (r 'and) (cdr exprs))\n" +" (r 'it)))))))))\n" +"\n" +" (define-syntax or\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((exprs (cdr expr)))\n" +" (cond\n" +" ((null? exprs)\n" +" #t)\n" +" ((= (length exprs) 1)\n" +" (car exprs))\n" +" (else\n" +" (list (r 'let) (list (list (r 'it) (car exprs)))\n" +" (list (r 'if) (r 'it)\n" +" (r 'it)\n" +" (cons (r 'or) (cdr exprs))))))))))\n" +"\n" +" (define-syntax quasiquote\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare)\n" +"\n" +" (define (quasiquote? form)\n" +" (and (pair? form) (compare (car form) 'quasiquote)))\n" +"\n" +" (define (unquote? form)\n" +" (and (pair? form) (compare (car form) 'unquote)))\n" +"\n" +" (define (unquote-splicing? form)\n" +" (and (pair? form) (pair? (car form))\n" +" (compare (car (car form)) '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 'list\n" +" (list 'quote (inject 'unquote))\n" +" (qq (- depth 1) (car (cdr expr))))))\n" +" ;; unquote-splicing\n" +" ((unquote-splicing? expr)\n" +" (if (= depth 1)\n" +" (list 'append\n" +" (car (cdr (car expr)))\n" +" (qq depth (cdr expr)))\n" +" (list 'cons\n" +" (list 'list\n" +" (list 'quote (inject 'unquote-splicing))\n" +" (qq (- depth 1) (car (cdr (car expr)))))\n" +" (qq depth (cdr expr)))))\n" +" ;; quasiquote\n" +" ((quasiquote? expr)\n" +" (list 'list\n" +" (list 'quote (inject 'quasiquote))\n" +" (qq (+ depth 1) (car (cdr expr)))))\n" +" ;; list\n" +" ((pair? expr)\n" +" (list 'cons\n" +" (qq depth (car expr))\n" +" (qq depth (cdr expr))))\n" +" ;; vector\n" +" ((vector? expr)\n" +" (list 'list->vector (qq depth (vector->list expr))))\n" +" ;; simple datum\n" +" (else\n" +" (list '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 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-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" +" (import (scheme read) (scheme file))\n" +"\n" +" (define-syntax include\n" +" (letrec ((read-file\n" +" (lambda (filename)\n" +" (let ((port (open-input-file filename)))\n" +" (dynamic-wind\n" +" (lambda () #f)\n" +" (lambda ()\n" +" (let loop ((expr (read port)) (exprs '()))\n" +" (if (eof-object? expr)\n" +" (reverse exprs)\n" +" (loop (read port) (cons expr exprs)))))\n" +" (lambda ()\n" +" (close-port port)))))))\n" +" (er-macro-transformer\n" +" (lambda (form rename compare)\n" +" (let ((filenames (cdr form)))\n" +" (let ((exprs (apply append (map read-file filenames))))\n" +" `(,(rename 'begin) ,@exprs)))))))\n" +"\n" +" (export let let* letrec letrec*\n" +" quasiquote unquote unquote-splicing\n" +" and or\n" +" cond case else =>\n" +" do when unless\n" +" let-syntax letrec-syntax\n" +" include\n" +" _ ... syntax-error)\n" +"\n" +"\n" +" ;; utility functions\n" +"\n" +" (define (walk proc expr)\n" +" (cond\n" +" ((null? expr)\n" +" '())\n" +" ((pair? expr)\n" +" (cons (walk proc (car expr))\n" +" (walk proc (cdr expr))))\n" +" ((vector? expr)\n" +" (list->vector (map proc (vector->list expr))))\n" +" (else\n" +" (proc expr))))\n" +"\n" +" (define (flatten expr)\n" +" (let ((list '()))\n" +" (walk\n" +" (lambda (x)\n" +" (set! list (cons x list)))\n" +" expr)\n" +" (reverse list)))\n" +"\n" +" (define (reverse* l)\n" +" ;; (reverse* '(a b c d . e)) => (e d c b a)\n" +" (let loop ((a '())\n" +" (d l))\n" +" (if (pair? d)\n" +" (loop (cons (car d) a) (cdr d))\n" +" (cons d a))))\n" +"\n" +" (define (every? pred l)\n" +" (if (null? l)\n" +" #t\n" +" (and (pred (car l)) (every? pred (cdr l)))))\n" +"\n" +"\n" +" ;; extra syntax\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 uniq\n" +" (let ((counter 0))\n" +" (lambda (x)\n" +" (let ((sym (string->symbol (string-append \"var$\" (number->string counter)))))\n" +" (set! counter (+ counter 1))\n" +" sym))))\n" +"\n" +" (define-syntax define-values\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare)\n" +" (let* ((formal (cadr form))\n" +" (formal* (walk uniq formal))\n" +" (exprs (cddr form)))\n" +" `(begin\n" +" ,@(map\n" +" (lambda (var) `(define ,var #f))\n" +" (flatten formal))\n" +" (call-with-values (lambda () ,@exprs)\n" +" (lambda ,formal*\n" +" ,@(map\n" +" (lambda (var val) `(set! ,var ,val))\n" +" (flatten formal)\n" +" (flatten formal*)))))))))\n" +"\n" +" (export let-values\n" +" let*-values\n" +" define-values)\n" +"\n" +" (define-syntax syntax-rules\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (define _define (r 'define))\n" +" (define _let (r 'let))\n" +" (define _if (r 'if))\n" +" (define _begin (r 'begin))\n" +" (define _lambda (r 'lambda))\n" +" (define _set! (r 'set!))\n" +" (define _not (r 'not))\n" +" (define _and (r 'and))\n" +" (define _car (r 'car))\n" +" (define _cdr (r 'cdr))\n" +" (define _cons (r 'cons))\n" +" (define _pair? (r 'pair?))\n" +" (define _null? (r 'null?))\n" +" (define _symbol? (r 'symbol?))\n" +" (define _vector? (r 'vector?))\n" +" (define _eqv? (r 'eqv?))\n" +" (define _string=? (r 'string=?))\n" +" (define _map (r 'map))\n" +" (define _vector->list (r 'vector->list))\n" +" (define _list->vector (r 'list->vector))\n" +" (define _quote (r 'quote))\n" +" (define _quasiquote (r 'quasiquote))\n" +" (define _unquote (r 'unquote))\n" +" (define _unquote-splicing (r 'unquote-splicing))\n" +" (define _syntax-error (r 'syntax-error))\n" +" (define _call/cc (r 'call/cc))\n" +" (define _er-macro-transformer (r 'er-macro-transformer))\n" +"\n" +" (define (var->sym v)\n" +" (let loop ((cnt 0)\n" +" (v v))\n" +" (if (symbol? v)\n" +" (string->symbol\n" +" (string-append (symbol->string v) \"/\" (number->string cnt)))\n" +" (loop (+ 1 cnt) (car v)))))\n" +"\n" +" (define push-var list)\n" +"\n" +" (define (compile-match ellipsis literals pattern)\n" +" (letrec ((compile-match-base\n" +" (lambda (pattern)\n" +" (cond ((member pattern literals compare)\n" +" (values\n" +" `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))\n" +" #f\n" +" (exit #f))\n" +" '()))\n" +" ((compare pattern (r '_)) (values #f '()))\n" +" ((and ellipsis (compare pattern ellipsis))\n" +" (values `(,_syntax-error \"invalid pattern\") '()))\n" +" ((symbol? pattern)\n" +" (values `(,_set! ,(var->sym pattern) expr) (list pattern)))\n" +" ((pair? pattern)\n" +" (compile-match-list pattern))\n" +" ((vector? pattern)\n" +" (compile-match-vector pattern))\n" +" ((string? pattern)\n" +" (values\n" +" `(,_if (,_not (,_string=? ',pattern expr))\n" +" (exit #f))\n" +" '()))\n" +" (else\n" +" (values\n" +" `(,_if (,_not (,_eqv? ',pattern expr))\n" +" (exit #f))\n" +" '())))))\n" +"\n" +" (compile-match-list\n" +" (lambda (pattern)\n" +" (let loop ((pattern pattern)\n" +" (matches '())\n" +" (vars '())\n" +" (accessor 'expr))\n" +" (cond ;; (hoge)\n" +" ((not (pair? (cdr pattern)))\n" +" (let*-values (((match1 vars1) (compile-match-base (car pattern)))\n" +" ((match2 vars2) (compile-match-base (cdr pattern))))\n" +" (values\n" +" `(,_begin ,@(reverse matches)\n" +" (,_if (,_pair? ,accessor)\n" +" (,_begin\n" +" (,_let ((expr (,_car ,accessor)))\n" +" ,match1)\n" +" (,_let ((expr (,_cdr ,accessor)))\n" +" ,match2))\n" +" (exit #f)))\n" +" (append vars (append vars1 vars2)))))\n" +" ;; (hoge ... rest args)\n" +" ((and ellipsis (compare (cadr pattern) ellipsis))\n" +" (let-values (((match-r vars-r) (compile-match-list-reverse pattern)))\n" +" (values\n" +" `(,_begin ,@(reverse matches)\n" +" (,_let ((expr (,_let loop ((a ())\n" +" (d ,accessor))\n" +" (,_if (,_pair? d)\n" +" (loop (,_cons (,_car d) a) (,_cdr d))\n" +" (,_cons d a)))))\n" +" ,match-r))\n" +" (append vars vars-r))))\n" +" (else\n" +" (let-values (((match1 vars1) (compile-match-base (car pattern))))\n" +" (loop (cdr pattern)\n" +" (cons `(,_if (,_pair? ,accessor)\n" +" (,_let ((expr (,_car ,accessor)))\n" +" ,match1)\n" +" (exit #f))\n" +" matches)\n" +" (append vars vars1)\n" +" `(,_cdr ,accessor))))))))\n" +"\n" +" (compile-match-list-reverse\n" +" (lambda (pattern)\n" +" (let loop ((pattern (reverse* pattern))\n" +" (matches '())\n" +" (vars '())\n" +" (accessor 'expr))\n" +" (cond ((and ellipsis (compare (car pattern) ellipsis))\n" +" (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))\n" +" (values\n" +" `(,_begin ,@(reverse matches)\n" +" (,_let ((expr ,accessor))\n" +" ,match1))\n" +" (append vars vars1))))\n" +" (else\n" +" (let-values (((match1 vars1) (compile-match-base (car pattern))))\n" +" (loop (cdr pattern)\n" +" (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)\n" +" (append vars vars1)\n" +" `(,_cdr ,accessor))))))))\n" +"\n" +" (compile-match-ellipsis\n" +" (lambda (pattern)\n" +" (let-values (((match vars) (compile-match-base pattern)))\n" +" (values\n" +" `(,_let loop ((expr expr))\n" +" (,_if (,_not (,_null? expr))\n" +" (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)\n" +" (,_let ((expr (,_car expr)))\n" +" ,match)\n" +" ,@(map\n" +" (lambda (var)\n" +" `(,_set! ,(var->sym (push-var var))\n" +" (,_cons ,(var->sym var) ,(var->sym (push-var var)))))\n" +" vars)\n" +" (loop (,_cdr expr)))))\n" +" (map push-var vars)))))\n" +"\n" +" (compile-match-vector\n" +" (lambda (pattern)\n" +" (let-values (((match vars) (compile-match-base (vector->list pattern))))\n" +" (values\n" +" `(,_if (,_vector? expr)\n" +" (,_let ((expr (,_vector->list expr)))\n" +" ,match)\n" +" (exit #f))\n" +" vars)))))\n" +"\n" +" (let-values (((match vars) (compile-match-base (cdr pattern))))\n" +" (values `(,_let ((expr (,_cdr expr)))\n" +" ,match\n" +" #t)\n" +" vars))))\n" +"\n" +" ;;; compile expand\n" +" (define (compile-expand ellipsis reserved template)\n" +" (letrec ((compile-expand-base\n" +" (lambda (template ellipsis-valid)\n" +" (cond ((member template reserved eq?)\n" +" (values (var->sym template) (list template)))\n" +" ((symbol? template)\n" +" (values `(rename ',template) '()))\n" +" ((pair? template)\n" +" (compile-expand-list template ellipsis-valid))\n" +" ((vector? template)\n" +" (compile-expand-vector template ellipsis-valid))\n" +" (else\n" +" (values `',template '())))))\n" +"\n" +" (compile-expand-list\n" +" (lambda (template ellipsis-valid)\n" +" (let loop ((template template)\n" +" (expands '())\n" +" (vars '()))\n" +" (cond ;; (... hoge)\n" +" ((and ellipsis-valid\n" +" (pair? template)\n" +" (compare (car template) ellipsis))\n" +" (if (and (pair? (cdr template)) (null? (cddr template)))\n" +" (compile-expand-base (cadr template) #f)\n" +" (values '(,_syntax-error \"invalid template\") '())))\n" +" ;; hoge\n" +" ((not (pair? template))\n" +" (let-values (((expand1 vars1)\n" +" (compile-expand-base template ellipsis-valid)))\n" +" (values\n" +" `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))\n" +" (append vars vars1))))\n" +" ;; (a ... rest syms)\n" +" ((and ellipsis-valid\n" +" (pair? (cdr template))\n" +" (compare (cadr template) ellipsis))\n" +" (let-values (((expand1 vars1)\n" +" (compile-expand-base (car template) ellipsis-valid)))\n" +" (loop (cddr template)\n" +" (cons\n" +" `(,_unquote-splicing\n" +" (,_map (,_lambda ,(map var->sym vars1) ,expand1)\n" +" ,@(map (lambda (v) (var->sym (push-var v))) vars1)))\n" +" expands)\n" +" (append vars (map push-var vars1)))))\n" +" (else\n" +" (let-values (((expand1 vars1)\n" +" (compile-expand-base (car template) ellipsis-valid)))\n" +" (loop (cdr template)\n" +" (cons\n" +" `(,_unquote ,expand1)\n" +" expands)\n" +" (append vars vars1))))))))\n" +"\n" +" (compile-expand-vector\n" +" (lambda (template ellipsis-valid)\n" +" (let-values (((expand1 vars1)\n" +" (compile-expand-base (vector->list template) ellipsis-valid)))\n" +" (values\n" +" `(,_list->vector ,expand1)\n" +" vars1)))))\n" +"\n" +" (compile-expand-base template ellipsis)))\n" +"\n" +" (define (check-vars vars-pattern vars-template)\n" +" ;;fixme\n" +" #t)\n" +"\n" +" (define (compile-rule ellipsis literals rule)\n" +" (let ((pattern (car rule))\n" +" (template (cadr rule)))\n" +" (let*-values (((match vars-match)\n" +" (compile-match ellipsis literals pattern))\n" +" ((expand vars-expand)\n" +" (compile-expand ellipsis (flatten vars-match) template)))\n" +" (if (check-vars vars-match vars-expand)\n" +" (list vars-match match expand)\n" +" 'mismatch))))\n" +"\n" +" (define (expand-clauses clauses rename)\n" +" (cond ((null? clauses)\n" +" `(,_quote (syntax-error \"no matching pattern\")))\n" +" ((compare (car clauses) 'mismatch)\n" +" `(,_syntax-error \"invalid rule\"))\n" +" (else\n" +" (let ((vars (list-ref (car clauses) 0))\n" +" (match (list-ref (car clauses) 1))\n" +" (expand (list-ref (car clauses) 2)))\n" +" `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)\n" +" (,_let ((result (,_call/cc (,_lambda (exit) ,match))))\n" +" (,_if result\n" +" ,expand\n" +" ,(expand-clauses (cdr clauses) rename))))))))\n" +"\n" +" (define (normalize-form form)\n" +" (if (and (list? form) (>= (length form) 2))\n" +" (let ((ellipsis '...)\n" +" (literals (cadr form))\n" +" (rules (cddr form)))\n" +"\n" +" (when (symbol? literals)\n" +" (set! ellipsis literals)\n" +" (set! literals (car rules))\n" +" (set! rules (cdr rules)))\n" +"\n" +" (if (and (symbol? ellipsis)\n" +" (list? literals)\n" +" (every? symbol? literals)\n" +" (list? rules)\n" +" (every? (lambda (l) (and (list? l) (= (length l) 2))) rules))\n" +" (if (member ellipsis literals compare)\n" +" `(syntax-rules #f ,literals ,@rules)\n" +" `(syntax-rules ,ellipsis ,literals ,@rules))\n" +" #f))\n" +" #f))\n" +"\n" +" (let ((form (normalize-form form)))\n" +" (if form\n" +" (let ((ellipsis (list-ref form 1))\n" +" (literals (list-ref form 2))\n" +" (rules (list-tail form 3)))\n" +" (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))\n" +" rules)))\n" +" `(,_er-macro-transformer\n" +" (,_lambda (expr rename cmp)\n" +" ,(expand-clauses clauses r)))))\n" +"\n" +" `(,_syntax-error \"malformed syntax-rules\"))))))\n" +"\n" +" (export syntax-rules)\n" +"\n" +"\n" +" ;; 4.2.6. Dynamic bindings\n" +"\n" +" (import (picrin parameter))\n" +"\n" +" (define-syntax parameterize\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare)\n" +" (let ((formal (car (cdr form)))\n" +" (body (cdr (cdr form))))\n" +" (let ((vars (map car formal))\n" +" (vals (map cadr formal)))\n" +" `(begin\n" +" ,@(map (lambda (var val) `(parameter-push! ,var ,val)) vars vals)\n" +" (let ((result (begin ,@body)))\n" +" ,@(map (lambda (var) `(parameter-pop! ,var)) vars)\n" +" result)))))))\n" +"\n" +" (export parameterize make-parameter)\n" +"\n" +"\n" +" ;; 4.2.7. Exception handling\n" +"\n" +" (define-syntax guard-aux\n" +" (syntax-rules (else =>)\n" +" ((guard-aux reraise (else result1 result2 ...))\n" +" (begin result1 result2 ...))\n" +" ((guard-aux reraise (test => result))\n" +" (let ((temp test))\n" +" (if temp\n" +" (result temp)\n" +" reraise)))\n" +" ((guard-aux reraise (test => result)\n" +" clause1 clause2 ...)\n" +" (let ((temp test))\n" +" (if temp\n" +" (result temp)\n" +" (guard-aux reraise clause1 clause2 ...))))\n" +" ((guard-aux reraise (test))\n" +" (or test reraise))\n" +" ((guard-aux reraise (test) clause1 clause2 ...)\n" +" (let ((temp test))\n" +" (if temp\n" +" temp\n" +" (guard-aux reraise clause1 clause2 ...))))\n" +" ((guard-aux reraise (test result1 result2 ...))\n" +" (if test\n" +" (begin result1 result2 ...)\n" +" reraise))\n" +" ((guard-aux reraise\n" +" (test result1 result2 ...)\n" +" clause1 clause2 ...)\n" +" (if test\n" +" (begin result1 result2 ...)\n" +" (guard-aux reraise clause1 clause2 ...)))))\n" +"\n" +" (define-syntax guard\n" +" (syntax-rules ()\n" +" ((guard (var clause ...) e1 e2 ...)\n" +" ((call/cc\n" +" (lambda (guard-k)\n" +" (with-exception-handler\n" +" (lambda (condition)\n" +" ((call/cc\n" +" (lambda (handler-k)\n" +" (guard-k\n" +" (lambda ()\n" +" (let ((var condition))\n" +" (guard-aux\n" +" (handler-k\n" +" (lambda ()\n" +" (raise-continuable condition)))\n" +" clause ...))))))))\n" +" (lambda ()\n" +" (call-with-values\n" +" (lambda () e1 e2 ...)\n" +" (lambda args\n" +" (guard-k\n" +" (lambda ()\n" +" (apply values args)))))))))))))\n" +"\n" +" (export guard)\n" +"\n" +" ;; 5.5 Recored-type definitions\n" +"\n" +" (import (picrin record)\n" +" (scheme write))\n" +"\n" +" (define ((default-record-writer ctor) obj)\n" +" (let ((port (open-output-string)))\n" +" (display \"#.(\" port)\n" +" (display (car ctor) port)\n" +" (for-each\n" +" (lambda (field)\n" +" (display \" \" port)\n" +" (write (record-ref obj field) port))\n" +" (cdr ctor))\n" +" (display \")\" port)\n" +" (get-output-string port)))\n" +"\n" +" (define ((boot-make-record-type ) name ctor)\n" +" (let ((rectype (make-record )))\n" +" (record-set! rectype 'name name)\n" +" (record-set! rectype 'writer (default-record-writer ctor))\n" +" rectype))\n" +"\n" +" (define \n" +" (let ((\n" +" ((boot-make-record-type #t) 'record-type '(record-type name writer))))\n" +" (record-set! '@@type )\n" +" ))\n" +"\n" +" (define make-record-type (boot-make-record-type ))\n" +"\n" +" (define-syntax define-record-constructor\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare?)\n" +" (let ((rectype (car (cdr form)))\n" +" (name (car (cdr (cdr form))))\n" +" (fields (cdr (cdr (cdr form)))))\n" +" `(define (,name ,@fields)\n" +" (let ((record (make-record ,rectype)))\n" +" ,@(map (lambda (field)\n" +" `(record-set! record ',field ,field))\n" +" fields)\n" +" record))))))\n" +"\n" +" (define-syntax define-record-predicate\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare?)\n" +" (let ((rectype (car (cdr form)))\n" +" (name (car (cdr (cdr form)))))\n" +" `(define (,name obj)\n" +" (and (record? obj)\n" +" (eq? (record-type obj)\n" +" ,rectype)))))))\n" +"\n" +" (define-syntax define-record-field\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare?)\n" +" (let ((pred (car (cdr form)))\n" +" (field-name (car (cdr (cdr form))))\n" +" (accessor (car (cdr (cdr (cdr form)))))\n" +" (modifier? (cdr (cdr (cdr (cdr form))))))\n" +" (if (null? modifier?)\n" +" `(define (,accessor record)\n" +" (if (,pred record)\n" +" (record-ref record ',field-name)\n" +" (error \"wrong record type\" record)))\n" +" `(begin\n" +" (define (,accessor record)\n" +" (if (,pred record)\n" +" (record-ref record ',field-name)\n" +" (error \"wrong record type\" record)))\n" +" (define (,(car modifier?) record val)\n" +" (if (,pred record)\n" +" (record-set! record ',field-name val)\n" +" (error \"wrong record type\" record)))))))))\n" +"\n" +" (define-syntax define-record-type\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare?)\n" +" (let ((name (car (cdr form)))\n" +" (ctor (car (cdr (cdr form))))\n" +" (pred (car (cdr (cdr (cdr form)))))\n" +" (fields (cdr (cdr (cdr (cdr form))))))\n" +" `(begin\n" +" (define ,name (make-record-type ',name ',ctor))\n" +" (define-record-constructor ,name ,@ctor)\n" +" (define-record-predicate ,name ,pred)\n" +" ,@(map (lambda (field) `(define-record-field ,pred ,@field))\n" +" fields))))))\n" +"\n" +" (export define-record-type)\n" +"\n" +" ;; 6.4 Pairs and lists\n" +"\n" +" (export pair?\n" +" cons\n" +" car\n" +" cdr\n" +" set-car!\n" +" set-cdr!\n" +" null?\n" +" caar\n" +" cadr\n" +" cdar\n" +" cddr\n" +" list?\n" +" make-list\n" +" list\n" +" length\n" +" append\n" +" reverse\n" +" list-tail\n" +" list-ref\n" +" list-set!\n" +" list-copy\n" +" memq\n" +" memv\n" +" member\n" +" assq\n" +" assv\n" +" assoc)\n" +"\n" +" ;; 6.5 Symbols\n" +"\n" +" (export symbol?\n" +" symbol=?\n" +" symbol->string\n" +" string->symbol)\n" +"\n" +" ;; 6.6 Characters\n" +"\n" +" (define-macro (define-char-transitive-predicate name op)\n" +" `(define (,name . cs)\n" +" (apply ,op (map char->integer cs))))\n" +"\n" +" (define-char-transitive-predicate char=? =)\n" +" (define-char-transitive-predicate char? >)\n" +" (define-char-transitive-predicate char<=? <=)\n" +" (define-char-transitive-predicate char>=? >=)\n" +"\n" +" (export char=?\n" +" char?\n" +" char<=?\n" +" char>=?)\n" +"\n" +" ;; 6.7 String\n" +"\n" +" (define (string->list string . opts)\n" +" (let ((start (if (pair? opts) (car opts) 0))\n" +" (end (if (>= (length opts) 2)\n" +" (cadr opts)\n" +" (string-length string))))\n" +" (do ((i start (+ i 1))\n" +" (res '()))\n" +" ((= i end)\n" +" (reverse res))\n" +" (set! res (cons (string-ref string i) res)))))\n" +"\n" +" (define (list->string list)\n" +" (let ((len (length list)))\n" +" (let ((v (make-string len)))\n" +" (do ((i 0 (+ i 1))\n" +" (l list (cdr l)))\n" +" ((= i len)\n" +" v)\n" +" (string-set! v i (car l))))))\n" +"\n" +" (define (string . objs)\n" +" (list->string objs))\n" +"\n" +" (export string string->list list->string)\n" +"\n" +" ;; 6.8. Vector\n" +"\n" +" (define (vector . objs)\n" +" (list->vector objs))\n" +"\n" +" (define (vector->string . args)\n" +" (list->string (apply vector->list args)))\n" +"\n" +" (define (string->vector . args)\n" +" (list->vector (apply string->list args)))\n" +"\n" +" (export vector vector->string string->vector)\n" +"\n" +" ;; 6.9 bytevector\n" +"\n" +" (define (bytevector->list v start end)\n" +" (do ((i start (+ i 1))\n" +" (res '()))\n" +" ((= i end)\n" +" (reverse res))\n" +" (set! res (cons (bytevector-u8-ref v i) res))))\n" +"\n" +" (define (list->bytevector list)\n" +" (let ((len (length list)))\n" +" (let ((v (make-bytevector len)))\n" +" (do ((i 0 (+ i 1))\n" +" (l list (cdr l)))\n" +" ((= i len)\n" +" v)\n" +" (bytevector-u8-set! v i (car l))))))\n" +"\n" +" (define (bytevector . objs)\n" +" (list->bytevector objs))\n" +"\n" +" (define (utf8->string v . opts)\n" +" (let ((start (if (pair? opts) (car opts) 0))\n" +" (end (if (>= (length opts) 2)\n" +" (cadr opts)\n" +" (bytevector-length v))))\n" +" (list->string (map integer->char (bytevector->list v start end)))))\n" +"\n" +" (define (string->utf8 s . opts)\n" +" (let ((start (if (pair? opts) (car opts) 0))\n" +" (end (if (>= (length opts) 2)\n" +" (cadr opts)\n" +" (string-length s))))\n" +" (list->bytevector (map char->integer (string->list s start end)))))\n" +"\n" +" (export bytevector\n" +" bytevector->list\n" +" list->bytevector\n" +" utf8->string\n" +" string->utf8)\n" +"\n" +" ;; 6.10 control features\n" +"\n" +" (define (string-map f . strings)\n" +" (list->string (apply map f (map string->list strings))))\n" +"\n" +" (define (string-for-each f . strings)\n" +" (apply for-each f (map string->list strings)))\n" +"\n" +" (define (vector-map f . vectors)\n" +" (list->vector (apply map f (map vector->list vectors))))\n" +"\n" +" (define (vector-for-each f . vectors)\n" +" (apply for-each f (map vector->list vectors)))\n" +"\n" +" (export string-map string-for-each\n" +" vector-map vector-for-each)\n" +"\n" +" ;; 6.13. Input and output\n" +"\n" +" (define (call-with-port port proc)\n" +" (dynamic-wind\n" +" (lambda () #f)\n" +" (lambda () (proc port))\n" +" (lambda () (close-port port))))\n" +"\n" +" (export call-with-port))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_record = +"(define-library (picrin record)\n" +" (import (scheme base))\n" +"\n" +" (define (define-record-writer* record-type writer)\n" +" (record-set! record-type 'writer writer))\n" +"\n" +" (define-syntax define-record-writer\n" +" (syntax-rules ()\n" +" ((_ (type obj) body ...)\n" +" (define-record-writer* type\n" +" (lambda (obj)\n" +" body ...)))\n" +" ((_ type writer)\n" +" (define-record-writer* type\n" +" writer))))\n" +"\n" +" (export define-record-writer))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_array = +"(define-library (picrin array)\n" +" (import (scheme base)\n" +" (scheme write)\n" +" (picrin record))\n" +"\n" +" (define-record-type \n" +" (create-array data size head tail)\n" +" array?\n" +" (data array-data set-array-data!)\n" +" (size array-size set-array-size!)\n" +" (head array-head set-array-head!)\n" +" (tail array-tail set-array-tail!))\n" +"\n" +" (define (translate ary i)\n" +" (floor-remainder i (array-size ary)))\n" +"\n" +" (define (array-length ary)\n" +" (let ((size (- (array-tail ary) (array-head ary))))\n" +" (translate ary size)))\n" +"\n" +" (define (array-rotate! ary)\n" +" (when (< (array-tail ary) (array-head ary))\n" +" (let ((xs (vector-copy (array-data ary) 0 (array-head ary)))\n" +" (ys (vector-copy (array-data ary) (array-head ary))))\n" +" (set-array-data! ary (vector-append ys xs))\n" +" (set-array-tail! ary (array-length ary))\n" +" (set-array-head! ary 0))))\n" +"\n" +" (define (array-reserve! ary size)\n" +" (set! size (+ size 1)) ; capa == size - 1\n" +" (when (< (array-size ary) size)\n" +" (array-rotate! ary)\n" +" (set-array-data! ary (vector-append\n" +" (array-data ary)\n" +" (make-vector (- size (array-size ary)))))\n" +" (set-array-size! ary size)))\n" +"\n" +" (define (make-array . rest)\n" +" (if (null? rest)\n" +" (make-array 0)\n" +" (let ((capacity (car rest))\n" +" (ary (create-array (vector) 0 0 0)))\n" +" (array-reserve! ary capacity)\n" +" ary)))\n" +"\n" +" (define (array-ref ary i)\n" +" (let ((data (array-data ary)))\n" +" (vector-ref data (translate ary (+ (array-head ary) i)))))\n" +"\n" +" (define (array-set! ary i obj)\n" +" (let ((data (array-data ary)))\n" +" (vector-set! data (translate ary (+ (array-head ary) i)) obj)))\n" +"\n" +" (define (array-push! ary obj)\n" +" (array-reserve! ary (+ (array-length ary) 1))\n" +" (array-set! ary (array-length ary) obj)\n" +" (set-array-tail! ary (translate ary (+ (array-tail ary) 1))))\n" +"\n" +" (define (array-pop! ary)\n" +" (set-array-tail! ary (translate ary (- (array-tail ary) 1)))\n" +" (array-ref ary (array-length ary)))\n" +"\n" +" (define (array-shift! ary)\n" +" (set-array-head! ary (translate ary (+ (array-head ary) 1)))\n" +" (array-ref ary -1))\n" +"\n" +" (define (array-unshift! ary obj)\n" +" (array-reserve! ary (+ (array-length ary) 1))\n" +" (array-set! ary -1 obj)\n" +" (set-array-head! ary (translate ary (- (array-head ary) 1))))\n" +"\n" +" (define (array->list ary)\n" +" (do ((i 0 (+ i 1))\n" +" (x '() (cons (array-ref ary i) x)))\n" +" ((= i (array-length ary))\n" +" (reverse x))))\n" +"\n" +" (define (list->array list)\n" +" (let ((ary (make-array)))\n" +" (for-each (lambda (x) (array-push! ary x)) list)\n" +" ary))\n" +"\n" +" (define (array . objs)\n" +" (list->array objs))\n" +"\n" +" (define (array-map proc ary)\n" +" (list->array (map proc (array->list ary))))\n" +"\n" +" (define (array-for-each proc ary)\n" +" (for-each proc (array->list ary)))\n" +"\n" +" (define-record-writer ( array)\n" +" (call-with-port (open-output-string)\n" +" (lambda (port)\n" +" (display \"#.(array\" port)\n" +" (array-for-each\n" +" (lambda (obj)\n" +" (display \" \" port)\n" +" (write obj port))\n" +" array)\n" +" (display \")\" port)\n" +" (get-output-string port))))\n" +"\n" +" (export make-array\n" +" array\n" +" array?\n" +" array-length\n" +" array-ref\n" +" array-set!\n" +" array-push!\n" +" array-pop!\n" +" array-shift!\n" +" array-unshift!\n" +" array-map\n" +" array-for-each\n" +" array->list\n" +" list->array))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_dictionary = +"(define-library (picrin dictionary)\n" +" (import (scheme base))\n" +"\n" +" (define (dictionary-map proc dict)\n" +" (let ((kvs '()))\n" +" (dictionary-for-each\n" +" (lambda (key val)\n" +" (set! kvs (cons (proc key val) kvs)))\n" +" dict)\n" +" (reverse kvs)))\n" +"\n" +" (define (dictionary->plist dict)\n" +" (let ((kvs '()))\n" +" (dictionary-for-each\n" +" (lambda (key val)\n" +" (set! kvs (cons val (cons key kvs))))\n" +" dict)\n" +" (reverse kvs)))\n" +"\n" +" (define (plist->dictionary plist)\n" +" (let ((dict (make-dictionary)))\n" +" (do ((kv plist (cddr kv)))\n" +" ((null? kv)\n" +" dict)\n" +" (dictionary-set! dict (car kv) (cadr kv)))))\n" +"\n" +" (define (dictionary->alist dict)\n" +" (dictionary-map\n" +" (lambda (key val)\n" +" (cons key val))\n" +" dict))\n" +"\n" +" (define (alist->dictionary alist)\n" +" (let ((dict (make-dictionary)))\n" +" (do ((kv alist (cdr kv)))\n" +" ((null? kv)\n" +" dict)\n" +" (dictionary-set! dict (car kv) (cdr kv)))))\n" +"\n" +" (define (dictionary . plist)\n" +" (plist->dictionary plist))\n" +"\n" +" (export dictionary\n" +" dictionary-map\n" +" dictionary->plist\n" +" plist->dictionary\n" +" dictionary->alist\n" +" alist->dictionary))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_test = +"(define-library (picrin test)\n" +" (import (scheme base)\n" +" (scheme write)\n" +" (scheme read)\n" +" (scheme process-context))\n" +" (define test-counter 0)\n" +" (define counter 0)\n" +" (define failure-counter 0)\n" +"\n" +" (define fails '())\n" +"\n" +" (define (print-statistics)\n" +" (newline)\n" +" (display \"Test Result: \")\n" +" (write (- counter failure-counter))\n" +" (display \" / \")\n" +" (write counter)\n" +" (display \" (\")\n" +" (write (* (/ (- counter failure-counter) counter) 100))\n" +" (display \"%)\")\n" +" (display \" [PASS/TOTAL]\")\n" +" (display \"\")\n" +" (newline)\n" +" (for-each\n" +" (lambda (fail)\n" +" (display fail))\n" +" (reverse fails)))\n" +"\n" +" (define (test-begin . o)\n" +" (set! test-counter (+ test-counter 1)))\n" +"\n" +" (define (test-end . o)\n" +" (set! test-counter (- test-counter 1))\n" +" (if (= test-counter 0)\n" +" (print-statistics)))\n" +"\n" +" (define-syntax test\n" +" (syntax-rules ()\n" +" ((test expected expr)\n" +" (let ((res expr))\n" +" (display \"case \")\n" +" (write counter)\n" +" (cond\n" +" ((equal? res expected)\n" +" (display \" PASS: \")\n" +" (write 'expr)\n" +" (display \" equals \")\n" +" (write expected)\n" +" (display \"\")\n" +" (newline)\n" +" )\n" +" ((not (equal? res expected))\n" +" (set! failure-counter (+ failure-counter 1))\n" +" (let ((out (open-output-string)))\n" +" (display \" FAIL: \" out)\n" +" (write 'expr out)\n" +" (newline out)\n" +" (display \" expected \" out)\n" +" (write expected out)\n" +" (display \" but got \" out)\n" +" (write res out)\n" +" (display \"\" out)\n" +" (newline out)\n" +" (let ((str (get-output-string out)))\n" +" (set! fails (cons str fails))\n" +" (display str)))))\n" +" (set! counter (+ counter 1))))))\n" +"\n" +" (define-syntax test-values\n" +" (syntax-rules ()\n" +" ((_ expect expr)\n" +" (test (call-with-values (lambda () expect) (lambda results results))\n" +" (call-with-values (lambda () expr) (lambda results results))))))\n" +"\n" +"\n" +" (define (test-failure-count)\n" +" (length fails))\n" +"\n" +" (define (test-exit)\n" +" (exit (zero? (test-failure-count))))\n" +"\n" +" (define-syntax test-syntax-error\n" +" (syntax-rules ()\n" +" ((_) (syntax-error \"invalid use of test-syntax-error\"))))\n" +"\n" +" (export test test-begin test-end test-values test-exit test-syntax-error))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_experimental_lambda = +"(define-library (picrin experimental lambda)\n" +" (import (scheme base)\n" +" (picrin macro))\n" +"\n" +" (define-syntax destructuring-bind\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare)\n" +" (let ((formal (car (cdr form)))\n" +" (value (car (cdr (cdr form))))\n" +" (body (cdr (cdr (cdr form)))))\n" +" (cond\n" +" ((symbol? formal)\n" +" `(let ((,formal ,value))\n" +" ,@body))\n" +" ((pair? formal)\n" +" `(let ((value# ,value))\n" +" (destructuring-bind ,(car formal) (car value#)\n" +" (destructuring-bind ,(cdr formal) (cdr value#)\n" +" ,@body))))\n" +" ((vector? formal)\n" +" ;; TODO\n" +" (error \"fixme\"))\n" +" (else\n" +" `(if (equal? ,value ',formal)\n" +" (begin\n" +" ,@body)\n" +" (error \"match failure\" ,value ',formal))))))))\n" +"\n" +" (define-syntax destructuring-lambda\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare)\n" +" (let ((args (car (cdr form)))\n" +" (body (cdr (cdr form))))\n" +" `(lambda formal# (destructuring-bind ,args formal# ,@body))))))\n" +"\n" +" (define-syntax destructuring-define\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare)\n" +" (let ((maybe-formal (cadr form)))\n" +" (if (symbol? maybe-formal)\n" +" `(define ,@(cdr form))\n" +" `(destructuring-define ,(car maybe-formal)\n" +" (destructuring-lambda ,(cdr maybe-formal)\n" +" ,@(cddr form))))))))\n" +"\n" +" (export (rename destructuring-bind bind)\n" +" (rename destructuring-lambda lambda)\n" +" (rename destructuring-define define)))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_promise = +"(define-library (picrin promise)\n" +" (import (scheme base)\n" +" (picrin experimental lambda))\n" +"\n" +" (define (identity x)\n" +" x)\n" +"\n" +" (define-record-type \n" +" (create-promise status reactors cache)\n" +" promise?\n" +" (status promise-status set-promise-status!)\n" +" (reactors promise-reactors set-promise-reactors!)\n" +" (cache promise-cache set-promise-cache!))\n" +"\n" +" (define (push-promise-reactor! promise reactor)\n" +" (set-promise-reactors! promise (cons reactor (promise-reactors promise))))\n" +"\n" +" #;\n" +" (define (print x)\n" +" (write x)\n" +" (newline)\n" +" (flush-output-port)\n" +" x)\n" +"\n" +" (define (make-promise handler)\n" +" (let ((self (create-promise 'pending '() #f)))\n" +"\n" +" (define (on-resolved result)\n" +" (when (eq? (promise-status self) 'pending)\n" +" (for-each\n" +" (lambda (((resolve . reject) on-resolved _))\n" +" (call/cc\n" +" (lambda (exit)\n" +" (with-exception-handler\n" +" (lambda (e)\n" +" (reject e)\n" +" (exit #f))\n" +" (lambda ()\n" +" (resolve (on-resolved result)))))))\n" +" (promise-reactors self))\n" +" (set-promise-status! self 'resolved)\n" +" (set-promise-cache! self result)\n" +" (set-promise-reactors! self '())))\n" +"\n" +" (define (on-rejected reason)\n" +" (when (eq? (promise-status 'pending) 'pending)\n" +" (for-each\n" +" (lambda (((resolve . reject) _ on-rejected))\n" +" (call/cc\n" +" (lambda (exit)\n" +" (with-exception-handler\n" +" (lambda (e)\n" +" (reject e)\n" +" (exit #f))\n" +" (lambda ()\n" +" (resolve (on-rejected reason)))))))\n" +" (promise-reactors self))\n" +" (set-promise-status! self 'rejected)\n" +" (set-promise-cache! self reason)\n" +" (set-promise-reactors! self '())))\n" +"\n" +" (handler on-resolved on-rejected)\n" +"\n" +" self))\n" +"\n" +" (define (promise-chain self on-resolved on-rejected)\n" +"\n" +" (define (handler resolve reject)\n" +" (case (promise-status self)\n" +" (pending\n" +" (push-promise-reactor! self `((,resolve . ,reject) ,on-resolved ,on-rejected)))\n" +" (resolved\n" +" (call/cc\n" +" (lambda (exit)\n" +" (with-exception-handler\n" +" (lambda (e)\n" +" (reject e)\n" +" (exit #f))\n" +" (lambda ()\n" +" (resolve (on-resolved (promise-cache self))))))))\n" +" (rejected\n" +" (call/cc\n" +" (lambda (exit)\n" +" (with-exception-handler\n" +" (lambda (e)\n" +" (reject e)\n" +" (exit #f))\n" +" (lambda ()\n" +" (resolve (on-rejected (promise-cache self))))))))))\n" +"\n" +" (make-promise handler))\n" +"\n" +" (define (promise-then self on-resolved)\n" +" (promise-chain self on-resolved identity))\n" +"\n" +" (define (promise-else self on-rejected)\n" +" (promise-chain self identity on-rejected))\n" +"\n" +" (define (promise-all promises)\n" +"\n" +" (define (handler resolve reject)\n" +" (do ((i 0 (+ i 1))\n" +" (x promises (cdr x))\n" +" (c 0)\n" +" (v (make-vector (length promises))))\n" +" ((null? x))\n" +"\n" +" (define (on-resolved result)\n" +" (vector-set! v i result)\n" +" (set! c (+ c 1))\n" +" (when (= c (length promises))\n" +" (resolve (vector->list v))))\n" +"\n" +" (define (on-rejected reason)\n" +" (reject reason))\n" +"\n" +" (promise-chain (car x) on-resolved on-rejected)))\n" +"\n" +" (make-promise handler))\n" +"\n" +" (define (promise-any promises)\n" +"\n" +" (define (handler resolve reject)\n" +" (do ((i 0 (+ i 1))\n" +" (x promises (cdr x))\n" +" (c 0)\n" +" (v (make-vector (length promises))))\n" +" ((null? x))\n" +"\n" +" (define (on-resolved result)\n" +" (resolve result))\n" +"\n" +" (define (on-rejected reason)\n" +" (vector-set! v i reason)\n" +" (set! c (+ c 1))\n" +" (when (= c (length promises))\n" +" (reject (vector->list v))))\n" +"\n" +" (promise-chain (car x) on-resolved on-rejected)))\n" +"\n" +" (make-promise handler))\n" +"\n" +" ; experimental API\n" +" (define (promise-race promises)\n" +" (make-promise\n" +" (lambda (resolve reject)\n" +" (for-each\n" +" (lambda (x)\n" +" (promise-chain x resolve reject))\n" +" promises))))\n" +"\n" +" (export promise?\n" +" make-promise\n" +" promise-then\n" +" promise-else\n" +" promise-all\n" +" promise-any))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_async = +"(define-library (picrin async)\n" +" (import (scheme base)\n" +" (picrin promise))\n" +"\n" +" (define (async-timer ms)\n" +" (make-promise\n" +" (lambda (resolve reject)\n" +" (set-timeout\n" +" (lambda ()\n" +" (resolve #t))\n" +" ms))))\n" +"\n" +" (export async-timer))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_cxr = +";;; Appendix A. Standard Libraries CxR\n" +"\n" +"(define-library (scheme cxr)\n" +" (import (scheme base))\n" +"\n" +" (define (caaar p) (car (caar p)))\n" +" (define (caadr p) (car (cadr p)))\n" +" (define (cadar p) (car (cdar p)))\n" +" (define (caddr p) (car (cddr p)))\n" +" (define (cdaar p) (cdr (caar p)))\n" +" (define (cdadr p) (cdr (cadr p)))\n" +" (define (cddar p) (cdr (cdar p)))\n" +" (define (cdddr p) (cdr (cddr p)))\n" +" (define (caaaar p) (caar (caar p)))\n" +" (define (caaadr p) (caar (cadr p)))\n" +" (define (caadar p) (caar (cdar p)))\n" +" (define (caaddr p) (caar (cddr p)))\n" +" (define (cadaar p) (cadr (caar p)))\n" +" (define (cadadr p) (cadr (cadr p)))\n" +" (define (caddar p) (cadr (cdar p)))\n" +" (define (cadddr p) (cadr (cddr p)))\n" +" (define (cdaaar p) (cdar (caar p)))\n" +" (define (cdaadr p) (cdar (cadr p)))\n" +" (define (cdadar p) (cdar (cdar p)))\n" +" (define (cdaddr p) (cdar (cddr p)))\n" +" (define (cddaar p) (cddr (caar p)))\n" +" (define (cddadr p) (cddr (cadr p)))\n" +" (define (cdddar p) (cddr (cdar p)))\n" +" (define (cddddr p) (cddr (cddr p)))\n" +"\n" +" (export caaar caadr cadar caddr\n" +" cdaar cdadr cddar cdddr\n" +" caaaar caaadr caadar caaddr\n" +" cadaar cadadr caddar cadddr\n" +" cdaaar cdaadr cdadar cdaddr\n" +" cddaar cddadr cdddar cddddr))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_file = +"(define-library (scheme file)\n" +" (import (scheme base))\n" +"\n" +" (define (call-with-input-file filename callback)\n" +" (call-with-port (open-input-file filename) callback))\n" +"\n" +" (define (call-with-output-file filename callback)\n" +" (call-with-port (open-output-file filename) callback))\n" +"\n" +" (define (with-input-from-file filename thunk)\n" +" (call-with-input-file filename\n" +" (lambda (port)\n" +" (parameterize ((current-input-port port))\n" +" (thunk)))))\n" +"\n" +" (define (with-output-to-file filename thunk)\n" +" (call-with-output-file filename\n" +" (lambda (port)\n" +" (parameterize ((current-output-port port))\n" +" (thunk)))))\n" +"\n" +" (export call-with-input-file\n" +" call-with-output-file\n" +" with-input-from-file\n" +" with-output-to-file))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_case_lambda = +"(define-library (scheme case-lambda)\n" +" (import (scheme base))\n" +"\n" +" (define-syntax case-lambda\n" +" (syntax-rules ()\n" +" ((case-lambda (params body0 ...) ...)\n" +" (lambda args\n" +" (let ((len (length args)))\n" +" (letrec-syntax\n" +" ((cl (syntax-rules ::: ()\n" +" ((cl)\n" +" (error \"no matching clause\"))\n" +" ((cl ((p :::) . body) . rest)\n" +" (if (= len (length '(p :::)))\n" +" (apply (lambda (p :::)\n" +" . body)\n" +" args)\n" +" (cl . rest)))\n" +" ((cl ((p ::: . tail) . body)\n" +" . rest)\n" +" (if (>= len (length '(p :::)))\n" +" (apply\n" +" (lambda (p ::: . tail)\n" +" . body)\n" +" args)\n" +" (cl . rest))))))\n" +" (cl (params body0 ...) ...)))))))\n" +"\n" +" (export case-lambda))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_lazy = +";;; Appendix A. Standard Libraries Lazy\n" +"\n" +"(define-library (scheme lazy)\n" +" (import (scheme base)\n" +" (picrin macro))\n" +"\n" +" (define-record-type \n" +" (make-promise% done obj)\n" +" promise?\n" +" (done promise-done? promise-done!)\n" +" (obj promise-value promise-value!))\n" +"\n" +" (define-syntax delay-force\n" +" (ir-macro-transformer\n" +" (lambda (form rename compare?)\n" +" (let ((expr (cadr form)))\n" +" `(make-promise% #f (lambda () ,expr))))))\n" +"\n" +" (define-syntax delay\n" +" (ir-macro-transformer\n" +" (lambda (form rename compare?)\n" +" (let ((expr (cadr form)))\n" +" `(delay-force (make-promise% #t ,expr))))))\n" +"\n" +" (define (promise-update! new old)\n" +" (promise-done! old (promise-done? new))\n" +" (promise-value! old (promise-value new)))\n" +"\n" +" (define (force promise)\n" +" (if (promise-done? promise)\n" +" (promise-value promise)\n" +" (let ((promise* ((promise-value promise))))\n" +" (unless (promise-done? promise)\n" +" (promise-update! promise* promise))\n" +" (force promise))))\n" +"\n" +" (define (make-promise obj)\n" +" (if (promise? obj)\n" +" obj\n" +" (make-promise% #t obj)))\n" +"\n" +" (export delay-force delay force make-promise promise?))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_eval = +"(define-library (scheme eval)\n" +" (import (scheme base))\n" +"\n" +" (define (null-environment n)\n" +" (if (not (= n 5))\n" +" (error \"unsupported environment version\" n)\n" +" '(scheme null)))\n" +"\n" +" (define (scheme-report-environment n)\n" +" (if (not (= n 5))\n" +" (error \"unsupported environment version\" n)\n" +" '(scheme r5rs)))\n" +"\n" +" (define environment\n" +" (let ((counter 0))\n" +" (lambda specs\n" +" (let ((library-name `(picrin @@my-environment ,counter)))\n" +" (set! counter (+ counter 1))\n" +" (eval\n" +" `(define-library ,library-name\n" +" ,@(map (lambda (spec)\n" +" `(import ,spec))\n" +" specs))\n" +" '(scheme base))\n" +" library-name))))\n" +"\n" +" (export null-environment\n" +" scheme-report-environment\n" +" environment))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_r5rs = +"(define-library (scheme r5rs)\n" +" (import (scheme base)\n" +" (scheme inexact)\n" +" (scheme write)\n" +" (scheme read)\n" +" (scheme file)\n" +" (scheme cxr)\n" +" (scheme lazy)\n" +" (scheme eval)\n" +" (scheme load))\n" +"\n" +" (export * + - / < <= = > >=\n" +" abs acos and\n" +" ;; angle\n" +" append apply asin assoc assq assv atan\n" +" begin boolean?\n" +" caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr\n" +" call-with-current-continuation\n" +" call-with-input-file\n" +" call-with-output-file\n" +" call-with-values\n" +" car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr\n" +" ceiling\n" +" ;; char->integer char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char=? char>? char?\n" +" close-input-port close-output-port complex? cond cons cos current-input-port current-output-port\n" +" define define-syntax delay\n" +" ;; denominator\n" +" display do dynamic-wind\n" +" eof-object? eq? equal? eqv? eval even?\n" +" (rename inexact exact->inexact)\n" +" exact? exp expt\n" +" floor for-each force\n" +" gcd\n" +" if\n" +" ;; imag-part\n" +" (rename exact inexact->exact)\n" +" inexact? input-port? integer->char integer?\n" +" ;; interaction-environment\n" +" lambda lcm length let\n" +" peek-char procedure?\n" +" quote\n" +" rational? read\n" +" ;; real-part\n" +" remainder round\n" +" scheme-report-environment\n" +" set! set-cdr! sqrt string->list string->symbol\n" +" ;; string-ci<=? string-ci=? string-ci>?\n" +" string-fill! string-ref string<=? string=? string>? substring symbol?\n" +" truncate\n" +" vector vector-fill! vector-ref vector? with-output-to-file write-char\n" +" output-port?\n" +" let-syntax\n" +" letrec-syntax\n" +" list->string\n" +" list-ref\n" +" list?\n" +" log\n" +" ;; make-polar\n" +" make-string\n" +" map\n" +" member\n" +" memv\n" +" modulo\n" +" newline\n" +" null-environment\n" +" number->string\n" +" ;; numerator\n" +" open-input-file\n" +" or\n" +" pair?\n" +" positive?\n" +" quasiquote\n" +" quotient\n" +" ;; rationalize\n" +" read-char\n" +" real?\n" +" reverse\n" +" let*\n" +" letrec\n" +" list\n" +" list->vector\n" +" list-tail\n" +" load\n" +" ;; magnitude\n" +" ;; make-rectangular\n" +" make-vector\n" +" max\n" +" memq\n" +" min\n" +" negative?\n" +" not\n" +" null?\n" +" number?\n" +" odd?\n" +" open-output-file\n" +" set-car!\n" +" sin\n" +" string\n" +" string->number\n" +" string-append\n" +" ;; string-ci=?\n" +" string-copy\n" +" string-length\n" +" string-set!\n" +" string=?\n" +" string?\n" +" symbol->string\n" +" tan\n" +" values\n" +" vector->list\n" +" vector-length\n" +" vector-set!\n" +" with-input-from-file\n" +" write\n" +" zero?\n" +" ))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_null = +"(define-library (scheme null)\n" +" (import (scheme base))\n" +" (export define\n" +" lambda\n" +" if\n" +" quote\n" +" quasiquote\n" +" unquote\n" +" unquote-splicing\n" +" begin\n" +" set!\n" +" define-syntax))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_1 = +"(define-library (srfi 1)\n" +" (import (scheme base)\n" +" (scheme cxr))\n" +"\n" +" ;; # Constructors\n" +" ;; cons list\n" +" ;; xcons cons* make-list list-tabulate\n" +" ;; list-copy circular-list iota\n" +" (define (xcons a b)\n" +" (cons b a))\n" +"\n" +" ;; means for inter-referential definition\n" +" (define append-reverse #f)\n" +"\n" +" (define (cons* x . args)\n" +" (let rec ((acc '()) (x x) (lst args))\n" +" (if (null? lst)\n" +" (append-reverse acc x)\n" +" (rec (cons x acc) (car lst) (cdr lst)))))\n" +"\n" +" (define (list-tabulate n init-proc)\n" +" (let rec ((acc '()) (n (- n 1)))\n" +" (if (zero? n)\n" +" (cons n acc)\n" +" (rec (cons n acc) (- n 1)))))\n" +"\n" +" (define (circular-list elt . args)\n" +" (let ((lst (cons elt args)))\n" +" (let rec ((l lst))\n" +" (if (null? (cdr l))\n" +" (set-cdr! l lst)\n" +" (rec (cdr l))))\n" +" lst))\n" +"\n" +" (define (iota count . lst)\n" +" (let ((start (if (pair? lst) (car lst) 0))\n" +" (step (if (and (pair? lst) (pair? (cdr lst)))\n" +" (cadr lst) 1)))\n" +" (let rec ((count (- count 1)) (acc '()))\n" +" (if (zero? count)\n" +" (cons start acc)\n" +" (rec (- count 1)\n" +" (cons (+ start (* count step)) acc))))))\n" +"\n" +" (export cons list xcons make-list list-tabulate list-copy circular-list iota)\n" +"\n" +" ;; # Predicates\n" +" ;; pair? null?\n" +" ;; proper-list? circular-list? dotted-list?\n" +" ;; not-pair? null-list?\n" +" ;; list=\n" +" (define (not-pair? x)\n" +" (not (pair? x)))\n" +" ;; detects circular list using Floyd's cycle-finding algorithm\n" +" (define (circular-list? x)\n" +" (let rec ((rapid x) (local x))\n" +" (if (and (pair? rapid) (pair? (cdr rapid)))\n" +" (if (eq? (cddr rapid) (cdr local))\n" +" #t\n" +" (rec (cddr rapid) (cdr local)))\n" +" #f)))\n" +"\n" +" (define proper-list? list?)\n" +"\n" +" (define (dotted-list? x)\n" +" (and (pair? x)\n" +" (not (proper-list? x))\n" +" (not (circular-list? x))))\n" +"\n" +" (define (null-list? x)\n" +" (cond ((pair? x) #f)\n" +" ((null? x) #t)\n" +" (else (error \"null-list?: argument out of domain\" x))))\n" +"\n" +" (define (list= elt= . lists)\n" +" (or (null? lists)\n" +" (let rec1 ((list1 (car lists)) (others (cdr lists)))\n" +" (or (null? others)\n" +" (let ((list2 (car others))\n" +" (others (cdr others)))\n" +" (if (eq? list1 list2)\n" +" (rec1 list2 others)\n" +" (let rec2 ((l1 list1) (l2 list2))\n" +" (if (null-list? l1)\n" +" (and (null-list? l2)\n" +" (rec1 list2 others))\n" +" (and (not (null-list? l2))\n" +" (elt= (car l1) (car l2))\n" +" (rec2 (cdr l1) (cdr l2)))))))))))\n" +"\n" +" (export pair? null? not-pair? proper-list? circular-list? null-list? list=)\n" +"\n" +" ;; # Selectors\n" +" ;; car cdr ... cddadr cddddr list-ref\n" +" ;; first second third fourth fifth sixth seventh eighth ninth tenth\n" +" ;; car+cdr\n" +" ;; take drop\n" +" ;; take-right drop-right\n" +" ;; take! drop-right!\n" +" ;; split-at split-at!\n" +" ;; last last-pair\n" +" (define (car+cdr pair)\n" +" (values (car pair) (cdr pair)))\n" +"\n" +" (define (take x i)\n" +" (if (zero? i)\n" +" '()\n" +" (cons (car x)\n" +" (take (cdr x) (- i 1)))))\n" +"\n" +" (define (drop x i)\n" +" (if (zero? i)\n" +" x\n" +" (drop (cdr x) (- i 1))))\n" +"\n" +" (define (take-right flist i)\n" +" (let ((len (length flist)))\n" +" (drop flist (- len i))))\n" +"\n" +" (define (drop-right flist i)\n" +" (let ((len (length flist)))\n" +" (take flist (- len i))))\n" +"\n" +" (define (take! x i)\n" +" (let rec ((lis x) (n (- i 1)))\n" +" (if (zero? n)\n" +" (begin (set-cdr! lis '()) x)\n" +" (rec (cdr lis) (- n 1)))))\n" +"\n" +" (define (drop-right! flist i)\n" +" (let ((lead (drop flist i)))\n" +" (if (not-pair? lead)\n" +" '()\n" +" (let rec ((lis1 flist) (lis2 (cdr lead)))\n" +" (if (pair? lis2)\n" +" (rec (cdr lis1) (cdr lis2))\n" +" (begin (set-cdr! lis1 '()) flist))))))\n" +"\n" +" (define (split-at x i)\n" +" (values (take x i) (drop x i)))\n" +"\n" +" (define (split-at! x i)\n" +" (values (take! x i) (drop x i)))\n" +"\n" +" (define (last pair)\n" +" (car (take-right pair 1)))\n" +"\n" +" (define (last-pair pair)\n" +" (take-right pair 1))\n" +"\n" +" (define first car)\n" +" (define second cadr)\n" +" (define third caddr)\n" +" (define fourth cadddr)\n" +" (define (fifth pair)\n" +" (list-ref pair 4))\n" +" (define (sixth pair)\n" +" (list-ref pair 5))\n" +" (define (seventh pair)\n" +" (list-ref pair 6))\n" +" (define (eighth pair)\n" +" (list-ref pair 7))\n" +" (define (ninth pair)\n" +" (list-ref pair 8))\n" +" (define (tenth pair)\n" +" (list-ref pair 9))\n" +"\n" +"\n" +" (export car cdr car+cdr list-ref\n" +" caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr\n" +" caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr\n" +" cdadar cdaddr cddaar cddadr cdddar cddddr\n" +" first second third fourth fifth sixth seventh eighth ninth tenth\n" +" take drop take-right drop-right take! drop-right!\n" +" split-at split-at! last last-pair)\n" +"\n" +" ;; # Miscellaneous\n" +" ;; length length+\n" +" ;; append concatenate reverse\n" +" ;; append! concatenate! reverse!\n" +" ;; append-reverse append-reverse!\n" +" ;; zip unzip1 unzip2 unzip3 unzip4 unzip5\n" +" ;; count\n" +" (define (length+ lst)\n" +" (if (not (circular-list? lst))\n" +" (length lst)))\n" +"\n" +" (define (concatenate lists)\n" +" (apply append lists))\n" +"\n" +" (define (append! . lists)\n" +" (if (null? lists)\n" +" '()\n" +" (let rec ((lst lists))\n" +" (if (not-pair? (cdr lst))\n" +" (car lst)\n" +" (begin (set-cdr! (last-pair (car lst)) (cdr lst))\n" +" (rec (cdr lst)))))))\n" +"\n" +" (define (concatenate! lists)\n" +" (apply append! lists))\n" +"\n" +" (define (reverse! list)\n" +" (let rec ((lst list) (acc '()))\n" +" (if (null? lst)\n" +" acc\n" +" (let ((rst (cdr lst)))\n" +" (set-cdr! lst acc)\n" +" (rec rst lst)))))\n" +"\n" +" (set! append-reverse\n" +" (lambda (rev-head tail)\n" +" (if (null? rev-head)\n" +" tail\n" +" (append-reverse (cdr rev-head) (cons (car rev-head) tail)))))\n" +"\n" +" (define (append-reverse! rev-head tail)\n" +" (let ((rst (cdr rev-head)))\n" +" (if (null? rev-head)\n" +" tail\n" +" (begin (set-cdr! rev-head tail)\n" +" (append-reverse! rst rev-head)))))\n" +"\n" +" (define (zip . lists)\n" +" (apply map list lists))\n" +"\n" +" (define (unzip1 list)\n" +" (map first list))\n" +"\n" +" (define (unzip2 list)\n" +" (values (map first list)\n" +" (map second list)))\n" +"\n" +" (define (unzip3 list)\n" +" (values (map first list)\n" +" (map second list)\n" +" (map third list)))\n" +"\n" +" (define (unzip4 list)\n" +" (values (map first list)\n" +" (map second list)\n" +" (map third list)\n" +" (map fourth list)))\n" +"\n" +" (define (unzip5 list)\n" +" (values (map first list)\n" +" (map second list)\n" +" (map third list)\n" +" (map fourth list)\n" +" (map fifth list)))\n" +"\n" +" (define (count pred . clists)\n" +" (let rec ((tflst (apply map pred clists)) (n 0))\n" +" (if (null? tflst)\n" +" n\n" +" (rec (cdr tflst) (if (car tflst) (+ n 1) n)))))\n" +"\n" +" (export length length+\n" +" append append! concatenate concatenate!\n" +" reverse reverse! append-reverse append-reverse!\n" +" zip unzip1 unzip2 unzip3 unzip4 unzip5\n" +" count)\n" +"\n" +" ;; # Fold, unfold & map\n" +" ;; map for-each\n" +" ;; fold unfold pair-fold reduce\n" +" ;; fold-right unfold-right pair-fold right reduce-right\n" +" ;; append-map append-map!\n" +" ;; map! pair-for-each filter-map map-in-order\n" +"\n" +" ;; means for inter-referential definition\n" +" (define every #f)\n" +"\n" +" (define (fold kons knil clist . clists)\n" +" (if (null? clists)\n" +" (let rec ((acc knil) (clist clist))\n" +" (if (null? clist)\n" +" acc\n" +" (rec (kons (car clist) acc) (cdr clist))))\n" +" (let rec ((acc knil) (clists (cons clist clists)))\n" +" (if (every pair? clists)\n" +" (rec (apply kons (append (map car clists) (list acc)))\n" +" (map cdr clists))\n" +" acc))))\n" +"\n" +" (define (fold-right kons knil clist . clists)\n" +" (if (null? clists)\n" +" (let rec ((clist clist) (cont values))\n" +" (if (null? clist)\n" +" (cont knil)\n" +" (rec (cdr clist) (lambda (x) (cont (kons (car clist) x))))))\n" +" (let rec ((clists (cons clist clists)) (cont values))\n" +" (if (every pair? clists)\n" +" (rec (map cdr clists)\n" +" (lambda (x)\n" +" (cont (apply kons (append (map car clists) (list x))))))\n" +" (cont knil)))))\n" +"\n" +" (define (pair-fold kons knil clist . clists)\n" +" (if (null? clists)\n" +" (let rec ((acc knil) (clist clist))\n" +" (if (null? clist)\n" +" acc\n" +" (let ((tail (cdr clist)))\n" +" (rec (kons clist acc) tail))))\n" +" (let rec ((acc knil) (clists (cons clist clists)))\n" +" (if (every pair? clists)\n" +" (let ((tail (map cdr clists)))\n" +" (rec (apply kons (append clists (list acc)))\n" +" tail))\n" +" acc))))\n" +"\n" +" (define (pair-fold-right kons knil clist . clists)\n" +" (if (null? clists)\n" +" (let rec ((clist clist) (cont values))\n" +" (if (null? clist)\n" +" (cont knil)\n" +" (let ((tail (map cdr clists)))\n" +" (rec tail (lambda (x) (cont (kons clist x)))))))\n" +" (let rec ((clists (cons clist clists)) (cont values))\n" +" (if (every pair? clists)\n" +" (let ((tail (map cdr clists)))\n" +" (rec tail\n" +" (lambda (x)\n" +" (cont (apply kons (append clists (list x)))))))\n" +" (cont knil)))))\n" +"\n" +" (define (reduce f ridentity list)\n" +" (if (null? list)\n" +" ridentity\n" +" (fold f (car list) (cdr list))))\n" +"\n" +" (define (reduce-right f ridentity list)\n" +" (fold-right f ridentity list))\n" +"\n" +" (define (unfold p f g seed . tail-gen)\n" +" (let ((tail-gen (if (null? tail-gen)\n" +" (lambda (x) '())\n" +" (car tail-gen))))\n" +" (let rec ((seed seed) (cont values))\n" +" (if (p seed)\n" +" (cont (tail-gen seed))\n" +" (rec (g seed) (lambda (x) (cont (cons (f seed) x))))))))\n" +"\n" +" (define (unfold-right p f g seed . tail)\n" +" (let rec ((seed seed) (lst tail))\n" +" (if (p seed)\n" +" lst\n" +" (rec (g seed) (cons (f seed) lst)))))\n" +"\n" +" (define (append-map f . clists)\n" +" (apply append (apply map f clists)))\n" +"\n" +" (define (append-map! f . clists)\n" +" (apply append! (apply map f clists)))\n" +"\n" +" (define (pair-for-each f clist . clists)\n" +" (if (null? clist)\n" +" (let rec ((clist clist))\n" +" (if (pair? clist)\n" +" (begin (f clist) (rec (cdr clist)))))\n" +" (let rec ((clists (cons clist clists)))\n" +" (if (every pair? clists)\n" +" (begin (apply f clists) (rec (map cdr clists)))))))\n" +"\n" +" (define (map! f list . lists)\n" +" (if (null? lists)\n" +" (pair-for-each (lambda (x) (set-car! x (f (car x)))) list)\n" +" (let rec ((list list) (lists lists))\n" +" (if (pair? list)\n" +" (let ((head (map car lists))\n" +" (rest (map cdr lists)))\n" +" (set-car! list (apply f (car list) head))\n" +" (rec (cdr list) rest)))))\n" +" list)\n" +"\n" +" (define (map-in-order f clist . clists)\n" +" (if (null? clists)\n" +" (let rec ((clist clist) (acc '()))\n" +" (if (null? clist)\n" +" (reverse! acc)\n" +" (rec (cdr clist) (cons (f (car clist)) acc))))\n" +" (let rec ((clists (cons clist clists)) (acc '()))\n" +" (if (every pair? clists)\n" +" (rec (map cdr clists)\n" +" (cons* (apply f (map car clists)) acc))\n" +" (reverse! acc)))))\n" +"\n" +" (define (filter-map f clist . clists)\n" +" (let recur ((l (apply map f clist clists)))\n" +" (cond ((null? l) '())\n" +" ((car l) (cons (car l) (recur (cdr l))))\n" +" (else (recur (cdr l))))))\n" +"\n" +" (export map for-each\n" +" fold unfold pair-fold reduce\n" +" fold-right unfold-right pair-fold-right reduce-right\n" +" append-map append-map!\n" +" map! pair-for-each filter-map map-in-order)\n" +"\n" +" ;; # Filtering & partitioning\n" +" ;; filter partition remove\n" +" ;; filter! partition! remove!\n" +" (define (filter pred list)\n" +" (let ((pcons (lambda (v acc) (if (pred v) (cons v acc) acc))))\n" +" (reverse (fold pcons '() list))))\n" +"\n" +" (define (remove pred list)\n" +" (filter (lambda (x) (not (pred x))) list))\n" +"\n" +" (define (partition pred list)\n" +" (values (filter pred list)\n" +" (remove pred list)))\n" +"\n" +" (define (filter! pred list)\n" +" (let rec ((lst list))\n" +" (if (null? lst)\n" +" lst\n" +" (if (pred (car lst))\n" +" (begin (set-cdr! lst (rec (cdr lst)))\n" +" lst)\n" +" (rec (cdr lst))))))\n" +"\n" +" (define (remove! pred list)\n" +" (filter! (lambda (x) (not (pred x))) list))\n" +"\n" +" (define (partition! pred list)\n" +" (values (filter! pred list)\n" +" (remove! pred list)))\n" +"\n" +" (export filter partition remove\n" +" filter! partition! remove!)\n" +"\n" +" ;; # Searching\n" +" ;; member memq memv\n" +" ;; find find-tail\n" +" ;; any every\n" +" ;; list-index\n" +" ;; take-while drop-while take-while!\n" +" ;; span break span! break!\n" +"\n" +" (define (find-tail pred list)\n" +" (if (null? list)\n" +" #f\n" +" (if (pred (car list))\n" +" list\n" +" (find-tail pred (cdr list)))))\n" +"\n" +" (define (find pred list)\n" +" (let ((tail (find-tail pred list)))\n" +" (if tail\n" +" (car tail)\n" +" #f)))\n" +"\n" +" (define (take-while pred clist)\n" +" (let rec ((clist clist) (cont values))\n" +" (if (null? clist)\n" +" (cont '())\n" +" (if (pred (car clist))\n" +" (rec (cdr clist)\n" +" (lambda (x) (cont (cons (car clist) x))))\n" +" (cont '())))))\n" +"\n" +" (define (take-while! pred clist)\n" +" (let rec ((clist clist))\n" +" (if (null? clist)\n" +" '()\n" +" (if (pred (car clist))\n" +" (begin (set-cdr! clist (rec (cdr clist)))\n" +" clist)\n" +" '()))))\n" +"\n" +" (define (drop-while pred clist)\n" +" (let rec ((clist clist))\n" +" (if (null? clist)\n" +" '()\n" +" (if (pred (car clist))\n" +" (rec (cdr clist))\n" +" clist))))\n" +"\n" +" (define (span pred clist)\n" +" (values (take-while pred clist)\n" +" (drop-while pred clist)))\n" +"\n" +" (define (span! pred clist)\n" +" (values (take-while! pred clist)\n" +" (drop-while pred clist)))\n" +"\n" +" (define (break pred clist)\n" +" (values (take-while (lambda (x) (not (pred x))) clist)\n" +" (drop-while (lambda (x) (not (pred x))) clist)))\n" +"\n" +" (define (break! pred clist)\n" +" (values (take-while! (lambda (x) (not (pred x))) clist)\n" +" (drop-while (lambda (x) (not (pred x))) clist)))\n" +"\n" +" (define (any pred clist . clists)\n" +" (if (null? clists)\n" +" (let rec ((clist clist))\n" +" (if (pair? clist)\n" +" (or (pred (car clist))\n" +" (rec (cdr clist)))))\n" +" (let rec ((clists (cons clist clists)))\n" +" (if (every pair? clists)\n" +" (or (apply pred (map car clists))\n" +" (rec (map cdr clists)))))))\n" +"\n" +" (set! every\n" +" (lambda (pred clist . clists)\n" +" (if (null? clists)\n" +" (let rec ((clist clist))\n" +" (or (null? clist)\n" +" (if (pred (car clist))\n" +" (rec (cdr clist)))))\n" +" (let rec ((clists (cons clist clists)))\n" +" (or (any null? clists)\n" +" (if (apply pred (map car clists))\n" +" (rec (map cdr clists))))))))\n" +"\n" +" (define (list-index pred clist . clists)\n" +" (if (null? clists)\n" +" (let rec ((clist clist) (n 0))\n" +" (if (pair? clist)\n" +" (if (pred (car clist))\n" +" n\n" +" (rec (cdr clist) (+ n 1)))))\n" +" (let rec ((clists (cons clist clists)) (n 0))\n" +" (if (every pair? clists)\n" +" (if (apply pred (map car clists))\n" +" n\n" +" (rec (map cdr clists) (+ n 1)))))))\n" +"\n" +" (export member memq memv\n" +" find find-tail\n" +" any every\n" +" list-index\n" +" take-while drop-while take-while!\n" +" span break span! break!)\n" +"\n" +" ;; # Deleting\n" +" ;; delete delete-duplicates\n" +" ;; delete! delete-duplicates!\n" +" (define (delete x list . =)\n" +" (let ((= (if (null? =) equal? (car =))))\n" +" (remove (lambda (a) (= x a)) list)))\n" +"\n" +" (define (delete! x list . =)\n" +" (let ((= (if (null? =) equal? (car =))))\n" +" (remove! (lambda (a) (= x a)) list)))\n" +"\n" +" (define (delete-duplicates list . =)\n" +" (let ((= (if (null? =) equal? (car =))))\n" +" (let rec ((list list) (cont values))\n" +" (if (null? list)\n" +" (cont '())\n" +" (let* ((x (car list))\n" +" (rest (cdr list))\n" +" (deleted (delete x rest =)))\n" +" (rec deleted (lambda (y) (cont (cons x y)))))))))\n" +"\n" +" (define (delete-duplicates! list . =)\n" +" (let ((= (if (null? =) equal? (car =))))\n" +" (let rec ((list list) (cont values))\n" +" (if (null? list)\n" +" (cont '())\n" +" (let* ((x (car list))\n" +" (rest (cdr list))\n" +" (deleted (delete! x list =)))\n" +" (rec deleted (lambda (y) (cont (cons x y)))))))))\n" +"\n" +" (export delete delete-duplicates\n" +" delete! delete-duplicates!)\n" +"\n" +" ;; # Association lists\n" +" ;; assoc assq assv\n" +" ;; alist-cons alist-copy\n" +" ;; alist-delete alist-delete!\n" +" (define (alist-cons key datum alist)\n" +" (cons (cons key datum) alist))\n" +"\n" +" (define (alist-copy alist)\n" +" (map (lambda (elt) (cons (car elt) (cdr elt))) alist))\n" +"\n" +" (define (alist-delete key alist . =)\n" +" (let ((= (if (null? =) equal? (car =))))\n" +" (remove (lambda (x) (= key (car x))) alist)))\n" +"\n" +" (define (alist-delete! key alist . =)\n" +" (let ((= (if (null? =) equal? (car =))))\n" +" (remove! (lambda (x) (= key (car x))) alist)))\n" +"\n" +" (export assoc assq assv\n" +" alist-cons alist-copy\n" +" alist-delete alist-delete!)\n" +"\n" +" ;; # Set operations on lists\n" +" ;; lset<= lset= lset-adjoin\n" +" ;; lset-union lset-union!\n" +" ;; lset-intersection lset-intersection!\n" +" ;; lset-difference lset-difference!\n" +" ;; lset-xor lset-xor!\n" +" ;; lset-diff+intersenction lset-diff+intersection!\n" +" (define (lset<= = . lists)\n" +" (or (null? lists)\n" +" (let rec ((head (car lists)) (rest (cdr lists)))\n" +" (or (null? rest)\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (and (or (eq? head next)\n" +" (every (lambda (x) (member x next =)) head))\n" +" (rec next rest)))))))\n" +"\n" +" (define (lset= = . lists)\n" +" (or (null? lists)\n" +" (let rec ((head (car lists)) (rest (cdr lists)))\n" +" (or (null? rest)\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (and (or (eq? head next)\n" +" (and (every (lambda (x) (member x next =)) head)\n" +" (every (lambda (x) (member x head =)) next))\n" +" (rec next rest))))))))\n" +"\n" +" (define (lset-adjoin = list . elts)\n" +" (let rec ((list list) (elts elts))\n" +" (if (null? elts)\n" +" list\n" +" (if (member (car elts) list)\n" +" (rec list (cdr elts))\n" +" (rec (cons (car elts) list) (cdr elts))))))\n" +"\n" +" (define (lset-union = . lists)\n" +" (if (null? lists)\n" +" lists\n" +" (let rec ((head (car lists)) (rest (cdr lists)))\n" +" (if (null? rest)\n" +" head\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (if (eq? head next)\n" +" (rec head rest)\n" +" (rec (apply lset-adjoin = head next) rest)))))))\n" +"\n" +" (define (lset-intersection = . lists)\n" +" (if (null? lists)\n" +" lists\n" +" (let rec ((head (car lists)) (rest (cdr lists)))\n" +" (if (null? rest)\n" +" head\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (if (eq? head next)\n" +" (rec head rest)\n" +" (rec (filter (lambda (x) (member x next =)) head)\n" +" rest)))))))\n" +"\n" +" (define (lset-difference = list . lists)\n" +" (let rec ((head list) (rest lists))\n" +" (if (null? rest)\n" +" head\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (if (eq? head next)\n" +" '()\n" +" (rec (remove (lambda (x) (member x next =)) head)\n" +" rest))))))\n" +"\n" +" (define (lset-xor = . lists)\n" +" (if (null? lists)\n" +" lists\n" +" (let rec ((head (car lists)) (rest (cdr lists)))\n" +" (if (null? rest)\n" +" head\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (if (eq? head next)\n" +" '()\n" +" (rec (append (remove (lambda (x) (member x next =)) head)\n" +" (remove (lambda (x) (member x head =)) next))\n" +" rest)))))))\n" +"\n" +" (define (lset-diff+intersection = list . lists)\n" +" (values (apply lset-difference = list lists)\n" +" (lset-intersection = list (apply lset-union lists))))\n" +"\n" +" (define (lset-adjoin! = list . elts)\n" +" (let rec ((list list) (elts elts))\n" +" (if (null? elts)\n" +" list\n" +" (if (member (car elts) list)\n" +" (rec list (cdr elts))\n" +" (let ((tail (cdr elts)))\n" +" (set-cdr! elts list)\n" +" (rec elts tail))))))\n" +"\n" +" (define (lset-union! = . lists)\n" +" (letrec ((adjoin\n" +" (lambda (lst1 lst2)\n" +" (if (null? lst2)\n" +" lst1\n" +" (if (member (car lst2) lst1 =)\n" +" (adjoin lst1 (cdr lst2))\n" +" (let ((tail (cdr lst2)))\n" +" (set-cdr! lst2 lst1)\n" +" (adjoin lst2 tail)))))))\n" +" (if (null? lists)\n" +" lists\n" +" (let rec ((head (car lists)) (rest (cdr lists)))\n" +" (if (null? rest)\n" +" head\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (if (eq? head next)\n" +" (rec head rest)\n" +" (rec (adjoin head next) rest))))))))\n" +"\n" +" (define (lset-intersection! = . lists)\n" +" (if (null? lists)\n" +" lists\n" +" (let rec ((head (car lists)) (rest (cdr lists)))\n" +" (if (null? rest)\n" +" head\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (if (eq? head next)\n" +" (rec head rest)\n" +" (rec (filter! (lambda (x) (member x next =)) head)\n" +" rest)))))))\n" +"\n" +" (define (lset-difference! = list . lists)\n" +" (let rec ((head list) (rest lists))\n" +" (if (null? rest)\n" +" head\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (if (eq? head next)\n" +" '()\n" +" (rec (remove! (lambda (x) (member x next =)) head)\n" +" rest))))))\n" +"\n" +" (define (lset-xor! = . lists)\n" +" (if (null? lists)\n" +" lists\n" +" (let rec ((head (car lists)) (rest (cdr lists)))\n" +" (if (null? rest)\n" +" head\n" +" (let ((next (car rest)) (rest (cdr rest)))\n" +" (if (eq? head next)\n" +" '()\n" +" (rec (append! (remove! (lambda (x) (member x next =)) head)\n" +" (remove! (lambda (x) (member x head =)) next))\n" +" rest)))))))\n" +"\n" +" (define (lset-diff+intersection! = list . lists)\n" +" (values (apply lset-difference! = list lists)\n" +" (lset-intersection! = list (apply lset-union! lists))))\n" +"\n" +" (export lset<= lset= lset-adjoin\n" +" lset-union lset-union!\n" +" lset-intersection lset-intersection!\n" +" lset-difference lset-difference!\n" +" lset-xor lset-xor!\n" +" lset-diff+intersection lset-diff+intersection!)\n" +"\n" +" ;; # Primitive side-effects\n" +" ;; set-car! set-cdr!\n" +" (export set-car! set-cdr!))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_8 = +"(define-library (srfi 8)\n" +" (import (scheme base))\n" +"\n" +" (define-syntax receive\n" +" (syntax-rules ()\n" +" ((receive formals expression body ...)\n" +" (call-with-values (lambda () expression)\n" +" (lambda formals body ...)))))\n" +"\n" +" (export receive))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_26 = +"(define-library (srfi 26)\n" +" (import (scheme base)\n" +" (picrin macro)\n" +" (srfi 1))\n" +"\n" +" (define-syntax cut%\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare?)\n" +" (let ((slots (second form))\n" +" (combi (third form))\n" +" (se (cdddr form)))\n" +" (cond ((null? se)\n" +" `(lambda ,slots ((begin ,(car combi)) ,@(cdr combi))))\n" +" ((and (symbol? (car se))\n" +" (compare? (car se) '<...>))\n" +" `(lambda (,@slots . rest-slot) (apply ,@combi rest-slot)))\n" +" ((and (symbol? (car se))\n" +" (compare? (car se) '<>))\n" +" `(cut% (,@slots x) (,@combi x) ,@(cdr se)))\n" +" (else `(cut% ,slots (,@combi ,(car se)) ,@(cdr se))))))))\n" +"\n" +" (define-syntax cute%\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare?)\n" +" (let ((slots (second form))\n" +" (binds (third form))\n" +" (combi (fourth form))\n" +" (se (cddddr form)))\n" +" (cond ((null? se)\n" +" `(let ,binds\n" +" (lambda ,slots ((begin ,(car combi)) ,@(cdr combi)))))\n" +" ((and (symbol? (car se))\n" +" (compare? (car se) '<...>))\n" +" `(let ,binds\n" +" (lambda (,@slots . rest-slot) (apply ,@combi rest-slot))))\n" +" ((and (symbol? (car se))\n" +" (compare? (car se) '<>))\n" +" `(cute% (,@slots x) ,binds (,@combi x) ,@(cdr se)))\n" +" (else\n" +" `(cute% ,slots ((x ,(car se)) ,@binds)\n" +" (,@combi x) ,@(cdr se))))))))\n" +" \n" +" (define-syntax cut\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare?)\n" +" `(cut% () () ,@(cdr form)))))\n" +"\n" +" (define-syntax cute\n" +" (ir-macro-transformer\n" +" (lambda (form inject compare?)\n" +" `(cute% () () () ,@(cdr form)))))\n" +"\n" +" (export cut cute))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_43 = +"(define-library (srfi 43)\n" +" (import (scheme base)\n" +" (srfi 8))\n" +" \n" +" ;; # Constructors\n" +" (define (vector-unfold f length . seeds)\n" +" (let ((seeds (if (null? seeds) '(0) seeds))\n" +" (vect (make-vector length)))\n" +" (letrec ((tabulate\n" +" (lambda (count . args)\n" +" (if (= length count)\n" +" vect\n" +" (receive lst (apply f count args)\n" +" (vector-set! vect count (car lst))\n" +" (apply tabulate (+ 1 count) (cdr lst)))))))\n" +" (apply tabulate 0 seeds))))\n" +"\n" +" (define (vector-unfold-right f length . seeds)\n" +" (let ((seeds (if (null? seeds) '(0) seeds))\n" +" (vect (make-vector length)))\n" +" (letrec ((tabulate\n" +" (lambda (count . args)\n" +" (if (< count 0)\n" +" vect\n" +" (receive lst (apply f count args)\n" +" (vector-set! vect count (car lst))\n" +" (apply tabulate (- count 1) (cdr lst)))))))\n" +" (apply tabulate (- length 1) seeds))))\n" +"\n" +" (define (vector-reverse-copy vec . rst)\n" +" (let* ((start (if (null? rst) 0 (car rst)))\n" +" (end (if (or (null? rst) (null? (cdr rst)))\n" +" (vector-length vec)\n" +" (cadr rst)))\n" +" (new-vect (make-vector (- end start))))\n" +" (let loop ((i (- end 1)) (count 0))\n" +" (if (< i start)\n" +" new-vect\n" +" (begin\n" +" (vector-set! new-vect count (vector-ref vec i))\n" +" (loop (- i 1) (+ 1 count)))))))\n" +"\n" +" (define (vector-concatenate list-of-vectors)\n" +" (apply vector-append list-of-vectors))\n" +"\n" +" \n" +" ;; # Predicates\n" +" (define (vector-empty? vec)\n" +" (zero? (vector-length vec)))\n" +"\n" +" ; for the symmetry, this should be rather 'vector=?' than 'vector='.\n" +" (define (vector= elt=? . vects)\n" +" (letrec ((vector2=\n" +" (lambda (v1 v2)\n" +" (let ((ln1 (vector-length v1)))\n" +" (and (= ln1 (vector-length v2))\n" +" (let loop ((count 0))\n" +" (if (= ln1 count)\n" +" #t\n" +" (and (elt=? (vector-ref v1 count)\n" +" (vector-ref v2 count))\n" +" (loop (+ 1 count))))))))))\n" +" (or (null? vects)\n" +" (let rec1 ((vect1 (car vects)) (others (cdr vects)))\n" +" (or (null? others)\n" +" (let ((vect2 (car others))\n" +" (others (cdr others)))\n" +" (if (eq? vect1 vect2)\n" +" (rec1 vect1 others)\n" +" (and (vector2= vect1 vect2)\n" +" (rec1 vect2 others)))))))))\n" +"\n" +" \n" +" ;; # Iteration\n" +" (define (vector-fold kons knil vec . vects)\n" +" (let* ((vects (cons vec vects))\n" +" (veclen (apply min (map vector-length vects))))\n" +" (let rec ((acc knil) (count 0))\n" +" (if (= count veclen)\n" +" acc\n" +" (rec (apply kons count acc\n" +" (map (lambda (v) (vector-ref v count)) vects))\n" +" (+ 1 count))))))\n" +"\n" +" (define (vector-fold-right kons knil vec . vects)\n" +" (let* ((vects (cons vec vects))\n" +" (veclen (apply min (map vector-length vects))))\n" +" (let rec ((acc knil) (count (- veclen 1)))\n" +" (if (< count 0)\n" +" acc\n" +" (rec (apply kons count acc\n" +" (map (lambda (v) (vector-ref v count)) vects))\n" +" (- count 1))))))\n" +"\n" +" (define (vector-map! f vec . vects)\n" +" (let* ((vects (cons vec vects))\n" +" (veclen (apply min (map vector-length vects)))\n" +" (new-vect (make-vector veclen)))\n" +" (let rec ((count 0))\n" +" (if (< count veclen)\n" +" (begin\n" +" (vector-set! vec count\n" +" (apply f (map (lambda (v) (vector-ref v count))\n" +" vects)))\n" +" (rec (+ 1 count)))))))\n" +"\n" +" (define (vector-count pred? vec . vects)\n" +" (let* ((vects (cons vec vects))\n" +" (veclen (apply min (map vector-length vects))))\n" +" (let rec ((i 0) (count 0))\n" +" (if (= i veclen)\n" +" count\n" +" (if (apply pred? count (map (lambda (v) (vector-ref v count)) vects))\n" +" (rec (+ 1 i) (+ 1 count))\n" +" (rec (+ 1 i) count))))))\n" +"\n" +" ;; # Searching\n" +" (define (vector-index pred? vec . vects)\n" +" (let* ((vects (cons vec vects))\n" +" (veclen (apply min (map vector-length vects))))\n" +" (let rec ((count 0))\n" +" (cond\n" +" ((= count veclen) #f)\n" +" ((apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" +" count)\n" +" (else (rec (+ 1 count)))))))\n" +"\n" +" (define (vector-index-right pred? vec . vects)\n" +" (let ((vects (cons vec vects))\n" +" (veclen (vector-length vec)))\n" +" (let rec ((count (- veclen 1)))\n" +" (cond\n" +" ((< count 0) #f)\n" +" ((apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" +" count)\n" +" (else (rec (- count 1)))))))\n" +"\n" +" (define (vector-skip pred? vec . vects)\n" +" (apply vector-index (lambda args (not (apply pred? args))) vec vects))\n" +"\n" +" (define (vector-skip-right pred? vec . vects)\n" +" (apply vector-index-right (lambda args (not (apply pred? args))) vec vects))\n" +"\n" +" (define (vector-binary-search vec value cmp)\n" +" (let rec ((start 0) (end (vector-length vec)) (n -1))\n" +" (let ((count (floor/ (+ start end) 2)))\n" +" (if (or (= start end) (= count n))\n" +" #f\n" +" (let ((comparison (cmp (vector-ref vec count) value)))\n" +" (cond\n" +" ((zero? comparison) count)\n" +" ((positive? comparison) (rec start count count))\n" +" (else (rec count end count))))))))\n" +"\n" +" (define (vector-any pred? vec . vects)\n" +" (let* ((vects (cons vec vects))\n" +" (veclen (vector-length vec)))\n" +" (let rec ((count 0))\n" +" (if (= count veclen)\n" +" #f\n" +" (or (apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" +" (rec (+ 1 count)))))))\n" +"\n" +" (define (vector-every pred? vec . vects)\n" +" (let* ((vects (cons vec vects))\n" +" (veclen (vector-length vec)))\n" +" (let rec ((count 0))\n" +" (if (= count veclen)\n" +" #t\n" +" (and (apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" +" (rec (+ 1 count)))))))\n" +"\n" +" ;; # Mutators\n" +" (define (vector-swap! vec i j)\n" +" (let ((tmp (vector-ref vec i)))\n" +" (vector-set! vec i (vector-ref vec j))\n" +" (vector-set! vec j tmp)))\n" +"\n" +" (define (vector-reverse! vec . rst)\n" +" (let ((start (if (null? rst) 0 (car rst)))\n" +" (end (if (or (null? rst) (cdr rst))\n" +" (vector-length vec)\n" +" (cadr rst))))\n" +" (let rec ((i start) (j (- end 1)))\n" +" (if (< i j)\n" +" (begin\n" +" (vector-swap! vec i j)\n" +" (rec (+ 1 i) (- j 1)))))))\n" +"\n" +" (define (vector-reverse-copy! target tstart source . rst)\n" +" (let ((sstart (if (null? rst) 0 (car rst)))\n" +" (send (if (or (null? rst) (cdr rst))\n" +" (vector-length source)\n" +" (cadr rst))))\n" +" (let rec ((i tstart) (j (- send 1)))\n" +" (if (>= j sstart)\n" +" (begin\n" +" (vector-set! target i (vector-ref source j))\n" +" (rec (+ 1 i) (- j 1)))))))\n" +"\n" +" ;; # Conversion\n" +" (define (reverse-vector->list vec . rst)\n" +" (let ((start (if (null? rst) 0 (car rst)))\n" +" (end (if (or (null? rst) (cdr rst))\n" +" (vector-length vec)\n" +" (cadr rst))))\n" +" (let rec ((i start) (acc '()))\n" +" (if (= i end)\n" +" acc\n" +" (rec (+ 1 i) (cons (vector-ref vec i) acc))))))\n" +"\n" +" (define (reverse-list->vector proper-list)\n" +" (apply vector (reverse proper-list)))\n" +"\n" +" (export vector?\n" +" make-vector\n" +" vector\n" +" vector-length\n" +" vector-ref\n" +" vector-set!\n" +" vector->list\n" +" list->vector\n" +" vector-fill!\n" +" vector-copy!\n" +"\n" +" vector-unfold\n" +" vector-unfold-right\n" +" vector-reverse-copy\n" +" vector-concatenate\n" +" vector-empty?\n" +" vector=\n" +" vector-fold\n" +" vector-fold-right\n" +" vector-map!\n" +" vector-count\n" +" vector-index\n" +" vector-index-right\n" +" vector-skip\n" +" vector-skip-right\n" +" vector-binary-search\n" +" vector-any\n" +" vector-every\n" +" vector-swap!\n" +" vector-reverse!\n" +" vector-reverse-copy!\n" +" reverse-vector->list\n" +" reverse-list->vector))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_60 = +"(define-library (srfi 60)\n" +" (import (scheme base)\n" +" (srfi 1))\n" +"\n" +" ;; # Bitwise Operations\n" +" (define (logand . args)\n" +" (letrec ((lgand\n" +" (lambda (x y)\n" +" (if (or (zero? x) (zero? y))\n" +" 0\n" +" (+ (* (lgand (floor/ x 2) (floor/ y 2)) 2)\n" +" (if (or (even? x) (even? y)) 0 1))))))\n" +" (fold lgand -1 args)))\n" +"\n" +" (define bitwise-and logand)\n" +"\n" +" (define (logior . args)\n" +" (letrec ((lgior\n" +" (lambda (x y)\n" +" (cond\n" +" ((= x y) x)\n" +" ((zero? x) y)\n" +" ((zero? y) x)\n" +" (else\n" +" (+ (* (lgior (truncate-quotient x 2)\n" +" (truncate-quotient y 2))\n" +" 2)\n" +" (if (and (even? x) (even? y)) 0 1)))))))\n" +" (fold lgior 0 args)))\n" +"\n" +" (define bitwise-ior logior)\n" +"\n" +" (define (logxor . args)\n" +" (letrec ((lgxor\n" +" (lambda (x y)\n" +" (cond\n" +" ((zero? x) y)\n" +" ((zero? y) x)\n" +" (else\n" +" (+ (* (lgxor (floor/ x 2) (floor/ y 2)) 2)\n" +" (if (even? x)\n" +" (if (even? y) 0 1)\n" +" (if (even? y) 1 0))))))))\n" +" (fold lgxor 0 args)))\n" +"\n" +" (define bitwise-xor logxor)\n" +"\n" +" (define (lognot n)\n" +" (- -1 n))\n" +"\n" +" (define bitwise-not lognot)\n" +"\n" +" (define (bitwise-if mask n0 n1)\n" +" (logior (logand mask n0)\n" +" (logand (lognot mask) n1)))\n" +"\n" +" (define bitwise-merge bitwise-if)\n" +"\n" +" (define (logtest j k)\n" +" (not (zero? (logand j k))))\n" +"\n" +" (define any-bits-set? logtest)\n" +"\n" +" ;; # Integer Properties\n" +" (define (logcount n)\n" +" (letrec ((lgcnt\n" +" (lambda (n)\n" +" (if (zero? n) 0\n" +" (+ (lgcnt (floor/ n 2))\n" +" (if (even? n) 0 1))))))\n" +" (if (negative? n)\n" +" (lgcnt (lognot n))\n" +" (lgcnt n))))\n" +"\n" +" (define bit-count logcount)\n" +"\n" +" (define (integer-length n)\n" +" (let loop ((n n) (count 0))\n" +" (if (zero? n)\n" +" count\n" +" (loop (floor/ n 2) (+ count 1)))))\n" +"\n" +" (define (log2-binary-factors n)\n" +" (+ -1 (integer-length (logand n (- n)))))\n" +"\n" +" (define first-set-bit log2-binary-factors)\n" +" \n" +" ;; # Bit Within Word\n" +" (define (logbit? index n)\n" +" (logtest (expt 2 index) n))\n" +"\n" +" (define bit-set? logbit?)\n" +"\n" +" (define (copy-bit index from bit)\n" +" (if bit\n" +" (logior from (expt 2 index))\n" +" (logand from (lognot (expt 2 index)))))\n" +"\n" +"\n" +" ;; # Field of Bits\n" +" (define (ash n count)\n" +" (if (negative? count)\n" +" (let ((k (expt 2 (- count))))\n" +" (if (negative? n)\n" +" (+ -1 (truncate-quotient (+ 1 n) k))\n" +" (truncate-quotient n k)))\n" +" (* (expt 2 count) n)))\n" +"\n" +" (define arithmetic-shift ash)\n" +"\n" +" (define (bit-field n start end)\n" +" (logand (lognot (ash -1 (- end start)))\n" +" (ash n (- start))))\n" +"\n" +" (define (copy-bit-field to from start end)\n" +" (bitwise-if (ash (lognot (ash -1 (- end start))) start)\n" +" (ash from start)\n" +" to))\n" +"\n" +" (define (rotate-bit-field n count start end)\n" +" (let* ((width (- start end))\n" +" (count (floor-remainder count width))\n" +" (mask (lognot (ash -1 width)))\n" +" (zn (logand mask (ash n (- start)))))\n" +" (logior (ash (logior (logand mask (ash zn count))\n" +" (ash zn (- count width)))\n" +" start)\n" +" (logand (lognot (ash mask start)) n))))\n" +"\n" +" (define (reverse-bit-field n start end)\n" +" (letrec ((bit-reverse\n" +" (lambda (k n)\n" +" (let loop ((m (if (negative? n) (lognot n) n))\n" +" (k (- k 1))\n" +" (rvs 0))\n" +" (if (negative? k)\n" +" (if (negative? n) (lognot rvs) rvs)\n" +" (loop (ash m -1)\n" +" (- k 1)\n" +" (logior (ash rvs 1) (logand 1 m))))))))\n" +" (let* ((width (- start end))\n" +" (mask (lognot (ash -1 width)))\n" +" (zn (logand mask (ash n (- start)))))\n" +" (logior (ash (bit-reverse width zn) start)\n" +" (logand (lognot (ash mask start)) n)))))\n" +"\n" +" ;; Bits as Booleans\n" +" (define (integer->list k . len)\n" +" (let ((len (if (null? len) (integer-length k) len)))\n" +" (let loop ((k k) (len len) (acc '()))\n" +" (if (or (zero? k) (zero? len))\n" +" acc\n" +" (loop (floor/ k 2) (- len 1) (cons (if (even? k) #f #t) acc))))))\n" +"\n" +" (define (list->integer lst)\n" +" (let loop ((lst lst) (acc 0))\n" +" (if (null? lst)\n" +" acc\n" +" (loop (cdr lst) (+ (* acc 2) (if (car lst) 1 0))))))\n" +"\n" +" (define (booleans->integer . args)\n" +" (list->integer args))\n" +"\n" +" (export logand bitwise-and\n" +" logior bitwise-ior\n" +" logxor bitwise-xor\n" +" lognot bitwise-not\n" +" bitwise-if bitwise-merge\n" +" logtest any-bits-set?\n" +" logcount bit-count\n" +" integer-length\n" +" log2-binary-factors first-set-bit\n" +" logbit? bit-set?\n" +" copy-bit\n" +" bit-field\n" +" copy-bit-field\n" +" ash arithmetic-shift\n" +" rotate-bit-field\n" +" reverse-bit-field\n" +" integer->list\n" +" list->integer\n" +" booleans->integer))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_95 = +"(define-library (srfi 95)\n" +" (import (scheme base)\n" +" (scheme load)\n" +" (srfi 1))\n" +"\n" +" (define (list-sorted? ls less?)\n" +" (let loop ((cur ls))\n" +" (if (<= (length cur) 1)\n" +" #t\n" +" (if (less? (second cur) (first cur))\n" +" #f\n" +" (loop (cdr cur))))))\n" +"\n" +" (define (identity x)\n" +" x)\n" +"\n" +" (define (merge ls1 ls2 less? . opt-key)\n" +" (let ((key (if (null? opt-key) identity (car opt-key))))\n" +" (let rec ((arg1 ls1) (arg2 ls2))\n" +" (cond ((null? arg1)\n" +" arg2)\n" +" ((null? arg2)\n" +" arg1)\n" +" ((less? (key (car arg1)) (key (car arg2)))\n" +" (cons (car arg1) (rec (cdr arg1) arg2)))\n" +" (else\n" +" (cons (car arg2) (rec arg1 (cdr arg2))))))))\n" +"\n" +" (define (merge-sub! ls1 ls2 less? key)\n" +" (let rec ((arg1 ls1) (arg2 ls2))\n" +" (cond ((null? arg1)\n" +" arg2)\n" +" ((null? arg2)\n" +" arg1)\n" +" ((not (less? (key (car arg2)) (key (car arg1))))\n" +" (set-cdr! arg1 (rec (cdr arg1) arg2)) arg1)\n" +" (else\n" +" (set-cdr! arg2 (rec arg1 (cdr arg2))) arg2))))\n" +"\n" +" (define (merge! ls1 ls2 less? . opt-key)\n" +" (let ((key (if (null? opt-key) identity (car opt-key)))\n" +" (c1 (car ls1))\n" +" (c2 (car ls2))\n" +" (d1 (cdr ls1))\n" +" (d2 (cdr ls2)))\n" +" (when (less? (key c2) (key c1))\n" +" (set-car! ls1 c2)\n" +" (set-car! ls2 c1)\n" +" (set-cdr! ls1 d2)\n" +" (set-cdr! ls2 d1))\n" +" (merge-sub! ls1 ls2 less? key)))\n" +"\n" +" (define (merge-sort ls less?)\n" +" (if (<= (length ls) 1)\n" +" ls\n" +" (let* ((n (length ls))\n" +" (p (quotient n 2))\n" +" (as (take ls p))\n" +" (bs (drop ls p))\n" +" (sa (merge-sort as less?))\n" +" (sb (merge-sort bs less?)))\n" +" (merge sa sb less?))))\n" +"\n" +" (define (merge-sort! ls less?)\n" +" (if (<= (length ls) 1) ls\n" +" (let* ((n (length ls))\n" +" (p (quotient n 2))\n" +" (bs (drop ls p))\n" +" (as (take! ls p))\n" +" (sa (merge-sort! as less?))\n" +" (sb (merge-sort! bs less?)))\n" +" (merge! sa sb less?))))\n" +"\n" +" (export list-sorted?\n" +" merge\n" +" merge!\n" +" merge-sort\n" +" merge-sort!))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_111 = +"(define-library (srfi 111)\n" +" (import (scheme base))\n" +"\n" +" (define-record-type \n" +" (box value)\n" +" box?\n" +" (value unbox set-box!))\n" +"\n" +" (export box box?\n" +" unbox set-box!))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_user = +"; the default repl environment\n" +"\n" +"(define-library (picrin user)\n" +" (import (scheme base)\n" +" (scheme load)\n" +" (scheme process-context)\n" +" (scheme read)\n" +" (scheme write)\n" +" (scheme file)\n" +" (scheme inexact)\n" +" (scheme cxr)\n" +" (scheme lazy)\n" +" (scheme time)\n" +" (picrin macro)\n" +" (picrin dictionary)\n" +" (picrin array)\n" +" (picrin library)))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_repl = +"(define-library (picrin repl)\n" +" (import (scheme base)\n" +" (scheme read)\n" +" (scheme file)\n" +" (scheme write)\n" +" (scheme eval)\n" +" (scheme process-context))\n" +"\n" +" (define (join sep strs)\n" +" (let loop ((result (car strs)) (rest (cdr strs)))\n" +" (if (null? rest)\n" +" result\n" +" (loop (string-append result sep (car rest)) (cdr rest)))))\n" +"\n" +" (define (file->string file)\n" +" (with-input-from-file file\n" +" (lambda ()\n" +" (let loop ((line (read-line)) (acc '()))\n" +" (if (eof-object? line)\n" +" (join \"\\n\" (reverse acc))\n" +" (loop (read-line) (cons line acc)))))))\n" +"\n" +" (define (print obj . port)\n" +" (let ((port (if (null? port) (current-output-port) (car port))))\n" +" (write obj port)\n" +" (newline port)\n" +" obj))\n" +"\n" +" (define (print-help)\n" +" (display \"picrin scheme\\n\")\n" +" (display \"\\n\")\n" +" (display \"Usage: picrin [options] [file]\\n\")\n" +" (display \"\\n\")\n" +" (display \"Options:\\n\")\n" +" (display \" -e [program] run one liner script\\n\")\n" +" (display \" -h or --help show this help\\n\"))\n" +"\n" +" (define (getopt)\n" +" (let ((args (cdr (command-line))))\n" +" (if (null? args)\n" +" #f\n" +" (case (string->symbol (car args))\n" +" ((-h --help)\n" +" (print-help)\n" +" (exit 1))\n" +" ((-e)\n" +" (cadr args))\n" +" (else\n" +" (file->string (car args)))))))\n" +"\n" +" (define (main-loop in out on-err)\n" +" (display \"> \" out)\n" +" (let ((expr (read in)))\n" +" (if (eof-object? expr)\n" +" (newline out) ; exit\n" +" (begin\n" +" (call/cc\n" +" (lambda (leave)\n" +" (with-exception-handler\n" +" (lambda (condition)\n" +" (display (error-object-message condition) (current-error-port))\n" +" (newline)\n" +" (if on-err\n" +" (on-err)\n" +" (leave)))\n" +" (lambda ()\n" +" (print (eval expr '(picrin user)) out)))))\n" +" (main-loop in out on-err)))))\n" +"\n" +" (define (run-repl program)\n" +" (let ((in (if program\n" +" (open-input-string program)\n" +" (current-input-port)))\n" +" (out (if program\n" +" (open-output-string) ; ignore output\n" +" (current-output-port)))\n" +" (on-err (if program\n" +" (lambda () (exit 1))\n" +" #f)))\n" +" (main-loop in out on-err)))\n" +"\n" +" (define (repl)\n" +" (let ((program (getopt)))\n" +" (run-repl program)))\n" +"\n" +" (export repl))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_10_partcont_piclib_partcont = +"(define-library (picrin control)\n" +" (import (scheme base))\n" +"\n" +" ; based on paper \"Representing Monads\" (Filinski 1994)\n" +"\n" +" (define m #f)\n" +"\n" +" (define (abort t)\n" +" (let ((v (t))) ; (t) may update m. do not place me like (m (t))\n" +" (m v)))\n" +"\n" +" (define (reset t)\n" +" (let ((n m))\n" +" (call/cc\n" +" (lambda (k)\n" +" (set! m (lambda (r)\n" +" (set! m n)\n" +" (k r)))\n" +" (abort t)))))\n" +"\n" +" (define (shift h)\n" +" (call/cc\n" +" (lambda (k)\n" +" (abort\n" +" (lambda ()\n" +" (h (lambda (v)\n" +" (reset (lambda ()\n" +" (k v))))))))))\n" +"\n" +" (export shift\n" +" reset))\n" +"\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_10_pretty_print_pretty_print = +"(define-library (picrin pretty-print)\n" +" (import (scheme base)\n" +" (scheme write))\n" +"\n" +" ; (reverse-string-append l) = (apply string-append (reverse l))\n" +"\n" +" (define (reverse-string-append l)\n" +"\n" +" (define (rev-string-append l i)\n" +" (if (pair? l)\n" +" (let* ((str (car l))\n" +" (len (string-length str))\n" +" (result (rev-string-append (cdr l) (+ i len))))\n" +" (let loop ((j 0) (k (- (- (string-length result) i) len)))\n" +" (if (< j len)\n" +" (begin\n" +" (string-set! result k (string-ref str j))\n" +" (loop (+ j 1) (+ k 1)))\n" +" result)))\n" +" (make-string i)))\n" +"\n" +" (rev-string-append l 0))\n" +"\n" +" ;; We define a pretty printer for Scheme S-expressions (sexp). While\n" +" ;; Petite Scheme supports that by its own, mzscheme does not. If you\n" +" ;; get a sexp (like from proof-to-expr) prefix it with a call to spp and\n" +" ;; the output is nicely formated to fit into pp-width many columns:\n" +" ;;\n" +" ;; (spp (proof-to-expr (current-proof)))\n" +" ;;\n" +"\n" +" (define pp-width 80)\n" +"\n" +" ;;\"genwrite.scm\" generic write used by pretty-print and truncated-print.\n" +" ;; Copyright (c) 1991, Marc Feeley\n" +" ;; Author: Marc Feeley (feeley@iro.umontreal.ca)\n" +" ;; Distribution restrictions: none\n" +" ;;\n" +" ;; Modified for Minlog by Stefan Schimanski \n" +" ;; Taken from slib 2d6, genwrite.scm and pp.scm\n" +"\n" +" (define genwrite:newline-str (make-string 1 #\\newline))\n" +"\n" +" (define (generic-write obj display? width output)\n" +"\n" +" (define (read-macro? l)\n" +" (define (length1? l) (and (pair? l) (null? (cdr l))))\n" +" (let ((head (car l)) (tail (cdr l)))\n" +" (case head\n" +" ((quote quasiquote unquote unquote-splicing) (length1? tail))\n" +" (else #f))))\n" +"\n" +" (define (read-macro-body l)\n" +" (cadr l))\n" +"\n" +" (define (read-macro-prefix l)\n" +" (let ((head (car l)) (tail (cdr l)))\n" +" (case head\n" +" ((quote) \"'\")\n" +" ((quasiquote) \"`\")\n" +" ((unquote) \",\")\n" +" ((unquote-splicing) \",@\"))))\n" +"\n" +" (define (out str col)\n" +" (and col (output str) (+ col (string-length str))))\n" +"\n" +" (define (wr obj col)\n" +"\n" +" (define (wr-lst l col)\n" +" (if (pair? l)\n" +" (let loop ((l (cdr l))\n" +" (col (and col (wr (car l) (out \"(\" col)))))\n" +" (cond ((not col) col)\n" +" ((pair? l)\n" +" (loop (cdr l) (wr (car l) (out \" \" col))))\n" +" ((null? l) (out \")\" col))\n" +" (else (out \")\" (wr l (out \" . \" col))))))\n" +" (out \"()\" col)))\n" +"\n" +" (define (wr-expr expr col)\n" +" (if (read-macro? expr)\n" +" (wr (read-macro-body expr) (out (read-macro-prefix expr) col))\n" +" (wr-lst expr col)))\n" +"\n" +" (cond ((pair? obj) (wr-expr obj col))\n" +" ((null? obj) (wr-lst obj col))\n" +" ((vector? obj) (wr-lst (vector->list obj) (out \"#\" col)))\n" +" ((boolean? obj) (out (if obj \"#t\" \"#f\") col))\n" +" ((number? obj) (out (number->string obj) col))\n" +" ((symbol? obj) (out (symbol->string obj) col))\n" +" ((procedure? obj) (out \"#[procedure]\" col))\n" +" ((string? obj) (if display?\n" +" (out obj col)\n" +" (let loop ((i 0) (j 0) (col (out \"\\\"\" col)))\n" +" (if (and col (< j (string-length obj)))\n" +" (let ((c (string-ref obj j)))\n" +" (if (or (char=? c #\\\\)\n" +" (char=? c #\\\"))\n" +" (loop j\n" +" (+ j 1)\n" +" (out \"\\\\\"\n" +" (out (substring obj i j)\n" +" col)))\n" +" (loop i (+ j 1) col)))\n" +" (out \"\\\"\"\n" +" (out (substring obj i j) col))))))\n" +" ((char? obj) (if display?\n" +" (out (make-string 1 obj) col)\n" +" (out (case obj\n" +" ((#\\space) \"space\")\n" +" ((#\\newline) \"newline\")\n" +" (else (make-string 1 obj)))\n" +" (out \"#\\\\\" col))))\n" +" ((input-port? obj) (out \"#[input-port]\" col))\n" +" ((output-port? obj) (out \"#[output-port]\" col))\n" +" ((eof-object? obj) (out \"#[eof-object]\" col))\n" +" (else (out \"#[unknown]\" col))))\n" +"\n" +" (define (pp obj col)\n" +"\n" +" (define (spaces n col)\n" +" (if (> n 0)\n" +" (if (> n 7)\n" +" (spaces (- n 8) (out \" \" col))\n" +" (out (substring \" \" 0 n) col))\n" +" col))\n" +"\n" +" (define (indent to col)\n" +" (and col\n" +" (if (< to col)\n" +" (and (out genwrite:newline-str col) (spaces to 0))\n" +" (spaces (- to col) col))))\n" +"\n" +" (define pp-list #f)\n" +" (define pp-expr #f)\n" +" (define pp-call #f)\n" +" (define pp-down #f)\n" +" (define pp-general #f)\n" +" (define pp-width #f)\n" +" (define pp-expr-list #f)\n" +"\n" +" (define indent-general #f)\n" +" (define max-expr-width #f)\n" +" (define max-call-head-width #f)\n" +" (define style #f)\n" +"\n" +" (define pr\n" +" (lambda (obj col extra pp-pair)\n" +" (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines\n" +" (let ((result '())\n" +" (left (min (+ (- (- width col) extra) 1) max-expr-width)))\n" +" (generic-write obj display? #f\n" +" (lambda (str)\n" +" (set! result (cons str result))\n" +" (set! left (- left (string-length str)))\n" +" (> left 0)))\n" +" (if (> left 0) ; all can be printed on one line\n" +" (out (reverse-string-append result) col)\n" +" (if (pair? obj)\n" +" (pp-pair obj col extra)\n" +" (pp-list (vector->list obj) (out \"#\" col) extra pp-expr))))\n" +" (wr obj col))))\n" +"\n" +" (set! pp-expr\n" +" (lambda (expr col extra)\n" +" (if (read-macro? expr)\n" +" (pr (read-macro-body expr)\n" +" (out (read-macro-prefix expr) col)\n" +" extra\n" +" pp-expr)\n" +" (let ((head (car expr)))\n" +" (if (symbol? head)\n" +" (let ((proc (style head)))\n" +" (if proc\n" +" (proc expr col extra)\n" +" (if (> (string-length (symbol->string head))\n" +" max-call-head-width)\n" +" (pp-general expr col extra #f #f #f pp-expr)\n" +" (pp-call expr col extra pp-expr))))\n" +" (pp-list expr col extra pp-expr))))))\n" +"\n" +" ; (head item1\n" +" ; item2\n" +" ; item3)\n" +" (set! pp-call\n" +" (lambda (expr col extra pp-item)\n" +" (let ((col* (wr (car expr) (out \"(\" col))))\n" +" (and col\n" +" (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))))\n" +"\n" +" ; (item1\n" +" ; item2\n" +" ; item3)\n" +" (set! pp-list\n" +" (lambda (l col extra pp-item)\n" +" (let ((col (out \"(\" col)))\n" +" (pp-down l col col extra pp-item))))\n" +"\n" +" (set! pp-down\n" +" (lambda (l col1 col2 extra pp-item)\n" +" (let loop ((l l) (col col1))\n" +" (and col\n" +" (cond ((pair? l)\n" +" (let ((rest (cdr l)))\n" +" (let ((extra (if (null? rest) (+ extra 1) 0)))\n" +" (loop rest\n" +" (pr (car l) (indent col2 col) extra pp-item)))))\n" +" ((null? l)\n" +" (out \")\" col))\n" +" (else\n" +" (out \")\"\n" +" (pr l\n" +" (indent col2 (out \".\" (indent col2 col)))\n" +" (+ extra 1)\n" +" pp-item))))))))\n" +"\n" +" (set! pp-general\n" +" (lambda (expr col extra named? pp-1 pp-2 pp-3)\n" +"\n" +" (define (tail3 rest col1 col2)\n" +" (pp-down rest col2 col1 extra pp-3))\n" +"\n" +" (define (tail2 rest col1 col2 col3)\n" +" (if (and pp-2 (pair? rest))\n" +" (let* ((val1 (car rest))\n" +" (rest (cdr rest))\n" +" (extra (if (null? rest) (+ extra 1) 0)))\n" +" (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))\n" +" (tail3 rest col1 col2)))\n" +"\n" +" (define (tail1 rest col1 col2 col3)\n" +" (if (and pp-1 (pair? rest))\n" +" (let* ((val1 (car rest))\n" +" (rest (cdr rest))\n" +" (extra (if (null? rest) (+ extra 1) 0)))\n" +" (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))\n" +" (tail2 rest col1 col2 col3)))\n" +"\n" +" (let* ((head (car expr))\n" +" (rest (cdr expr))\n" +" (col* (wr head (out \"(\" col))))\n" +" (if (and named? (pair? rest))\n" +" (let* ((name (car rest))\n" +" (rest (cdr rest))\n" +" (col** (wr name (out \" \" col*))))\n" +" (tail1 rest (+ col indent-general) col** (+ col** 1)))\n" +" (tail1 rest (+ col indent-general) col* (+ col* 1))))))\n" +"\n" +" (set! pp-expr-list\n" +" (lambda (l col extra)\n" +" (pp-list l col extra pp-expr)))\n" +"\n" +" (define (pp-LAMBDA expr col extra)\n" +" (pp-general expr col extra #f pp-expr-list #f pp-expr))\n" +"\n" +" (define (pp-IF expr col extra)\n" +" (pp-general expr col extra #f pp-expr #f pp-expr))\n" +"\n" +" (define (pp-COND expr col extra)\n" +" (pp-call expr col extra pp-expr-list))\n" +"\n" +" (define (pp-CASE expr col extra)\n" +" (pp-general expr col extra #f pp-expr #f pp-expr-list))\n" +"\n" +" (define (pp-AND expr col extra)\n" +" (pp-call expr col extra pp-expr))\n" +"\n" +" (define (pp-LET expr col extra)\n" +" (let* ((rest (cdr expr))\n" +" (named? (and (pair? rest) (symbol? (car rest)))))\n" +" (pp-general expr col extra named? pp-expr-list #f pp-expr)))\n" +"\n" +" (define (pp-BEGIN expr col extra)\n" +" (pp-general expr col extra #f #f #f pp-expr))\n" +"\n" +" (define (pp-DO expr col extra)\n" +" (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))\n" +"\n" +" ; define formatting style (change these to suit your style)\n" +"\n" +" (set! indent-general 2)\n" +"\n" +" (set! max-call-head-width 5)\n" +"\n" +" (set! max-expr-width 50)\n" +"\n" +" (set! style\n" +" (lambda (head)\n" +" (case head\n" +" ((lambda let* letrec define) pp-LAMBDA)\n" +" ((if set!) pp-IF)\n" +" ((cond) pp-COND)\n" +" ((case) pp-CASE)\n" +" ((and or) pp-AND)\n" +" ((let) pp-LET)\n" +" ((begin) pp-BEGIN)\n" +" ((do) pp-DO)\n" +" (else #f))))\n" +"\n" +" (pr obj col 0 pp-expr))\n" +"\n" +" (if width\n" +" (out genwrite:newline-str (pp obj 0))\n" +" (wr obj 0)))\n" +"\n" +" (define (pretty-print obj . opt)\n" +" (let ((port (if (pair? opt) (car opt) (current-output-port))))\n" +" (generic-write obj #f pp-width\n" +" (lambda (s) (display s port) #t))\n" +" (display \"\")))\n" +"\n" +" (export pretty-print))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_20_async_piclib_async = +"(define-library (picrin control async)\n" +" (import (scheme base)\n" +" (picrin control)\n" +" (picrin promise))\n" +"\n" +" (define (promise-unit x)\n" +" (make-promise\n" +" (lambda (resolve _)\n" +" (resolve x))))\n" +"\n" +" (define (promise-bind m f)\n" +" (promise-then m f))\n" +"\n" +" (define-syntax async\n" +" (syntax-rules ()\n" +" ((_ x ...)\n" +" (reset (lambda ()\n" +" (promise-unit (begin x ...)))))))\n" +"\n" +" (define (await m)\n" +" (shift (lambda (f)\n" +" (promise-bind m f))))\n" +"\n" +" (export async await))\n" +; + +static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_20_for_piclib_for = +"(define-library (picrin control list)\n" +" (import (scheme base)\n" +" (picrin control))\n" +"\n" +" (define-syntax for\n" +" (syntax-rules ()\n" +" ((_ expr)\n" +" (reset (lambda () expr)))))\n" +"\n" +" (define (in m)\n" +" (shift (lambda (k)\n" +" (apply append (map k m)))))\n" +"\n" +" (define (yield x)\n" +" (list x))\n" +"\n" +" (define (null . x)\n" +" '())\n" +"\n" +" (export for in yield null))\n" +; + +void +pic_load_piclib(pic_state *pic) +{ + pic_try { + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_base); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_list); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_symbol); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_macro); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_base); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_record); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_array); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_dictionary); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_test); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_experimental_lambda); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_promise); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_async); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_cxr); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_file); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_case_lambda); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_lazy); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_eval); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_r5rs); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_null); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_1); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_8); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_26); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_43); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_60); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_95); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_111); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_user); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_repl); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_10_partcont_piclib_partcont); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_10_pretty_print_pretty_print); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_20_async_piclib_async); + pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_20_for_piclib_for); + } + pic_catch { + /* error! */ + fputs("fatal error: failure in loading built-in.scm\n", stderr); + fputs(pic_errmsg(pic), stderr); + abort(); + } + +#if DEBUG + puts("successfully loaded stdlib"); +#endif +} diff --git a/macro.c b/macro.c new file mode 100644 index 00000000..e9c9b64b --- /dev/null +++ b/macro.c @@ -0,0 +1,494 @@ +/** + * See Copyright Notice in picrin.h + */ + +#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 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) +{ + UNUSED(pic); + + xh_put_int(&senv->map, sym, &rename); +} + +bool +pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename) +{ + xh_entry *e; + + UNUSED(pic); + + if ((e = xh_get_int(&senv->map, sym)) == NULL) { + return false; + } + if (rename != NULL) { + *rename = xh_val(e, pic_sym); + } + return true; +} + +static void +define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) +{ + 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); +} + +static struct pic_macro * +find_macro(pic_state *pic, pic_sym rename) +{ + xh_entry *e; + + if ((e = xh_get_int(&pic->macros, rename)) == NULL) { + return NULL; + } + return xh_val(e, struct pic_macro *); +} + +static pic_sym +make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) +{ + pic_sym rename; + + while (true) { + if (pic_find_rename(pic, senv, sym, &rename)) { + return rename; + } + if (! senv->up) + break; + senv = senv->up; + } + if (! pic_interned_p(pic, sym)) { + return sym; + } + else { + return pic_gensym(pic, sym); + } +} + +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); + +static pic_value +macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) +{ + return pic_sym_value(make_identifier(pic, sym, senv)); +} + +static pic_value +macroexpand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); +} + +static pic_value +macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv) +{ + 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); + x = pic_cons(pic, head, tail); + } else { + x = macroexpand(pic, obj, senv); + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, x); + return x; +} + +static pic_value +macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_value formal, body; + struct pic_senv *in; + pic_value a; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + in = pic_senv_new(pic, senv); + + for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { + pic_value v = pic_car(pic, a); + + if (! pic_sym_p(v)) { + pic_error(pic, "syntax error"); + } + pic_add_rename(pic, in, pic_sym(v)); + } + if (pic_sym_p(a)) { + pic_add_rename(pic, in, pic_sym(a)); + } + else if (! pic_nil_p(a)) { + pic_error(pic, "syntax error"); + } + + formal = macroexpand_list(pic, pic_cadr(pic, expr), in); + body = macroexpand_list(pic, pic_cddr(pic, expr), in); + + return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); +} + +static pic_value +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_sym sym, rename; + pic_value var, val; + + if (pic_length(pic, expr) != 3) { + pic_error(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_sym_p(var)) { + pic_error(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); + } + val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv); + + return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val); +} + +static pic_value +macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_value var, val; + pic_sym sym, rename; + + if (pic_length(pic, expr) != 3) { + pic_error(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_sym_p(var)) { + pic_error(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); + } else { + pic_warnf(pic, "redefining syntax variable: ~s", pic_sym_value(sym)); + } + + val = pic_cadr(pic, pic_cdr(pic, expr)); + + pic_try { + val = pic_eval(pic, val, pic->lib); + } pic_catch { + pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); + } + + 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), senv); + + return pic_none_value(); +} + +static pic_value +macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv) +{ + pic_value v, args; + +#if DEBUG + puts("before expand-1:"); + pic_debug(pic, expr); + 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)); + } + + pic_try { + v = pic_apply(pic, mac->proc, args); + } pic_catch { + pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); + } + +#if DEBUG + puts("after expand-1:"); + pic_debug(pic, v); + puts(""); +#endif + + return v; +} + +static pic_value +macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + switch (pic_type(expr)) { + case PIC_TT_SYMBOL: { + return macroexpand_symbol(pic, pic_sym(expr), senv); + } + case PIC_TT_PAIR: { + pic_value car; + struct pic_macro *mac; + + if (! pic_list_p(expr)) { + pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); + } + + car = macroexpand(pic, pic_car(pic, expr), senv); + if (pic_sym_p(car)) { + pic_sym tag = pic_sym(car); + + if (tag == pic->rDEFINE_SYNTAX) { + return macroexpand_defsyntax(pic, expr, senv); + } + else if (tag == pic->rLAMBDA) { + return macroexpand_lambda(pic, expr, senv); + } + else if (tag == pic->rDEFINE) { + return macroexpand_define(pic, expr, senv); + } + 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 pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv)); + } + default: + return expr; + } +} + +static pic_value +macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value v; + +#if DEBUG + printf("[macroexpand] expanding... "); + pic_debug(pic, expr); + puts(""); +#endif + + v = macroexpand_node(pic, expr, senv); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; +} + +pic_value +pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) +{ + struct pic_lib *prev; + pic_value v; + +#if DEBUG + puts("before expand:"); + pic_debug(pic, expr); + puts(""); +#endif + + /* change library for macro-expansion time processing */ + prev = pic->lib; + pic->lib = lib; + + v = macroexpand(pic, expr, lib->env); + + pic->lib = prev; + +#if DEBUG + puts("after expand:"); + pic_debug(pic, v); + puts(""); +#endif + + return v; +} + +struct pic_senv * +pic_senv_new(pic_state *pic, struct pic_senv *up) +{ + struct pic_senv *senv; + + senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + senv->up = up; + xh_init_int(&senv->map, sizeof(pic_sym)); + + return senv; +} + +struct pic_senv * +pic_null_syntactic_environment(pic_state *pic) +{ + struct pic_senv *senv; + + senv = pic_senv_new(pic, NULL); + + 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); + + return senv; +} + +void +pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) +{ + pic_put_rename(pic, senv, sym, rsym); + + if (pic->lib && pic->lib->env == senv) { + pic_export(pic, sym); + } +} + +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); + + /* symbol registration */ + define_macro(pic, id, pic_proc_new(pic, func, pic_symbol_name(pic, name)), NULL); + + /* auto export! */ + pic_export(pic, name); +} + +bool +pic_identifier_p(pic_state *pic, pic_value obj) +{ + return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj)); +} + +static pic_value +pic_macro_gensym(pic_state *pic) +{ + static const char skel[] = ".g"; + pic_sym uniq; + + pic_get_args(pic, ""); + + uniq = pic_gensym(pic, pic_intern_cstr(pic, skel)); + return pic_sym_value(uniq); +} + +static pic_value +pic_macro_ungensym(pic_state *pic) +{ + pic_sym sym; + + pic_get_args(pic, "m", &sym); + + return pic_sym_value(pic_ungensym(pic, sym)); +} + +static pic_value +pic_macro_macroexpand(pic_state *pic) +{ + pic_value expr; + + pic_get_args(pic, "o", &expr); + + return pic_macroexpand(pic, expr, pic->lib); +} + +static pic_value +pic_macro_macroexpand_1(pic_state *pic) +{ + struct pic_senv *senv = pic->lib->env; + struct pic_macro *mac; + pic_value expr; + pic_sym sym; + + pic_get_args(pic, "o", &expr); + + if (pic_sym_p(expr)) { + if (pic_interned_p(pic, pic_sym(expr))) { + return pic_values2(pic, macroexpand_symbol(pic, pic_sym(expr), senv), pic_true_value()); + } + } + if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) { + sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv); + if ((mac = find_macro(pic, sym)) != NULL) { + return pic_values2(pic, macroexpand_macro(pic, mac, expr, senv), pic_true_value()); + } + } + + return pic_values2(pic, expr, pic_false_value()); /* no expansion occurred */ +} + +static pic_value +pic_macro_identifier_p(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_bool_value(pic_identifier_p(pic, obj)); +} + +static pic_value +pic_macro_make_identifier(pic_state *pic) +{ + pic_value obj; + pic_sym sym; + + pic_get_args(pic, "mo", &sym, &obj); + + pic_assert_type(pic, obj, senv); + + return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj))); +} + +void +pic_init_macro(pic_state *pic) +{ + pic_deflibrary (pic, "(picrin base macro)") { + pic_defun(pic, "identifier?", pic_macro_identifier_p); + pic_defun(pic, "make-identifier", pic_macro_make_identifier); + } + + pic_deflibrary (pic, "(picrin macro)") { + pic_defun(pic, "gensym", pic_macro_gensym); + pic_defun(pic, "ungensym", pic_macro_ungensym); + pic_defun(pic, "macroexpand", pic_macro_macroexpand); + pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1); + } +} diff --git a/number.c b/number.c new file mode 100644 index 00000000..ed6ce95c --- /dev/null +++ b/number.c @@ -0,0 +1,944 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/string.h" +#include "picrin/cont.h" + +static int +gcd(int a, int b) +{ + if (a > b) + return gcd(b, a); + if (a < 0) + return gcd(-a, b); + if (a > 0) + return gcd(b % a, a); + return b; +} + +static double +lcm(int a, int b) +{ + return fabs((double)a * b) / gcd(a, b); +} + +/** + * Returns the length of string representing val. + * radix is between 2 and 36 (inclusive). + * No error checks are performed in this function. + */ +static int +number_string_length(int val, int radix) +{ + long long v = val; /* in case val == INT_MIN */ + int count = 0; + if (val == 0) { + return 1; + } + if (val < 0) { + v = - v; + count = 1; + } + while (v > 0) { + ++count; + v /= radix; + } + return count; +} + +/** + * Returns the string representing val. + * radix is between 2 and 36 (inclusive). + * This function overwrites buffer and stores the result. + * No error checks are performed in this function. It is caller's responsibility to avoid buffer-overrun. + */ +static void +number_string(int val, int radix, int length, char *buffer) { + const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz"; + long long v = val; + int i; + if (val == 0) { + buffer[0] = '0'; + buffer[1] = '\0'; + return; + } + if (val < 0) { + buffer[0] = '-'; + v = -v; + } + + for(i = length - 1; v > 0; --i) { + buffer[i] = digits[v % radix]; + v /= radix; + } + buffer[length] = '\0'; + return; +} + +static pic_value +pic_number_real_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_float_p(v) || pic_int_p(v)); +} + +static pic_value +pic_number_integer_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)) { + double f = pic_float(v); + + if (isinf(f)) { + return pic_false_value(); + } + + if (f == round(f)) { + return pic_true_value(); + } + } + return pic_false_value(); +} + +static pic_value +pic_number_exact_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_int_p(v)); +} + +static pic_value +pic_number_inexact_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + 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(); +} + +#define DEFINE_ARITH_CMP(op, name) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc; \ + pic_value *argv; \ + size_t i; \ + double f,g; \ + \ + pic_get_args(pic, "ff*", &f, &g, &argc, &argv); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + \ + for (i = 0; i < argc; ++i) { \ + f = g; \ + if (pic_float_p(argv[i])) \ + g = pic_float(argv[i]); \ + else if (pic_int_p(argv[i])) \ + g = pic_int(argv[i]); \ + else \ + pic_error(pic, #op ": number required"); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + } \ + \ + return pic_true_value(); \ + } + +DEFINE_ARITH_CMP(==, eq) +DEFINE_ARITH_CMP(<, lt) +DEFINE_ARITH_CMP(>, gt) +DEFINE_ARITH_CMP(<=, le) +DEFINE_ARITH_CMP(>=, ge) + +static pic_value +pic_number_zero_p(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_bool_value(f == 0); +} + +static pic_value +pic_number_positive_p(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_bool_value(f > 0); +} + +static pic_value +pic_number_negative_p(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_bool_value(f < 0); +} + +static pic_value +pic_number_odd_p(pic_state *pic) +{ + int i; + + pic_get_args(pic, "i", &i); + + return pic_bool_value(i % 2 != 0); +} + +static pic_value +pic_number_even_p(pic_state *pic) +{ + int i; + + pic_get_args(pic, "i", &i); + + return pic_bool_value(i % 2 == 0); +} + +static pic_value +pic_number_max(pic_state *pic) +{ + size_t argc; + pic_value *argv; + size_t i; + double f; + bool e = true; + + pic_get_args(pic, "*", &argc, &argv); + + f = -INFINITY; + for (i = 0; i < argc; ++i) { + if (pic_int_p(argv[i])) { + f = fmax(f, pic_int(argv[i])); + } + else if (pic_float_p(argv[i])) { + e = false; + f = fmax(f, pic_float(argv[i])); + } + else { + pic_error(pic, "max: number required"); + } + } + + return e ? pic_int_value(f) : pic_float_value(f); +} + +static pic_value +pic_number_min(pic_state *pic) +{ + size_t argc; + pic_value *argv; + size_t i; + double f; + bool e = true; + + pic_get_args(pic, "*", &argc, &argv); + + f = INFINITY; + for (i = 0; i < argc; ++i) { + if (pic_int_p(argv[i])) { + f = fmin(f, pic_int(argv[i])); + } + else if (pic_float_p(argv[i])) { + e = false; + f = fmin(f, pic_float(argv[i])); + } + else { + pic_error(pic, "min: number required"); + } + } + + return e ? pic_int_value(f) : pic_float_value(f); +} + +#define DEFINE_ARITH_OP(op, name, unit) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc; \ + pic_value *argv; \ + size_t i; \ + double f; \ + bool e = true; \ + \ + 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 if (pic_float_p(argv[i])) { \ + e = false; \ + f op##= pic_float(argv[i]); \ + } \ + else { \ + pic_error(pic, #op ": number required"); \ + } \ + } \ + \ + return e ? pic_int_value((int)f) : pic_float_value(f); \ + } + +DEFINE_ARITH_OP(+, add, 0) +DEFINE_ARITH_OP(*, mul, 1) + +#define DEFINE_ARITH_INV_OP(op, name, unit, exact) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc; \ + pic_value *argv; \ + size_t i; \ + double f; \ + bool e; \ + \ + pic_get_args(pic, "F*", &f, &e, &argc, &argv); \ + \ + 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_error(pic, #op ": number required"); \ + } \ + } \ + \ + return e ? pic_int_value((int)f) : pic_float_value(f); \ + } + +DEFINE_ARITH_INV_OP(-, sub, 0, true) +DEFINE_ARITH_INV_OP(/, div, 1, false) + +static pic_value +pic_number_abs(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value(fabs(f)); + } + else { + return pic_float_value(fabs(f)); + } +} + +static pic_value +pic_number_floor_quotient(pic_state *pic) +{ + int i,j; + bool e1, e2; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + if (e1 && e2) { + return pic_int_value((int)floor((double)i/j)); + } + else { + return pic_float_value(floor((double)i/j)); + } +} + +static pic_value +pic_number_floor_remainder(pic_state *pic) +{ + int i,j,q; + bool e1, e2; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + q = (int)floor((double)i/j); + if (e1 && e2) { + return pic_int_value(i - j * q); + } + else { + return pic_float_value(i - j * q); + } +} + +static pic_value +pic_number_floor2(pic_state *pic) +{ + int i, j; + bool e1, e2; + double q, r; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + q = floor((double)i/j); + r = i - j * q; + + if (e1 && e2) { + return pic_values2(pic, pic_int_value(q), pic_int_value(r)); + } + else { + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + } +} + +static pic_value +pic_number_trunc_quotient(pic_state *pic) +{ + int i,j; + bool e1, e2; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + if (e1 && e2) { + return pic_int_value((int)trunc((double)i/j)); + } + else { + return pic_float_value(trunc((double)i/j)); + } +} + +static pic_value +pic_number_trunc_remainder(pic_state *pic) +{ + int i,j,q; + bool e1, e2; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + q = (int)trunc((double)i/j); + if (e1 && e2) { + return pic_int_value(i - j * q); + } + else { + return pic_float_value(i - j * q); + } +} + +static pic_value +pic_number_trunc2(pic_state *pic) +{ + int i, j; + bool e1, e2; + double q, r; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + q = trunc((double)i/j); + r = i - j * q; + + if (e1 && e2) { + return pic_values2(pic, pic_int_value(q), pic_int_value(r)); + } + else { + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + } +} + +static pic_value +pic_number_gcd(pic_state *pic) +{ + size_t argc; + pic_value *args; + int r; + bool e = true; + + pic_get_args(pic, "*", &argc, &args); + + r = 0; + while (argc-- > 0) { + if (pic_int_p(args[argc])) { + r = gcd(r, pic_int(args[argc])); + } + else if (pic_float_p(args[argc])) { + e = false; + r = gcd(r, pic_float(args[argc])); + } + else { + pic_error(pic, "gcd: number required"); + } + } + return e ? pic_int_value(r) : pic_float_value(r); +} + +static pic_value +pic_number_lcm(pic_state *pic) +{ + size_t argc; + pic_value *args; + double r; + bool e = true; + + pic_get_args(pic, "*", &argc, &args); + + r = 1; + while (argc-- > 0) { + if (pic_int_p(args[argc])) { + r = lcm(r, pic_int(args[argc])); + } + else if (pic_float_p(args[argc])) { + e = false; + r = lcm(r, pic_float(args[argc])); + } + else { + pic_error(pic, "lcm: number required"); + } + } + return e && pic_valid_int(r) ? pic_int_value(r) : pic_float_value(r); +} + +static pic_value +pic_number_floor(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } + else { + return pic_float_value(floor(f)); + } +} + +static pic_value +pic_number_ceil(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } + else { + return pic_float_value(ceil(f)); + } +} + +static pic_value +pic_number_trunc(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } + else { + return pic_float_value(trunc(f)); + } +} + +static pic_value +pic_number_round(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } + else { + return pic_float_value(round(f)); + } +} + +static pic_value +pic_number_exp(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + return pic_float_value(exp(f)); +} + +static pic_value +pic_number_log(pic_state *pic) +{ + double f,g; + int argc; + + argc = pic_get_args(pic, "f|f", &f, &g); + if (argc == 1) { + return pic_float_value(log(f)); + } + else { + return pic_float_value(log(f) / log(g)); + } +} + +static pic_value +pic_number_sin(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = sin(f); + return pic_float_value(f); +} + +static pic_value +pic_number_cos(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = cos(f); + return pic_float_value(f); +} + +static pic_value +pic_number_tan(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = tan(f); + return pic_float_value(f); +} + +static pic_value +pic_number_acos(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = acos(f); + return pic_float_value(f); +} + +static pic_value +pic_number_asin(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = asin(f); + return pic_float_value(f); +} + +static pic_value +pic_number_atan(pic_state *pic) +{ + double f,g; + int argc; + + argc = pic_get_args(pic, "f|f", &f, &g); + if (argc == 1) { + f = atan(f); + return pic_float_value(f); + } + else { + return pic_float_value(atan2(f,g)); + } +} + +static pic_value +pic_number_exact_integer_sqrt(pic_state *pic) +{ + int k, n, m; + + pic_get_args(pic, "i", &k); + + n = sqrt(k); + m = k - n * n; + + return pic_values2(pic, pic_int_value(n), pic_int_value(m)); +} + +static pic_value +pic_number_square(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + long long i = (long long)f; + + if (i * i <= INT_MAX) { + return pic_int_value(i * i); + } + } + return pic_float_value(f * f); +} + +static pic_value +pic_number_sqrt(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + 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_str_new(pic, buf, sizeof buf - 1)); + } + else { + char buf[snprintf(NULL, 0, "%a", f) + 1]; + + snprintf(buf, sizeof buf, "%a", f); + + return pic_obj_value(pic_str_new(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(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); +} + +void +pic_init_number(pic_state *pic) +{ + size_t ai = pic_gc_arena_preserve(pic); + + pic_defun(pic, "number?", pic_number_real_p); + pic_defun(pic, "complex?", pic_number_real_p); + pic_defun(pic, "real?", pic_number_real_p); + pic_defun(pic, "rational?", pic_number_real_p); + pic_defun(pic, "integer?", pic_number_integer_p); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "exact?", pic_number_exact_p); + pic_defun(pic, "inexact?", pic_number_inexact_p); + pic_defun(pic, "exact-integer?", pic_number_exact_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_gc_arena_restore(pic, ai); + + pic_defun(pic, "zero?", pic_number_zero_p); + pic_defun(pic, "positive?", pic_number_positive_p); + pic_defun(pic, "negative?", pic_number_negative_p); + pic_defun(pic, "odd?", pic_number_odd_p); + pic_defun(pic, "even?", pic_number_even_p); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "min", pic_number_min); + pic_defun(pic, "max", pic_number_max); + 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_gc_arena_restore(pic, ai); + + pic_defun(pic, "abs", pic_number_abs); + pic_defun(pic, "floor-quotient", pic_number_floor_quotient); + pic_defun(pic, "floor-remainder", pic_number_floor_remainder); + pic_defun(pic, "floor/", pic_number_floor2); + pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient); + pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder); + pic_defun(pic, "truncate/", pic_number_trunc2); + pic_defun(pic, "modulo", pic_number_floor_remainder); + pic_defun(pic, "quotient", pic_number_trunc_quotient); + pic_defun(pic, "remainder", pic_number_trunc_remainder); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "gcd", pic_number_gcd); + pic_defun(pic, "lcm", pic_number_lcm); + pic_gc_arena_restore(pic, ai); + + 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, "exact-integer-sqrt", pic_number_exact_integer_sqrt); + pic_defun(pic, "square", pic_number_square); + pic_defun(pic, "expt", pic_number_expt); + 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); + + 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); + + pic_deflibrary (pic, "(scheme inexact)") { + 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_defun(pic, "exp", pic_number_exp); + pic_defun(pic, "log", pic_number_log); + pic_defun(pic, "sin", pic_number_sin); + pic_defun(pic, "cos", pic_number_cos); + pic_defun(pic, "tan", pic_number_tan); + pic_defun(pic, "acos", pic_number_acos); + pic_defun(pic, "asin", pic_number_asin); + pic_defun(pic, "atan", pic_number_atan); + + pic_defun(pic, "sqrt", pic_number_sqrt); + } +} diff --git a/pair.c b/pair.c new file mode 100644 index 00000000..5b62ceaf --- /dev/null +++ b/pair.c @@ -0,0 +1,767 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/pair.h" + +pic_value +pic_cons(pic_state *pic, pic_value car, pic_value cdr) +{ + struct pic_pair *pair; + + pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR); + pair->car = car; + pair->cdr = cdr; + + return pic_obj_value(pair); +} + +pic_value +pic_car(pic_state *pic, pic_value obj) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_errorf(pic, "pair required, but got ~s", obj); + } + pair = pic_pair_ptr(obj); + + return pair->car; +} + +pic_value +pic_cdr(pic_state *pic, pic_value obj) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_errorf(pic, "pair required, but got ~s", obj); + } + pair = pic_pair_ptr(obj); + + return pair->cdr; +} + +void +pic_set_car(pic_state *pic, pic_value obj, pic_value val) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_error(pic, "pair required"); + } + pair = pic_pair_ptr(obj); + + pair->car = val; +} + +void +pic_set_cdr(pic_state *pic, pic_value obj, pic_value val) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_error(pic, "pair required"); + } + pair = pic_pair_ptr(obj); + + pair->cdr = val; +} + +bool +pic_list_p(pic_value obj) +{ + pic_value local, rapid; + int i; + + /* Floyd's cycle-finding algorithm. */ + + local = rapid = obj; + while (true) { + + /* advance rapid fast-forward; runs 2x faster than local */ + for (i = 0; i < 2; ++i) { + if (pic_pair_p(rapid)) { + rapid = pic_pair_ptr(rapid)->cdr; + } + else { + return pic_nil_p(rapid); + } + } + + /* advance local */ + local = pic_pair_ptr(local)->cdr; + + if (pic_eq_p(local, rapid)) { + return false; + } + } +} + +pic_value +pic_list1(pic_state *pic, pic_value obj1) +{ + return pic_cons(pic, obj1, pic_nil_value()); +} + +pic_value +pic_list2(pic_state *pic, pic_value obj1, pic_value obj2) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list1(pic, obj2)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list4(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list3(pic, obj2, obj3, obj4)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list6(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list5(pic, obj2, obj3, obj4, obj5, obj6)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list_by_array(pic_state *pic, size_t c, pic_value *vs) +{ + pic_value v; + + v = pic_nil_value(); + while (c--) { + v = pic_cons(pic, vs[c], v); + } + return v; +} + +pic_value +pic_make_list(pic_state *pic, int k, pic_value fill) +{ + pic_value list; + int i; + + list = pic_nil_value(); + for (i = 0; i < k; ++i) { + list = pic_cons(pic, fill, list); + } + + return list; +} + +int +pic_length(pic_state *pic, pic_value obj) +{ + int c = 0; + + if (! pic_list_p(obj)) { + pic_errorf(pic, "length: expected list, but got ~s", obj); + } + + while (! pic_nil_p(obj)) { + obj = pic_cdr(pic, obj); + ++c; + } + + return c; +} + +pic_value +pic_reverse(pic_state *pic, pic_value list) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value v, acc; + + acc = pic_nil_value(); + pic_for_each(v, list) { + acc = pic_cons(pic, v, acc); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, acc); + } + return acc; +} + +pic_value +pic_append(pic_state *pic, pic_value xs, pic_value ys) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value x; + + xs = pic_reverse(pic, xs); + pic_for_each (x, xs) { + ys = pic_cons(pic, x, ys); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, xs); + pic_gc_protect(pic, ys); + } + return ys; +} + +pic_value +pic_memq(pic_state *pic, pic_value key, pic_value list) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (pic_eq_p(key, pic_car(pic, list))) + return list; + + list = pic_cdr(pic, list); + goto enter; +} + +pic_value +pic_memv(pic_state *pic, pic_value key, pic_value list) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (pic_eqv_p(key, pic_car(pic, list))) + return list; + + list = pic_cdr(pic, list); + goto enter; +} + +pic_value +pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (compar == NULL) { + if (pic_equal_p(pic, key, pic_car(pic, list))) + return list; + } else { + if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list)))) + return list; + } + + list = pic_cdr(pic, list); + goto enter; +} + +pic_value +pic_assq(pic_state *pic, pic_value key, pic_value assoc) +{ + pic_value cell; + + enter: + + if (pic_nil_p(assoc)) + return pic_false_value(); + + cell = pic_car(pic, assoc); + if (pic_eq_p(key, pic_car(pic, cell))) + return cell; + + assoc = pic_cdr(pic, assoc); + goto enter; +} + +pic_value +pic_assv(pic_state *pic, pic_value key, pic_value assoc) +{ + pic_value cell; + + enter: + + if (pic_nil_p(assoc)) + return pic_false_value(); + + cell = pic_car(pic, assoc); + if (pic_eqv_p(key, pic_car(pic, cell))) + return cell; + + assoc = pic_cdr(pic, assoc); + goto enter; +} + +pic_value +pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar) +{ + pic_value cell; + + enter: + + if (pic_nil_p(assoc)) + return pic_false_value(); + + cell = pic_car(pic, assoc); + if (compar == NULL) { + if (pic_equal_p(pic, key, pic_car(pic, cell))) + return cell; + } else { + if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell)))) + return cell; + } + + assoc = pic_cdr(pic, assoc); + goto enter; +} + +pic_value +pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc) +{ + return pic_cons(pic, pic_cons(pic, key, val), assoc); +} + +pic_value +pic_caar(pic_state *pic, pic_value v) +{ + return pic_car(pic, pic_car(pic, v)); +} + +pic_value +pic_cadr(pic_state *pic, pic_value v) +{ + return pic_car(pic, pic_cdr(pic, v)); +} + +pic_value +pic_cdar(pic_state *pic, pic_value v) +{ + return pic_cdr(pic, pic_car(pic, v)); +} + +pic_value +pic_cddr(pic_state *pic, pic_value v) +{ + return pic_cdr(pic, pic_cdr(pic, v)); +} + +pic_value +pic_list_tail(pic_state *pic, pic_value list, int i) +{ + while (i-- > 0) { + list = pic_cdr(pic, list); + } + return list; +} + +pic_value +pic_list_ref(pic_state *pic, pic_value list, int i) +{ + return pic_car(pic, pic_list_tail(pic, list, i)); +} + +void +pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj) +{ + pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj; +} + +pic_value +pic_list_copy(pic_state *pic, pic_value obj) +{ + if (pic_pair_p(obj)) { + return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj))); + } + else { + return obj; + } +} + +static pic_value +pic_pair_pair_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_pair_p(v)); +} + +static pic_value +pic_pair_cons(pic_state *pic) +{ + pic_value v,w; + + pic_get_args(pic, "oo", &v, &w); + + return pic_cons(pic, v, w); +} + +static pic_value +pic_pair_car(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_car(pic, v); +} + +static pic_value +pic_pair_cdr(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_cdr(pic, v); +} + +static pic_value +pic_pair_caar(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_caar(pic, v); +} + +static pic_value +pic_pair_cadr(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_cadr(pic, v); +} + +static pic_value +pic_pair_cdar(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_cdar(pic, v); +} + +static pic_value +pic_pair_cddr(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_cddr(pic, v); +} + +static pic_value +pic_pair_set_car(pic_state *pic) +{ + pic_value v,w; + + pic_get_args(pic, "oo", &v, &w); + + if (! pic_pair_p(v)) + pic_error(pic, "pair expected"); + + pic_pair_ptr(v)->car = w; + return pic_none_value(); +} + +static pic_value +pic_pair_set_cdr(pic_state *pic) +{ + pic_value v,w; + + pic_get_args(pic, "oo", &v, &w); + + if (! pic_pair_p(v)) + pic_error(pic, "pair expected"); + + pic_pair_ptr(v)->cdr = w; + return pic_none_value(); +} + +static pic_value +pic_pair_null_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_nil_p(v)); +} + +static pic_value +pic_pair_list_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_list_p(v)); +} + +static pic_value +pic_pair_make_list(pic_state *pic) +{ + int i; + pic_value fill = pic_none_value(); + + pic_get_args(pic, "i|o", &i, &fill); + + return pic_make_list(pic, i, fill); +} + +static pic_value +pic_pair_list(pic_state *pic) +{ + size_t argc; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + return pic_list_by_array(pic, argc, argv); +} + +static pic_value +pic_pair_length(pic_state *pic) +{ + pic_value list; + + pic_get_args(pic, "o", &list); + + return pic_int_value(pic_length(pic, list)); +} + +static pic_value +pic_pair_append(pic_state *pic) +{ + size_t argc; + pic_value *args, list; + + pic_get_args(pic, "*", &argc, &args); + + if (argc == 0) { + return pic_nil_value(); + } + + list = args[--argc]; + + while (argc-- > 0) { + list = pic_append(pic, args[argc], list); + } + return list; +} + +static pic_value +pic_pair_reverse(pic_state *pic) +{ + pic_value list; + + pic_get_args(pic, "o", &list); + + return pic_reverse(pic, list); +} + +static pic_value +pic_pair_list_tail(pic_state *pic) +{ + pic_value list; + int i; + + pic_get_args(pic, "oi", &list, &i); + + return pic_list_tail(pic, list, i); +} + +static pic_value +pic_pair_list_ref(pic_state *pic) +{ + pic_value list; + int i; + + pic_get_args(pic, "oi", &list, &i); + + return pic_list_ref(pic, list, i); +} + +static pic_value +pic_pair_list_set(pic_state *pic) +{ + pic_value list, obj; + int i; + + pic_get_args(pic, "oio", &list, &i, &obj); + + pic_list_set(pic, list, i, obj); + + return pic_none_value(); +} + +static pic_value +pic_pair_list_copy(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_list_copy(pic, obj); +} + +static pic_value +pic_pair_memq(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_memq(pic, key, list); +} + +static pic_value +pic_pair_memv(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_memv(pic, key, list); +} + +static pic_value +pic_pair_member(pic_state *pic) +{ + struct pic_proc *proc = NULL; + pic_value key, list; + + pic_get_args(pic, "oo|l", &key, &list, &proc); + + return pic_member(pic, key, list, proc); +} + +static pic_value +pic_pair_assq(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_assq(pic, key, list); +} + +static pic_value +pic_pair_assv(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_assv(pic, key, list); +} + +static pic_value +pic_pair_assoc(pic_state *pic) +{ + struct pic_proc *proc = NULL; + pic_value key, list; + + pic_get_args(pic, "oo|l", &key, &list, &proc); + + return pic_assoc(pic, key, list, proc); +} + +void +pic_init_pair(pic_state *pic) +{ + pic_deflibrary (pic, "(picrin base list)") { + 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); + 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_deflibrary (pic, "(picrin list)") { + pic_defun(pic, "caar", pic_pair_caar); + pic_defun(pic, "cadr", pic_pair_cadr); + pic_defun(pic, "cdar", pic_pair_cdar); + pic_defun(pic, "cddr", pic_pair_cddr); + pic_defun(pic, "list?", pic_pair_list_p); + pic_defun(pic, "make-list", pic_pair_make_list); + pic_defun(pic, "list", pic_pair_list); + pic_defun(pic, "length", pic_pair_length); + pic_defun(pic, "append", pic_pair_append); + pic_defun(pic, "reverse", pic_pair_reverse); + pic_defun(pic, "list-tail", pic_pair_list_tail); + pic_defun(pic, "list-ref", pic_pair_list_ref); + pic_defun(pic, "list-set!", pic_pair_list_set); + pic_defun(pic, "list-copy", pic_pair_list_copy); + pic_defun(pic, "memq", pic_pair_memq); + pic_defun(pic, "memv", pic_pair_memv); + pic_defun(pic, "member", pic_pair_member); + pic_defun(pic, "assq", pic_pair_assq); + pic_defun(pic, "assv", pic_pair_assv); + pic_defun(pic, "assoc", pic_pair_assoc); + } +} diff --git a/port.c b/port.c new file mode 100644 index 00000000..b9790d06 --- /dev/null +++ b/port.c @@ -0,0 +1,749 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/proc.h" +#include "picrin/port.h" +#include "picrin/string.h" +#include "picrin/blob.h" +#include "picrin/var.h" + +pic_value +pic_eof_object() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_EOF); + + return v; +} + +struct pic_port * +pic_stdin(pic_state *pic) +{ + struct pic_proc *proc; + + proc = pic_proc_ptr(pic_ref(pic, "current-input-port")); + + return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); +} + +struct pic_port * +pic_stdout(pic_state *pic) +{ + struct pic_proc *proc; + + proc = pic_proc_ptr(pic_ref(pic, "current-output-port")); + + return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); +} + +static struct pic_port * +port_new_stdport(pic_state *pic, xFILE *file, short dir) +{ + struct pic_port *port; + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = dir | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + return port; +} + +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->flags = PIC_PORT_IN | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + + xfputs(str, port->file); + xfflush(port->file); + xrewind(port->file); + + return port; +} + +struct pic_port * +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->flags = PIC_PORT_OUT | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + + return port; +} + +struct pic_string * +pic_get_output_string(pic_state *pic, struct pic_port *port) +{ + long size; + char *buf; + + /* get endpos */ + xfflush(port->file); + size = 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); + + return pic_str_new(pic, buf, size); +} + +void +pic_close_port(pic_state *pic, struct pic_port *port) +{ + if (xfclose(port->file) == EOF) { + pic_error(pic, "close-port: failure"); + } + port->status = PIC_PORT_CLOSE; +} + +static pic_value +pic_port_input_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_IN) != 0) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_output_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_OUT) != 0) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_textual_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_TEXT) != 0) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_binary_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_BINARY) != 0) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_port_p(v)); +} + +static pic_value +pic_port_input_port_open_p(pic_state *pic) +{ + pic_value v; + struct pic_port *port; + + pic_get_args(pic, "o", &v); + + if (! pic_port_p(v)) + return pic_false_value(); + port = pic_port_ptr(v); + if ((port->flags & PIC_PORT_IN) == 0) + return pic_false_value(); + + return pic_bool_value(port->status == PIC_PORT_OPEN); +} + +static pic_value +pic_port_output_port_open_p(pic_state *pic) +{ + pic_value v; + struct pic_port *port; + + pic_get_args(pic, "o", &v); + + if (! pic_port_p(v)) + return pic_false_value(); + port = pic_port_ptr(v); + if ((port->flags & PIC_PORT_OUT) == 0) + return pic_false_value(); + + return pic_bool_value(port->status == PIC_PORT_OPEN); +} + +static pic_value +pic_port_eof_object_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_vtype(v) == PIC_VTYPE_EOF) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_eof_object(pic_state *pic) +{ + pic_get_args(pic, ""); + + return pic_eof_object(); +} + +static pic_value +pic_port_close_port(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, "p", &port); + + pic_close_port(pic, port); + + return pic_none_value(); +} + +#define assert_port_profile(port, flgs, stat, caller) do { \ + if ((port->flags & (flgs)) != (flgs)) { \ + switch (flgs) { \ + case PIC_PORT_IN: \ + pic_error(pic, caller ": expected output port"); \ + case PIC_PORT_OUT: \ + pic_error(pic, caller ": expected input port"); \ + case PIC_PORT_IN | PIC_PORT_TEXT: \ + pic_error(pic, caller ": expected input/textual port"); \ + case PIC_PORT_IN | PIC_PORT_BINARY: \ + pic_error(pic, caller ": expected input/binary port"); \ + case PIC_PORT_OUT | PIC_PORT_TEXT: \ + pic_error(pic, caller ": expected output/textual port"); \ + case PIC_PORT_OUT | PIC_PORT_BINARY: \ + pic_error(pic, caller ": expected output/binary port"); \ + } \ + } \ + if (port->status != stat) { \ + switch (stat) { \ + case PIC_PORT_OPEN: \ + pic_error(pic, caller ": expected open port"); \ + case PIC_PORT_CLOSE: \ + pic_error(pic, caller ": expected close port"); \ + } \ + } \ + } while (0) + +static pic_value +pic_port_open_input_string(pic_state *pic) +{ + struct pic_port *port; + char *str; + + pic_get_args(pic, "z", &str); + + port = pic_open_input_string(pic, str); + + return pic_obj_value(port); +} + +static pic_value +pic_port_open_output_string(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, ""); + + port = pic_open_output_string(pic); + + return pic_obj_value(port); +} + +static pic_value +pic_port_get_output_string(pic_state *pic) +{ + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string"); + + return pic_obj_value(pic_get_output_string(pic, port)); +} + +static pic_value +pic_port_open_input_blob(pic_state *pic) +{ + struct pic_port *port; + struct pic_blob *blob; + + 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->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); +} + +static pic_value +pic_port_open_output_bytevector(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, ""); + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); + port->file = xmopen(); + port->flags = PIC_PORT_OUT | PIC_PORT_BINARY; + port->status = PIC_PORT_OPEN; + + return pic_obj_value(port); +} + +static pic_value +pic_port_get_output_bytevector(pic_state *pic) +{ + struct pic_port *port = pic_stdout(pic); + pic_blob *blob; + long endpos; + + 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); + endpos = xftell(port->file); + xrewind(port->file); + + /* copy to buf */ + blob = pic_blob_new(pic, endpos); + xfread(blob->data, 1, endpos, port->file); + + return pic_obj_value(blob); +} + +static pic_value +pic_port_read_char(pic_state *pic) +{ + int c; + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-char"); + + if ((c = xfgetc(port->file)) == EOF) { + return pic_eof_object(); + } + else { + return pic_char_value((char)c); + } +} + +static pic_value +pic_port_peek_char(pic_state *pic) +{ + int c; + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "peek-char"); + + if ((c = xfgetc(port->file)) == EOF) { + return pic_eof_object(); + } + else { + xungetc(c, port->file); + return pic_char_value((char)c); + } +} + +static pic_value +pic_port_read_line(pic_state *pic) +{ + int c; + struct pic_port *port = pic_stdin(pic), *buf; + struct pic_string *str; + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-line"); + + buf = pic_open_output_string(pic); + while ((c = xfgetc(port->file)) != EOF && c != '\n') { + xfputc(c, buf->file); + } + + str = pic_get_output_string(pic, buf); + if (pic_strlen(str) == 0 && c == EOF) { + return pic_eof_object(); + } + else { + return pic_obj_value(str); + } +} + +static pic_value +pic_port_char_ready_p(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "char-ready?"); + + pic_get_args(pic, "|p", &port); + + return pic_true_value(); /* FIXME: always returns #t */ +} + +static pic_value +pic_port_read_string(pic_state *pic){ + struct pic_port *port = pic_stdin(pic), *buf; + pic_str *str; + int k, i; + int c; + + pic_get_args(pic, "i|p", &k, &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-stritg"); + + c = EOF; + buf = pic_open_output_string(pic); + for(i = 0; i < k; ++i) { + if((c = xfgetc(port->file)) == EOF){ + break; + } + xfputc(c, buf->file); + } + + str = pic_get_output_string(pic, buf); + if (pic_strlen(str) == 0 && c == EOF) { + return pic_eof_object(); + } + else { + return pic_obj_value(str); + } + +} + +static pic_value +pic_port_read_byte(pic_state *pic){ + struct pic_port *port = pic_stdin(pic); + int c; + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8"); + if ((c = xfgetc(port->file)) == EOF) { + return pic_eof_object(); + } + + return pic_int_value(c); +} + +static pic_value +pic_port_peek_byte(pic_state *pic) +{ + int c; + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "peek-u8"); + + c = xfgetc(port->file); + if (c == EOF) { + return pic_eof_object(); + } + else { + xungetc(c, port->file); + return pic_int_value(c); + } +} + +static pic_value +pic_port_byte_ready_p(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "u8-ready?"); + + return pic_true_value(); /* FIXME: always returns #t */ +} + + +static pic_value +pic_port_read_blob(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + pic_blob *blob; + int k, i; + + pic_get_args(pic, "i|p", &k, &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector"); + + blob = pic_blob_new(pic, k); + + i = xfread(blob->data, sizeof(char), k, port->file); + if ( i == 0 ) { + return pic_eof_object(); + } + else { + pic_realloc(pic, blob->data, i); + blob->len = i; + return pic_obj_value(blob); + } +} + +static pic_value +pic_port_read_blob_ip(pic_state *pic) +{ + struct pic_port *port; + struct pic_blob *bv; + int i, n, start, end, len; + char *buf; + + n = pic_get_args(pic, "b|pii", &bv, &port, &start, &end); + switch (n) { + case 1: + port = pic_stdin(pic); + case 2: + start = 0; + case 3: + end = bv->len; + } + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!"); + len = end - start; + + buf = pic_calloc(pic, len, sizeof(char)); + i = xfread(buf, sizeof(char), len, port->file); + memcpy(bv->data + start, buf, i); + pic_free(pic, buf); + + if ( i == 0) { + return pic_eof_object(); + } + else { + return pic_int_value(i); + } +} + +static pic_value +pic_port_newline(pic_state *pic) +{ + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "newline"); + + xfputs("\n", port->file); + return pic_none_value(); +} + +static pic_value +pic_port_write_char(pic_state *pic) +{ + char c; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "c|p", &c, &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-char"); + + xfputc(c, port->file); + return pic_none_value(); +} + +static pic_value +pic_port_write_string(pic_state *pic) +{ + char *str; + struct pic_port *port; + int start, end, n, i; + + n = pic_get_args(pic, "z|pii", &str, &port, &start, &end); + switch (n) { + case 1: + port = pic_stdout(pic); + case 2: + start = 0; + case 3: + end = INT_MAX; + } + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-string"); + + for (i = start; i < end && str[i] != '\0'; ++i) { + xfputc(str[i], port->file); + } + return pic_none_value(); +} + +static pic_value +pic_port_write_byte(pic_state *pic) +{ + int i; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "i|p", &i, &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-u8"); + + xfputc(i, port->file); + return pic_none_value(); +} + +static pic_value +pic_port_write_blob(pic_state *pic) +{ + struct pic_blob *blob; + struct pic_port *port; + int start, end, n, i; + + n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end); + switch (n) { + case 1: + port = pic_stdout(pic); + case 2: + start = 0; + case 3: + end = blob->len; + } + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector"); + + for (i = start; i < end; ++i) { + xfputc(blob->data[i], port->file); + } + return pic_none_value(); +} + +static pic_value +pic_port_flush(pic_state *pic) +{ + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_OUT, PIC_PORT_OPEN, "flush-output-port"); + + xfflush(port->file); + return pic_none_value(); +} + +void +pic_init_port(pic_state *pic) +{ + struct pic_port *STDIN, *STDOUT, *STDERR; + + STDIN = port_new_stdport(pic, xstdin, PIC_PORT_IN); + STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT); + STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT); + + pic_deflibrary (pic, "(picrin port)") { + pic_define(pic, "standard-input-port", pic_obj_value(STDIN)); + pic_define(pic, "standard-output-port", pic_obj_value(STDOUT)); + pic_define(pic, "standard-error-port", pic_obj_value(STDERR)); + } + + pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDIN), NULL))); + pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDOUT), NULL))); + pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDERR), NULL))); + + pic_defun(pic, "input-port?", pic_port_input_port_p); + pic_defun(pic, "output-port?", pic_port_output_port_p); + pic_defun(pic, "textual-port?", pic_port_textual_port_p); + pic_defun(pic, "binary-port?", pic_port_binary_port_p); + pic_defun(pic, "port?", pic_port_port_p); + pic_defun(pic, "input-port-open?", pic_port_input_port_open_p); + pic_defun(pic, "output-port-open?", pic_port_output_port_open_p); + pic_defun(pic, "close-port", pic_port_close_port); + pic_defun(pic, "close-input-port", pic_port_close_port); + pic_defun(pic, "close-output-port", pic_port_close_port); + + /* string I/O */ + pic_defun(pic, "open-input-string", pic_port_open_input_string); + pic_defun(pic, "open-output-string", pic_port_open_output_string); + pic_defun(pic, "get-output-string", pic_port_get_output_string); + pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob); + pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector); + pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector); + + /* input */ + pic_defun(pic, "read-char", pic_port_read_char); + pic_defun(pic, "peek-char", pic_port_peek_char); + pic_defun(pic, "read-line", pic_port_read_line); + pic_defun(pic, "eof-object?", pic_port_eof_object_p); + pic_defun(pic, "eof-object", pic_port_eof_object); + pic_defun(pic, "char-ready?", pic_port_char_ready_p); + pic_defun(pic, "read-string", pic_port_read_string); + pic_defun(pic, "read-u8", pic_port_read_byte); + pic_defun(pic, "peek-u8", pic_port_peek_byte); + pic_defun(pic, "u8-ready?", pic_port_byte_ready_p); + pic_defun(pic, "read-bytevector", pic_port_read_blob); + pic_defun(pic, "read-bytevector!", pic_port_read_blob_ip); + + /* output */ + pic_defun(pic, "newline", pic_port_newline); + pic_defun(pic, "write-char", pic_port_write_char); + pic_defun(pic, "write-string", pic_port_write_string); + pic_defun(pic, "write-u8", pic_port_write_byte); + pic_defun(pic, "write-bytevector", pic_port_write_blob); + pic_defun(pic, "flush-output-port", pic_port_flush); +} diff --git a/proc.c b/proc.c new file mode 100644 index 00000000..889a621d --- /dev/null +++ b/proc.c @@ -0,0 +1,183 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/proc.h" +#include "picrin/irep.h" +#include "picrin/dict.h" + +struct pic_proc * +pic_proc_new(pic_state *pic, pic_func_t func, const char *name) +{ + struct pic_proc *proc; + + assert(name != NULL); + + 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->attr = NULL; + return proc; +} + +struct pic_proc * +pic_proc_new_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env) +{ + 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->attr = NULL; + return proc; +} + +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; + } + UNREACHABLE(); +} + +struct pic_dict * +pic_attr(pic_state *pic, struct pic_proc *proc) +{ + if (proc->attr == NULL) { + proc->attr = pic_dict_new(pic); + } + return proc->attr; +} + +pic_value +pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key) +{ + return pic_dict_ref(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key)); +} + +void +pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v) +{ + pic_dict_set(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key), v); +} + +static pic_value +pic_proc_proc_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_proc_p(v)); +} + +static pic_value +pic_proc_apply(pic_state *pic) +{ + struct pic_proc *proc; + pic_value *args; + size_t argc; + pic_value arg_list; + + pic_get_args(pic, "l*", &proc, &argc, &args); + + if (argc == 0) { + pic_error(pic, "apply: wrong number of arguments"); + } + + arg_list = args[--argc]; + while (argc--) { + arg_list = pic_cons(pic, args[argc], arg_list); + } + + return pic_apply_trampoline(pic, proc, arg_list); +} + +static pic_value +pic_proc_map(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc; + pic_value *args; + int i; + pic_value cars, ret; + + pic_get_args(pic, "l*", &proc, &argc, &args); + + ret = pic_nil_value(); + do { + cars = pic_nil_value(); + for (i = argc - 1; i >= 0; --i) { + if (! pic_pair_p(args[i])) { + break; + } + cars = pic_cons(pic, pic_car(pic, args[i]), cars); + args[i] = pic_cdr(pic, args[i]); + } + if (i >= 0) + break; + ret = pic_cons(pic, pic_apply(pic, proc, cars), ret); + } while (1); + + return pic_reverse(pic, ret); +} + +static pic_value +pic_proc_for_each(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc; + pic_value *args; + int i; + pic_value cars; + + pic_get_args(pic, "l*", &proc, &argc, &args); + + do { + cars = pic_nil_value(); + for (i = argc - 1; i >= 0; --i) { + if (! pic_pair_p(args[i])) { + break; + } + cars = pic_cons(pic, pic_car(pic, args[i]), cars); + args[i] = pic_cdr(pic, args[i]); + } + if (i >= 0) + break; + pic_apply(pic, proc, cars); + } while (1); + + return pic_none_value(); +} + +static pic_value +pic_proc_attribute(pic_state *pic) +{ + struct pic_proc *proc; + + pic_get_args(pic, "l", &proc); + + return pic_obj_value(pic_attr(pic, proc)); +} + +void +pic_init_proc(pic_state *pic) +{ + pic_defun(pic, "procedure?", pic_proc_proc_p); + pic_defun(pic, "apply", pic_proc_apply); + pic_defun(pic, "map", pic_proc_map); + pic_defun(pic, "for-each", pic_proc_for_each); + + pic_deflibrary (pic, "(picrin attribute)") { + pic_defun(pic, "attribute", pic_proc_attribute); + } +} diff --git a/read.c b/read.c new file mode 100644 index 00000000..2eb12829 --- /dev/null +++ b/read.c @@ -0,0 +1,976 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include +#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); + +static noreturn void +read_error(pic_state *pic, const char *msg) +{ + pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value()); +} + +static int +skip(struct pic_port *port, int c) +{ + while (isspace(c)) { + c = xfgetc(port->file); + } + return c; +} + +static int +next(struct pic_port *port) +{ + return xfgetc(port->file); +} + +static int +peek(struct pic_port *port) +{ + int c; + + xungetc((c = xfgetc(port->file)), port->file); + + return c; +} + +static bool +expect(struct pic_port *port, const char *str) +{ + int c; + + while ((c = (int)*str++) != 0) { + if (c != peek(port)) + return false; + next(port); + } + + return true; +} + +static bool +isdelim(int c) +{ + return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ +} + +static bool +strcaseeq(const char *s1, const char *s2) +{ + char a, b; + + while ((a = *s1++) * (b = *s2++)) { + if (tolower(a) != tolower(b)) + return false; + } + return a == b; +} + +static pic_value +read_comment(pic_state *pic, struct pic_port *port, const char *str) +{ + int c; + + UNUSED(pic); + UNUSED(str); + + do { + c = next(port); + } while (! (c == EOF || c == '\n')); + + return pic_undef_value(); +} + +static pic_value +read_block_comment(pic_state *pic, struct pic_port *port, const char *str) +{ + int x, y; + int i = 1; + + UNUSED(pic); + UNUSED(str); + + y = next(port); + + while (y != EOF && i > 0) { + x = y; + y = next(port); + if (x == '|' && y == '#') { + i--; + } + if (x == '#' && y == '|') { + i++; + } + } + + return pic_undef_value(); +} + +static pic_value +read_datum_comment(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(str); + + read(pic, port, next(port)); + + return pic_undef_value(); +} + +static pic_value +read_directive(pic_state *pic, struct pic_port *port, const char *str) +{ + switch (peek(port)) { + case 'n': + if (expect(port, "no-fold-case")) { + pic->reader->typecase = PIC_CASE_DEFAULT; + return pic_undef_value(); + } + break; + case 'f': + if (expect(port, "fold-case")) { + pic->reader->typecase = PIC_CASE_FOLD; + return pic_undef_value(); + } + break; + } + + return read_comment(pic, port, str); +} + +static pic_value +read_eval(pic_state *pic, struct pic_port *port, const char *str) +{ + pic_value form; + + 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) +{ + UNUSED(str); + + return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port))); +} + +static pic_value +read_quasiquote(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(str); + + return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port))); +} + +static pic_value +read_unquote(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(str); + + 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) +{ + 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] = tolower(str[i]); + } else { + buf[i] = str[i]; + } + } + + 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] = c; + } + + sym = pic_intern(pic, buf, len); + pic_free(pic, buf); + + return pic_sym_value(sym); +} + +static size_t +read_uinteger(pic_state *pic, struct pic_port *port, int c, char buf[]) +{ + size_t i = 0; + + if (! isdigit(c)) { + read_error(pic, "expected one or more digits"); + } + + buf[i++] = c; + while (isdigit(c = peek(port))) { + buf[i++] = next(port); + } + + buf[i] = '\0'; + + return i; +} + +static size_t +read_suffix(pic_state *pic, struct pic_port *port, char buf[]) +{ + size_t i = 0; + int c; + + c = peek(port); + + if (c != 'e' && c != 'E') { + return i; + } + + buf[i++] = next(port); + + switch ((c = next(port))) { + case '-': + case '+': + buf[i++] = c; + c = next(port); + default: + return i + read_uinteger(pic, port, c, buf + i); + } +} + +static pic_value +read_unsigned(pic_state *pic, struct pic_port *port, int c) +{ + char buf[256]; + size_t i; + + i = read_uinteger(pic, port, c, buf); + + switch (peek(port)) { + case '.': + buf[i++] = next(port); + i += read_uinteger(pic, port, next(port), buf + i); + read_suffix(pic, port, buf + i); + return pic_float_value(atof(buf)); + + default: + read_suffix(pic, port, buf + i); + return pic_int_value((int)atof(buf)); + } +} + +static pic_value +read_number(pic_state *pic, struct pic_port *port, const char *str) +{ + return read_unsigned(pic, port, str[0]); +} + +static pic_value +negate(pic_value n) +{ + if (pic_int_p(n)) { + return pic_int_value(-pic_int(n)); + } else { + return pic_float_value(-pic_float(n)); + } +} + +static pic_value +read_minus(pic_state *pic, struct pic_port *port, const char *str) +{ + pic_value sym; + + if (isdigit(peek(port))) { + 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")) { + return pic_float_value(-INFINITY); + } + if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-nan.0")) { + return pic_float_value(-NAN); + } + return sym; + } +} + +static pic_value +read_plus(pic_state *pic, struct pic_port *port, const char *str) +{ + pic_value sym; + + if (isdigit(peek(port))) { + 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")) { + return pic_float_value(INFINITY); + } + if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+nan.0")) { + return pic_float_value(NAN); + } + return sym; + } +} + +static pic_value +read_true(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(pic); + UNUSED(port); + UNUSED(str); + + return pic_true_value(); +} + +static pic_value +read_false(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(pic); + UNUSED(port); + UNUSED(str); + + return pic_false_value(); +} + +static pic_value +read_char(pic_state *pic, struct pic_port *port, const char *str) +{ + int c; + + UNUSED(str); + + c = next(port); + + if (! isdelim(peek(port))) { + switch (c) { + default: read_error(pic, "unexpected character after char literal"); + case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break; + case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break; + case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break; + case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break; + case 'n': + if ((c = peek(port)) == 'e') { + c = '\n'; + if (! expect(port, "ewline")) + goto fail; + } else { + c = '\0'; + if (! expect(port, "ull")) + goto fail; + } + break; + case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break; + case 's': c = ' '; if (! expect(port, "pace")) goto fail; break; + case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break; + } + } + + return pic_char_value(c); + + fail: + read_error(pic, "unexpected character while reading character literal"); +} + +static pic_value +read_string(pic_state *pic, struct pic_port *port, const char *name) +{ + int c; + char *buf; + size_t size, cnt; + pic_str *str; + + UNUSED(name); + + size = 256; + buf = pic_alloc(pic, size); + cnt = 0; + + /* TODO: intraline whitespaces */ + + while ((c = next(port)) != '"') { + if (c == '\\') { + switch (c = next(port)) { + case 'a': c = '\a'; break; + case 'b': c = '\b'; break; + case 't': c = '\t'; break; + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + } + } + buf[cnt++] = c; + if (cnt >= size) { + buf = pic_realloc(pic, buf, size *= 2); + } + } + buf[cnt] = '\0'; + + str = pic_str_new(pic, buf, cnt); + pic_free(pic, buf); + return pic_obj_value(str); +} + +static pic_value +read_pipe(pic_state *pic, struct pic_port *port, const char *str) +{ + char *buf; + size_t size, cnt; + pic_sym sym; + /* Currently supports only ascii chars */ + char HEX_BUF[3]; + size_t i = 0; + int c; + + UNUSED(str); + + size = 256; + buf = pic_alloc(pic, size); + cnt = 0; + while ((c = next(port)) != '|') { + if (c == '\\') { + switch ((c = next(port))) { + case 'a': c = '\a'; break; + case 'b': c = '\b'; break; + case 't': c = '\t'; break; + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + case 'x': + i = 0; + while ((HEX_BUF[i++] = next(port)) != ';') { + if (i >= sizeof HEX_BUF) + read_error(pic, "expected ';'"); + } + c = strtol(HEX_BUF, NULL, 16); + break; + } + } + buf[cnt++] = c; + if (cnt >= size) { + buf = pic_realloc(pic, buf, size *= 2); + } + } + buf[cnt] = '\0'; + + sym = pic_intern_cstr(pic, buf); + pic_free(pic, buf); + + return pic_sym_value(sym); +} + +static pic_value +read_blob(pic_state *pic, struct pic_port *port, const char *str) +{ + int nbits, n, c; + size_t len, i; + char *dat, buf[256]; + pic_blob *blob; + + UNUSED(str); + + nbits = 0; + + while (isdigit(c = next(port))) { + nbits = 10 * nbits + c - '0'; + } + + if (nbits != 8) { + read_error(pic, "unsupported bytevector bit width"); + } + + if (c != '(') { + read_error(pic, "expected '(' character"); + } + + len = 0; + dat = NULL; + c = next(port); + while ((c = skip(port, c)) != ')') { + read_uinteger(pic, port, c, buf); + n = atoi(buf); + if (n < 0 || (1 << nbits) <= n) { + read_error(pic, "invalid element in bytevector literal"); + } + len += 1; + dat = pic_realloc(pic, dat, len); + dat[len - 1] = n; + c = next(port); + } + + blob = pic_blob_new(pic, len); + for (i = 0; i < len; ++i) { + blob->data[i] = dat[i]; + } + + pic_free(pic, dat); + return pic_obj_value(blob); +} + +static pic_value +read_pair(pic_state *pic, struct pic_port *port, const char *str) +{ + const int tCLOSE = (str[0] == '(') ? ')' : ']'; + pic_value car, cdr; + int c; + + retry: + + c = skip(port, ' '); + + if (c == tCLOSE) { + return pic_nil_value(); + } + if (c == '.' && isdelim(peek(port))) { + cdr = read(pic, port, next(port)); + + closing: + if ((c = skip(port, ' ')) != tCLOSE) { + if (pic_undef_p(read_nullable(pic, port, c))) { + goto closing; + } + read_error(pic, "unmatched parenthesis"); + } + return cdr; + } + else { + car = read_nullable(pic, port, c); + + if (pic_undef_p(car)) { + goto retry; + } + + cdr = read_pair(pic, port, str); + return pic_cons(pic, car, cdr); + } +} + +static pic_value +read_vector(pic_state *pic, struct pic_port *port, const char *str) +{ + pic_value list; + + list = read(pic, port, str[1]); + + return pic_obj_value(pic_vec_new_from_list(pic, list)); +} + +static pic_value +read_label_set(pic_state *pic, struct pic_port *port, int i) +{ + pic_value val; + int c; + + switch ((c = skip(port, ' '))) { + case '(': case '[': + { + pic_value tmp; + + val = pic_cons(pic, pic_none_value(), pic_none_value()); + + xh_put_int(&pic->reader->labels, i, &val); + + tmp = read(pic, port, c); + pic_pair_ptr(val)->car = pic_car(pic, tmp); + pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp); + + return val; + } + case '#': + { + bool vect; + + if (peek(port) == '(') { + vect = true; + } else { + vect = false; + } + + if (vect) { + pic_vec *tmp; + + val = pic_obj_value(pic_vec_new(pic, 0)); + + xh_put_int(&pic->reader->labels, i, &val); + + tmp = pic_vec_ptr(read(pic, port, c)); + SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); + SWAP(size_t, tmp->len, pic_vec_ptr(val)->len); + + return val; + } + + FALLTHROUGH; + } + default: + { + val = read(pic, port, c); + + xh_put_int(&pic->reader->labels, i, &val); + + return val; + } + } +} + +static pic_value +read_label_ref(pic_state *pic, struct pic_port *port, int i) +{ + xh_entry *e; + + UNUSED(port); + + e = xh_get_int(&pic->reader->labels, i); + if (! e) { + read_error(pic, "label of given index not defined"); + } + return xh_val(e, pic_value); +} + +static pic_value +read_label(pic_state *pic, struct pic_port *port, const char *str) +{ + int i, c; + + i = 0; + c = str[1]; /* initial index letter */ + do { + i = i * 10 + c; + } while (isdigit(c = next(port))); + + if (c == '=') { + return read_label_set(pic, port, i); + } + if (c == '#') { + return read_label_ref(pic, port, i); + } + read_error(pic, "broken label expression"); +} + +static pic_value +read_unmatch(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(port); + UNUSED(str); + + read_error(pic, "unmatched parenthesis"); +} + +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) { + read_error(pic, "invalid character at the seeker head"); + } + + buf[i++] = c; + + while (i < sizeof buf) { + trie = trie->table[c]; + + if ((c = peek(port)) == EOF) { + break; + } + if (trie->table[c] == NULL) { + break; + } + buf[i++] = 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_str_new(pic, buf, i); + return pic_apply2(pic, trie->proc, pic_obj_value(port), pic_obj_value(str)); +} + +static pic_value +read(pic_state *pic, struct pic_port *port, int c) +{ + pic_value val; + + retry: + val = read_nullable(pic, port, c); + + if (pic_undef_p(val)) { + c = next(port); + goto retry; + } + + return val; +} + +struct pic_trie * +pic_trie_new(pic_state *pic) +{ + 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_trie_new(pic); + } + trie = trie->table[c]; + } + trie->proc = pic_proc_new(pic, reader, "reader"); +} + +#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); \ + } + +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); + + /* read number */ + for (buf[0] = '0'; buf[0] <= '9'; ++buf[0]) { + pic_define_reader(pic, buf, pic_read_number); + } + + /* read symbol */ + for (buf[0] = 'a'; buf[0] <= 'z'; ++buf[0]) { + pic_define_reader(pic, buf, pic_read_symbol); + } + 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); + } + + /* read label */ + buf[0] = '#'; + for (buf[1] = '0'; buf[1] <= '9'; ++buf[1]) { + pic_define_reader(pic, buf, pic_read_label); + } +} + +pic_value +pic_read(pic_state *pic, struct pic_port *port) +{ + pic_value val; + int c = next(port); + + retry: + c = skip(port, c); + + if (c == EOF) { + return pic_eof_object(); + } + + val = read_nullable(pic, port, c); + + if (pic_undef_p(val)) { + c = next(port); + goto retry; + } + + return val; +} + +pic_value +pic_read_cstr(pic_state *pic, const char *str) +{ + struct pic_port *port; + + port = pic_open_input_string(pic, str); + + return pic_read(pic, port); +} + +static pic_value +pic_parse(pic_state *pic, struct pic_port *port) +{ + pic_value val, acc; + + pic_try { + acc = pic_nil_value(); + while (! pic_eof_p(val = pic_read(pic, port))) { + pic_push(pic, val, acc); + } + } + pic_catch { + return pic_undef_value(); + } + + return pic_reverse(pic, acc); +} + +pic_list +pic_parse_file(pic_state *pic, FILE *file) +{ + struct pic_port *port; + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); + port->file = xfpopen(file); + port->flags = PIC_PORT_OUT | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + + return pic_parse(pic, port); +} + +pic_list +pic_parse_cstr(pic_state *pic, const char *str) +{ + struct pic_port *port; + + port = pic_open_input_string(pic, str); + + return pic_parse(pic, port); +} + +static pic_value +pic_read_read(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + return pic_read(pic, port); +} + +void +pic_init_read(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme read)") { + pic_defun(pic, "read", pic_read_read); + } +} diff --git a/record.c b/record.c new file mode 100644 index 00000000..d62776ca --- /dev/null +++ b/record.c @@ -0,0 +1,115 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/record.h" + +struct pic_record * +pic_record_new(pic_state *pic, pic_value rectype) +{ + struct pic_record *rec; + + rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD); + xh_init_int(&rec->hash, sizeof(pic_value)); + + pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype); + + return rec; +} + +pic_value +pic_record_type(pic_state *pic, struct pic_record *rec) +{ + return pic_record_ref(pic, rec, pic_intern_cstr(pic, "@@type")); +} + +pic_value +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); + } + return xh_val(e, pic_value); +} + +void +pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym slot, pic_value val) +{ + UNUSED(pic); + + xh_put_int(&rec->hash, slot, &val); +} + +static pic_value +pic_record_make_record(pic_state *pic) +{ + struct pic_record * rec; + pic_value rectype; + + pic_get_args(pic, "o", &rectype); + + rec = pic_record_new(pic, rectype); + + return pic_obj_value(rec); +} + +static pic_value +pic_record_record_p(pic_state *pic) +{ + pic_value rec; + + pic_get_args(pic, "o", &rec); + + return pic_bool_value(pic_record_p(rec)); +} + +static pic_value +pic_record_record_type(pic_state *pic) +{ + struct pic_record *rec; + + pic_get_args(pic, "r", &rec); + + return pic_record_type(pic, rec); +} + +static pic_value +pic_record_record_ref(pic_state *pic) +{ + struct pic_record *rec; + pic_sym slot; + + pic_get_args(pic, "rm", &rec, &slot); + + return pic_record_ref(pic, rec, slot); +} + +static pic_value +pic_record_record_set(pic_state *pic) +{ + struct pic_record *rec; + 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(); +} + +void +pic_init_record(pic_state *pic) +{ + pic_deflibrary (pic, "(picrin record)") { + pic_defun(pic, "make-record", pic_record_make_record); + pic_defun(pic, "record?", pic_record_record_p); + pic_defun(pic, "record-type", pic_record_record_type); + pic_defun(pic, "record-ref", pic_record_record_ref); + pic_defun(pic, "record-set!", pic_record_record_set); + } +} diff --git a/state.c b/state.c new file mode 100644 index 00000000..d9427f3d --- /dev/null +++ b/state.c @@ -0,0 +1,205 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#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/error.h" + +void pic_init_core(pic_state *); + +pic_state * +pic_open(int argc, char *argv[], char **envp) +{ + char t; + + pic_state *pic; + size_t ai; + + pic = malloc(sizeof(pic_state)); + + /* root block */ + pic->blk = NULL; + + /* command line */ + pic->argc = argc; + pic->argv = argv; + pic->envp = envp; + + /* prepare VM stack */ + pic->stbase = pic->sp = calloc(PIC_STACK_SIZE, sizeof(pic_value)); + pic->stend = pic->stbase + PIC_STACK_SIZE; + + /* callinfo */ + pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo)); + pic->ciend = pic->cibase + PIC_STACK_SIZE; + + /* memory heap */ + pic->heap = pic_heap_open(); + + /* 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; + + /* global variables */ + xh_init_int(&pic->globals, sizeof(pic_value)); + + /* macros */ + xh_init_int(&pic->macros, sizeof(struct pic_macro *)); + + /* libraries */ + 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_trie_new(pic); + xh_init_int(&pic->reader->labels, sizeof(pic_value)); + + /* error handling */ + pic->jmp = NULL; + pic->err = NULL; + pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf)); + pic->try_jmp_idx = 0; + pic->try_jmp_size = PIC_RESCUE_SIZE; + + /* GC arena */ + pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **)); + pic->arena_size = PIC_ARENA_SIZE; + pic->arena_idx = 0; + + /* native stack marker */ + pic->native_stack_start = &t; + +#define register_core_symbol(pic,slot,name) do { \ + pic->slot = pic_intern_cstr(pic, name); \ + } while (0) + + ai = pic_gc_arena_preserve(pic); + register_core_symbol(pic, sDEFINE, "define"); + register_core_symbol(pic, sLAMBDA, "lambda"); + register_core_symbol(pic, sIF, "if"); + register_core_symbol(pic, sBEGIN, "begin"); + register_core_symbol(pic, sSETBANG, "set!"); + register_core_symbol(pic, sQUOTE, "quote"); + register_core_symbol(pic, sQUASIQUOTE, "quasiquote"); + register_core_symbol(pic, sUNQUOTE, "unquote"); + register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing"); + register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax"); + register_core_symbol(pic, sIMPORT, "import"); + register_core_symbol(pic, sEXPORT, "export"); + register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); + register_core_symbol(pic, sIN_LIBRARY, "in-library"); + register_core_symbol(pic, sCONS, "cons"); + register_core_symbol(pic, sCAR, "car"); + register_core_symbol(pic, sCDR, "cdr"); + register_core_symbol(pic, sNILP, "null?"); + register_core_symbol(pic, sADD, "+"); + register_core_symbol(pic, sSUB, "-"); + register_core_symbol(pic, sMUL, "*"); + register_core_symbol(pic, sDIV, "/"); + register_core_symbol(pic, sMINUS, "minus"); + register_core_symbol(pic, sEQ, "="); + register_core_symbol(pic, sLT, "<"); + register_core_symbol(pic, sLE, "<="); + register_core_symbol(pic, sGT, ">"); + register_core_symbol(pic, sGE, ">="); + register_core_symbol(pic, sNOT, "not"); + pic_gc_arena_restore(pic, ai); + +#define register_renamed_symbol(pic,slot,name) do { \ + pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); \ + } while (0) + + ai = pic_gc_arena_preserve(pic); + register_renamed_symbol(pic, rDEFINE, "define"); + register_renamed_symbol(pic, rLAMBDA, "lambda"); + register_renamed_symbol(pic, rIF, "if"); + register_renamed_symbol(pic, rBEGIN, "begin"); + register_renamed_symbol(pic, rSETBANG, "set!"); + register_renamed_symbol(pic, rQUOTE, "quote"); + register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax"); + register_renamed_symbol(pic, rIMPORT, "import"); + register_renamed_symbol(pic, rEXPORT, "export"); + register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); + register_renamed_symbol(pic, rIN_LIBRARY, "in-library"); + pic_gc_arena_restore(pic, ai); + + /* root block */ + pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK); + pic->blk->prev = NULL; + pic->blk->depth = 0; + pic->blk->in = pic->blk->out = NULL; + + pic_init_core(pic); + + /* set library */ + pic_make_library(pic, pic_read_cstr(pic, "(picrin user)")); + pic_in_library(pic, pic_read_cstr(pic, "(picrin user)")); + + return pic; +} + +void +pic_close(pic_state *pic) +{ + xh_iter it; + + /* invoke exit handlers */ + while (pic->blk) { + if (pic->blk->out) { + pic_apply0(pic, pic->blk->out); + } + pic->blk = pic->blk->prev; + } + + /* clear out root objects */ + pic->sp = pic->stbase; + pic->ci = pic->cibase; + pic->arena_idx = 0; + pic->err = NULL; + xh_clear(&pic->macros); + pic->libs = pic_nil_value(); + + /* free all heap objects */ + pic_gc_run(pic); + + /* free heaps */ + pic_heap_close(pic->heap); + + /* free runtime context */ + free(pic->stbase); + free(pic->cibase); + + /* free reader struct */ + xh_destroy(&pic->reader->labels); + pic_trie_delete(pic, pic->reader->trie); + free(pic->reader); + + /* free global stacks */ + free(pic->try_jmps); + xh_destroy(&pic->syms); + xh_destroy(&pic->globals); + xh_destroy(&pic->macros); + + /* free GC arena */ + free(pic->arena); + + /* free symbol names */ + xh_begin(&it, &pic->sym_names); + while (xh_next(&it)) { + free(xh_val(it.e, char *)); + } + xh_destroy(&pic->sym_names); + + free(pic); +} diff --git a/string.c b/string.c new file mode 100644 index 00000000..ab679f50 --- /dev/null +++ b/string.c @@ -0,0 +1,424 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/string.h" +#include "picrin/pair.h" +#include "picrin/port.h" + +static pic_str * +str_new_rope(pic_state *pic, xrope *rope) +{ + pic_str *str; + + str = (pic_str *)pic_obj_alloc(pic, sizeof(pic_str), PIC_TT_STRING); + str->rope = rope; /* delegate ownership */ + return str; +} + +pic_str * +pic_str_new(pic_state *pic, const char *imbed, size_t len) +{ + if (imbed == NULL && len > 0) { + pic_errorf(pic, "zero length specified against NULL ptr"); + } + return str_new_rope(pic, xr_new_copy(imbed, len)); +} + +pic_str * +pic_str_new_cstr(pic_state *pic, const char *cstr) +{ + return pic_str_new(pic, cstr, strlen(cstr)); +} + +pic_str * +pic_str_new_fill(pic_state *pic, size_t len, char fill) +{ + size_t i; + char *cstr; + pic_str *str; + + cstr = (char *)pic_alloc(pic, len + 1); + cstr[len] = '\0'; + for (i = 0; i < len; ++i) { + cstr[i] = fill; + } + + str = pic_str_new(pic, cstr, len); + + pic_free(pic, cstr); + return str; +} + +size_t +pic_strlen(pic_str *str) +{ + return xr_len(str->rope); +} + +char +pic_str_ref(pic_state *pic, pic_str *str, size_t i) +{ + int c; + + c = xr_at(str->rope, i); + if (c == -1) { + pic_errorf(pic, "index out of range %d", i); + } + return (char)c; +} + +static xrope * +xr_put(xrope *rope, size_t i, char c) +{ + xrope *x, *y, *z; + char buf[2]; + + if (xr_len(rope) <= i) { + return NULL; + } + + buf[0] = c; + buf[1] = '\0'; + + x = xr_sub(rope, 0, i); + y = xr_new_copy(buf, 1); + z = xr_cat(x, y); + XROPE_DECREF(x); + XROPE_DECREF(y); + + x = z; + y = xr_sub(rope, i + 1, xr_len(rope)); + z = xr_cat(z, y); + XROPE_DECREF(x); + XROPE_DECREF(y); + + return z; +} + +void +pic_str_set(pic_state *pic, pic_str *str, size_t i, char c) +{ + xrope *x; + + x = xr_put(str->rope, i, c); + if (x == NULL) { + pic_errorf(pic, "index out of range %d", i); + } + XROPE_DECREF(str->rope); + str->rope = x; +} + +pic_str * +pic_strcat(pic_state *pic, pic_str *a, pic_str *b) +{ + return str_new_rope(pic, xr_cat(a->rope, b->rope)); +} + +pic_str * +pic_substr(pic_state *pic, pic_str *str, size_t s, size_t e) +{ + return str_new_rope(pic, xr_sub(str->rope, s, e)); +} + +int +pic_strcmp(pic_str *str1, pic_str *str2) +{ + return strcmp(xr_cstr(str1->rope), xr_cstr(str2->rope)); +} + +const char * +pic_str_cstr(pic_str *str) +{ + return xr_cstr(str->rope); +} + +pic_value +pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) +{ + char c; + pic_value irrs = pic_nil_value(); + + while ((c = *fmt++)) { + switch (c) { + default: + xfputc(c, file); + break; + case '%': + c = *fmt++; + if (! c) + goto exit; + switch (c) { + default: + xfputc(c, file); + break; + case '%': + xfputc('%', file); + break; + case 'c': + xfprintf(file, "%c", va_arg(ap, int)); + break; + case 's': + xfprintf(file, "%s", va_arg(ap, const char *)); + break; + case 'd': + xfprintf(file, "%d", va_arg(ap, int)); + break; + case 'p': + xfprintf(file, "%p", va_arg(ap, void *)); + break; + case 'f': + xfprintf(file, "%f", va_arg(ap, double)); + break; + } + break; + case '~': + c = *fmt++; + if (! c) + goto exit; + switch (c) { + default: + xfputc(c, file); + break; + case '~': + xfputc('~', file); + break; + case '%': + xfputc('\n', file); + break; + case 'a': + irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs); + break; + case 's': + irrs = pic_cons(pic, pic_fwrite(pic, va_arg(ap, pic_value), file), irrs); + break; + } + break; + } + } + exit: + + return pic_reverse(pic, irrs); +} + +pic_value +pic_vformat(pic_state *pic, const char *fmt, va_list ap) +{ + struct pic_port *port; + pic_value irrs; + + port = pic_open_output_string(pic); + + irrs = pic_vfformat(pic, port->file, fmt, ap); + irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs); + + pic_close_port(pic, port); + return irrs; +} + +pic_value +pic_format(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_value objs; + + va_start(ap, fmt); + objs = pic_vformat(pic, fmt, ap); + va_end(ap); + + return objs; +} + +static pic_value +pic_str_string_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_str_p(v)); +} + +static pic_value +pic_str_make_string(pic_state *pic) +{ + int len; + char c = ' '; + + pic_get_args(pic, "i|c", &len, &c); + + return pic_obj_value(pic_str_new_fill(pic, len, c)); +} + +static pic_value +pic_str_string_length(pic_state *pic) +{ + pic_str *str; + + pic_get_args(pic, "s", &str); + + return pic_int_value(pic_strlen(str)); +} + +static pic_value +pic_str_string_ref(pic_state *pic) +{ + pic_str *str; + int k; + + pic_get_args(pic, "si", &str, &k); + + return pic_char_value(pic_str_ref(pic, str, k)); +} + +static pic_value +pic_str_string_set(pic_state *pic) +{ + pic_str *str; + char c; + int k; + + pic_get_args(pic, "sic", &str, &k, &c); + + pic_str_set(pic, str, k, c); + return pic_none_value(); +} + +#define DEFINE_STRING_CMP(name, op) \ + static pic_value \ + pic_str_string_##name(pic_state *pic) \ + { \ + size_t argc; \ + pic_value *argv; \ + size_t i; \ + \ + pic_get_args(pic, "*", &argc, &argv); \ + \ + if (argc < 1 || ! pic_str_p(argv[0])) { \ + return pic_false_value(); \ + } \ + \ + for (i = 1; i < argc; ++i) { \ + 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)) { \ + return pic_false_value(); \ + } \ + } \ + return pic_true_value(); \ + } + +DEFINE_STRING_CMP(eq, ==) +DEFINE_STRING_CMP(lt, <) +DEFINE_STRING_CMP(gt, >) +DEFINE_STRING_CMP(le, <=) +DEFINE_STRING_CMP(ge, >=) + +static pic_value +pic_str_string_copy(pic_state *pic) +{ + pic_str *str; + int n, start, end; + + n = pic_get_args(pic, "s|ii", &str, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = pic_strlen(str); + } + + return pic_obj_value(pic_substr(pic, str, start, end)); +} + +static pic_value +pic_str_string_copy_ip(pic_state *pic) +{ + pic_str *to, *from; + int n, at, start, end; + + n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end); + + switch (n) { + case 3: + start = 0; + case 4: + end = pic_strlen(from); + } + if (to == from) { + from = pic_substr(pic, from, 0, end); + } + + while (start < end) { + pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++)); + } + return pic_none_value(); +} + +static pic_value +pic_str_string_append(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + pic_str *str; + + pic_get_args(pic, "*", &argc, &argv); + + str = pic_str_new(pic, NULL, 0); + for (i = 0; i < argc; ++i) { + if (! pic_str_p(argv[i])) { + pic_error(pic, "type error"); + } + str = pic_strcat(pic, str, pic_str_ptr(argv[i])); + } + return pic_obj_value(str); +} + +static pic_value +pic_str_string_fill_ip(pic_state *pic) +{ + pic_str *str; + char c; + int n, start, end; + + n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end); + + switch (n) { + case 2: + start = 0; + case 3: + end = pic_strlen(str); + } + + while (start < end) { + pic_str_set(pic, str, start++, c); + } + return pic_none_value(); +} + +void +pic_init_str(pic_state *pic) +{ + pic_defun(pic, "string?", pic_str_string_p); + pic_defun(pic, "make-string", pic_str_make_string); + pic_defun(pic, "string-length", pic_str_string_length); + pic_defun(pic, "string-ref", pic_str_string_ref); + pic_defun(pic, "string-set!", pic_str_string_set); + + pic_defun(pic, "string=?", pic_str_string_eq); + pic_defun(pic, "string?", pic_str_string_gt); + pic_defun(pic, "string<=?", pic_str_string_le); + pic_defun(pic, "string>=?", pic_str_string_ge); + + pic_defun(pic, "string-copy", pic_str_string_copy); + pic_defun(pic, "string-copy!", pic_str_string_copy_ip); + pic_defun(pic, "string-append", pic_str_string_append); + pic_defun(pic, "string-fill!", pic_str_string_fill_ip); + pic_defun(pic, "substring", pic_str_string_copy); +} diff --git a/symbol.c b/symbol.c new file mode 100644 index 00000000..2add0769 --- /dev/null +++ b/symbol.c @@ -0,0 +1,161 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/string.h" + +pic_sym +pic_intern(pic_state *pic, const char *str, size_t len) +{ + char *cstr; + xh_entry *e; + pic_sym id; + + 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; +} + +pic_sym +pic_intern_cstr(pic_state *pic, const char *str) +{ + return pic_intern(pic, str, strlen(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, 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_abort(pic, "logic flaw"); + } + return pic_intern(pic, name, occr - name); +} + +bool +pic_interned_p(pic_state *pic, pic_sym sym) +{ + return sym == pic_intern_cstr(pic, pic_symbol_name(pic, sym)); +} + +const char * +pic_symbol_name(pic_state *pic, pic_sym sym) +{ + return xh_val(xh_get_int(&pic->sym_names, sym), const char *); +} + +static pic_value +pic_symbol_symbol_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_sym_p(v)); +} + +static pic_value +pic_symbol_symbol_eq_p(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! pic_sym_p(argv[i])) { + return pic_false_value(); + } + if (! pic_eq_p(argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); +} + +static pic_value +pic_symbol_symbol_to_string(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (! pic_sym_p(v)) { + pic_error(pic, "symbol->string: expected symbol"); + } + + return pic_obj_value(pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(v)))); +} + +static pic_value +pic_symbol_string_to_symbol(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (! pic_str_p(v)) { + pic_error(pic, "string->symbol: expected string"); + } + + return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v)))); +} + +void +pic_init_symbol(pic_state *pic) +{ + pic_deflibrary (pic, "(picrin base symbol)") { + pic_defun(pic, "symbol?", pic_symbol_symbol_p); + pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); + pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); + } + + pic_deflibrary (pic, "(picrin symbol)") { + pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p); + } +} diff --git a/system.c b/system.c new file mode 100644 index 00000000..20203d27 --- /dev/null +++ b/system.c @@ -0,0 +1,136 @@ +/** + * See Copyright Notice in picrin.h + */ + +#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) +{ + pic_value v = pic_nil_value(); + int i; + + pic_get_args(pic, ""); + + for (i = 0; i < pic->argc; ++i) { + size_t ai = pic_gc_arena_preserve(pic); + + v = pic_cons(pic, pic_obj_value(pic_str_new_cstr(pic, pic->argv[i])), v); + pic_gc_arena_restore(pic, ai); + } + + return pic_reverse(pic, v); +} + +static pic_value +pic_system_exit(pic_state *pic) +{ + pic_value v; + int argc, status = EXIT_SUCCESS; + + argc = pic_get_args(pic, "|o", &v); + if (argc == 1) { + switch (pic_type(v)) { + case PIC_TT_FLOAT: + status = (int)pic_float(v); + break; + case PIC_TT_INT: + status = pic_int(v); + break; + default: + break; + } + } + + pic_close(pic); + + exit(status); +} + +static pic_value +pic_system_emergency_exit(pic_state *pic) +{ + pic_value v; + int argc, status = EXIT_FAILURE; + + argc = pic_get_args(pic, "|o", &v); + if (argc == 1) { + switch (pic_type(v)) { + case PIC_TT_FLOAT: + status = (int)pic_float(v); + break; + case PIC_TT_INT: + status = pic_int(v); + break; + default: + break; + } + } + + _Exit(status); +} + +static pic_value +pic_system_getenv(pic_state *pic) +{ + char *str, *val; + + pic_get_args(pic, "z", &str); + + val = getenv(str); + + if (val == NULL) + return pic_nil_value(); + else + return pic_obj_value(pic_str_new_cstr(pic, val)); +} + +static pic_value +pic_system_getenvs(pic_state *pic) +{ + char **envp; + pic_value data = pic_nil_value(); + size_t ai = pic_gc_arena_preserve(pic); + + pic_get_args(pic, ""); + + if (! pic->envp) { + return pic_nil_value(); + } + + for (envp = pic->envp; *envp; ++envp) { + pic_str *key, *val; + int i; + + for (i = 0; (*envp)[i] != '='; ++i) + ; + + key = pic_str_new(pic, *envp, i); + val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key))); + + /* push */ + data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, data); + } + + return data; +} + +void +pic_init_system(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme process-context)") { + pic_defun(pic, "command-line", pic_system_cmdline); + pic_defun(pic, "exit", pic_system_exit); + pic_defun(pic, "emergency-exit", pic_system_emergency_exit); + pic_defun(pic, "get-environment-variable", pic_system_getenv); + pic_defun(pic, "get-environment-variables", pic_system_getenvs); + } +} diff --git a/time.c b/time.c new file mode 100644 index 00000000..8e42dc8e --- /dev/null +++ b/time.c @@ -0,0 +1,49 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" + +#define UTC_TAI_DIFF 35 + +static pic_value +pic_current_second(pic_state *pic) +{ + time_t t; + + pic_get_args(pic, ""); + + time(&t); + return pic_float_value((double)t + UTC_TAI_DIFF); +} + +static pic_value +pic_current_jiffy(pic_state *pic) +{ + clock_t c; + + pic_get_args(pic, ""); + + c = clock(); + return pic_int_value(c); +} + +static pic_value +pic_jiffies_per_second(pic_state *pic) +{ + pic_get_args(pic, ""); + + return pic_int_value(CLOCKS_PER_SEC); +} + +void +pic_init_time(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme time)") { + pic_defun(pic, "current-second", pic_current_second); + pic_defun(pic, "current-jiffy", pic_current_jiffy); + pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); + } +} diff --git a/var.c b/var.c new file mode 100644 index 00000000..a5836797 --- /dev/null +++ b/var.c @@ -0,0 +1,134 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/var.h" +#include "picrin/pair.h" + +struct pic_var * +pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv) +{ + struct pic_var *var; + + var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR); + var->stack = pic_nil_value(); + var->conv = conv; + + pic_var_push(pic, var, init); + + return var; +} + +pic_value +pic_var_ref(pic_state *pic, struct pic_var *var) +{ + return pic_car(pic, var->stack); +} + +void +pic_var_set(pic_state *pic, struct pic_var *var, pic_value value) +{ + if (var->conv != NULL) { + value = pic_apply1(pic, var->conv, value); + } + pic_set_car(pic, var->stack, value); +} + +void +pic_var_push(pic_state *pic, struct pic_var *var, pic_value value) +{ + if (var->conv != NULL) { + value = pic_apply1(pic, var->conv, value); + } + var->stack = pic_cons(pic, value, var->stack); +} + +void +pic_var_pop(pic_state *pic, struct pic_var *var) +{ + var->stack = pic_cdr(pic, var->stack); +} + +static pic_value +pic_var_make_parameter(pic_state *pic) +{ + struct pic_proc *conv = NULL; + pic_value init; + + pic_get_args(pic, "o|l", &init, &conv); + + return pic_obj_value(pic_var_new(pic, init, conv)); +} + +static pic_value +pic_var_parameter_ref(pic_state *pic) +{ + struct pic_var *var; + pic_value v; + + pic_get_args(pic, "o", &v); + + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + + return pic_var_ref(pic, var); +} + +static pic_value +pic_var_parameter_set(pic_state *pic) +{ + struct pic_var *var; + pic_value v, val; + + pic_get_args(pic, "oo", &v, &val); + + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + pic_var_set(pic, var, val); + return pic_none_value(); +} + +static pic_value +pic_var_parameter_push(pic_state *pic) +{ + struct pic_var *var; + pic_value v, val; + + pic_get_args(pic, "oo", &v, &val); + + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + pic_var_push(pic, var, val); + return pic_none_value(); +} + +static pic_value +pic_var_parameter_pop(pic_state *pic) +{ + struct pic_var *var; + pic_value v; + + pic_get_args(pic, "o", &v); + + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + pic_var_pop(pic, var); + return pic_none_value(); +} + +void +pic_init_var(pic_state *pic) +{ + pic_deflibrary (pic, "(picrin parameter)") { + pic_defun(pic, "make-parameter", pic_var_make_parameter); + pic_defun(pic, "parameter-ref", pic_var_parameter_ref); + pic_defun(pic, "parameter-set!", pic_var_parameter_set); + pic_defun(pic, "parameter-push!", pic_var_parameter_push); + pic_defun(pic, "parameter-pop!", pic_var_parameter_pop); + } +} diff --git a/vector.c b/vector.c new file mode 100644 index 00000000..d57214e7 --- /dev/null +++ b/vector.c @@ -0,0 +1,283 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/vector.h" +#include "picrin/pair.h" + +struct pic_vector * +pic_vec_new(pic_state *pic, size_t len) +{ + struct pic_vector *vec; + size_t i; + + 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); + for (i = 0; i < len; ++i) { + vec->data[i] = pic_none_value(); + } + return vec; +} + +struct pic_vector * +pic_vec_new_from_list(pic_state *pic, pic_value data) +{ + struct pic_vector *vec; + size_t i, len; + + len = pic_length(pic, data); + + vec = pic_vec_new(pic, len); + for (i = 0; i < len; ++i) { + vec->data[i] = pic_car(pic, data); + data = pic_cdr(pic, data); + } + return vec; +} + +void +pic_vec_extend_ip(pic_state *pic, struct pic_vector *vec, size_t size) +{ + size_t len, i; + + len = vec->len; + vec->len = size; + vec->data = (pic_value *)pic_realloc(pic, vec->data, sizeof(pic_value) * size); + for (i = len; i < size; ++i) { + vec->data[i] = pic_none_value(); + } +} + +static pic_value +pic_vec_vector_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_vec_p(v)); +} + +static pic_value +pic_vec_make_vector(pic_state *pic) +{ + pic_value v; + int n, k; + size_t i; + struct pic_vector *vec; + + n = pic_get_args(pic, "i|o", &k, &v); + + vec = pic_vec_new(pic, k); + if (n == 2) { + for (i = 0; i < (size_t)k; ++i) { + vec->data[i] = v; + } + } + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_length(pic_state *pic) +{ + struct pic_vector *v; + + pic_get_args(pic, "v", &v); + + return pic_int_value(v->len); +} + +static pic_value +pic_vec_vector_ref(pic_state *pic) +{ + struct pic_vector *v; + int k; + + pic_get_args(pic, "vi", &v, &k); + + if (k < 0 || v->len <= (size_t)k) { + pic_error(pic, "vector-ref: index out of range"); + } + return v->data[k]; +} + +static pic_value +pic_vec_vector_set(pic_state *pic) +{ + struct pic_vector *v; + int k; + pic_value o; + + pic_get_args(pic, "vio", &v, &k, &o); + + if (k < 0 || v->len <= (size_t)k) { + pic_error(pic, "vector-set!: index out of range"); + } + v->data[k] = o; + return pic_none_value(); +} + +static pic_value +pic_vec_vector_copy_i(pic_state *pic) +{ + pic_vec *to, *from; + int n, at, start, end; + + n = pic_get_args(pic, "viv|ii", &to, &at, &from, &start, &end); + + switch (n) { + case 3: + start = 0; + case 4: + end = from->len; + } + + if (to == from && (start <= at && at < end)) { + /* copy in reversed order */ + at += end - start; + while (start < end) { + to->data[--at] = from->data[--end]; + } + return pic_none_value(); + } + + while (start < end) { + to->data[at++] = from->data[start++]; + } + + return pic_none_value(); +} + +static pic_value +pic_vec_vector_copy(pic_state *pic) +{ + pic_vec *vec, *to; + int n, start, end, i = 0; + + n = pic_get_args(pic, "v|ii", &vec, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = vec->len; + } + + to = pic_vec_new(pic, end - start); + while (start < end) { + to->data[i++] = vec->data[start++]; + } + + return pic_obj_value(to); +} + +static pic_value +pic_vec_vector_append(pic_state *pic) +{ + size_t argc, i, j, len; + pic_value *argv; + pic_vec *vec; + + pic_get_args(pic, "*", &argc, &argv); + + len = 0; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], vec); + len += pic_vec_ptr(argv[i])->len; + } + + vec = pic_vec_new(pic, len); + + len = 0; + for (i = 0; i < argc; ++i) { + for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) { + vec->data[len + j] = pic_vec_ptr(argv[i])->data[j]; + } + len += pic_vec_ptr(argv[i])->len; + } + + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_fill_i(pic_state *pic) +{ + pic_vec *vec; + pic_value obj; + int n, start, end; + + n = pic_get_args(pic, "vo|ii", &vec, &obj, &start, &end); + + switch (n) { + case 2: + start = 0; + case 3: + end = vec->len; + } + + while (start < end) { + vec->data[start++] = obj; + } + + return pic_none_value(); +} + +static pic_value +pic_vec_list_to_vector(pic_state *pic) +{ + struct pic_vector *vec; + pic_value list, e, *data; + + pic_get_args(pic, "o", &list); + + vec = pic_vec_new(pic, pic_length(pic, list)); + + data = vec->data; + + pic_for_each (e, list) { + *data++ = e; + } + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_to_list(pic_state *pic) +{ + struct pic_vector *vec; + pic_value list; + int n, start, end, i; + + n = pic_get_args(pic, "v|ii", &vec, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = vec->len; + } + + list = pic_nil_value(); + + for (i = start; i < end; ++i) { + pic_push(pic, vec->data[i], list); + } + return pic_reverse(pic, list); +} + +void +pic_init_vector(pic_state *pic) +{ + pic_defun(pic, "vector?", pic_vec_vector_p); + pic_defun(pic, "make-vector", pic_vec_make_vector); + pic_defun(pic, "vector-length", pic_vec_vector_length); + pic_defun(pic, "vector-ref", pic_vec_vector_ref); + pic_defun(pic, "vector-set!", pic_vec_vector_set); + pic_defun(pic, "vector-copy!", pic_vec_vector_copy_i); + pic_defun(pic, "vector-copy", pic_vec_vector_copy); + pic_defun(pic, "vector-append", pic_vec_vector_append); + pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i); + pic_defun(pic, "list->vector", pic_vec_list_to_vector); + pic_defun(pic, "vector->list", pic_vec_vector_to_list); +} diff --git a/vm.c b/vm.c new file mode 100644 index 00000000..99f12f82 --- /dev/null +++ b/vm.c @@ -0,0 +1,1057 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include +#include + +#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/var.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)]) + +struct pic_proc * +pic_get_proc(pic_state *pic) +{ + pic_value v = GET_OPERAND(pic,0); + + if (! pic_proc_p(v)) { + pic_error(pic, "fatal error"); + } + return pic_proc_ptr(v); +} + +/** + * char type + * ---- ---- + * o object + * i int + * I int with exactness + * f float + * F float with exactness + * s string object + * z c string + * m symbol + * v vector object + * b bytevector object + * c char + * l lambda object + * p port object + * d dictionary object + * e error object + * + * | optional operator + * * variable length operator + */ + +int +pic_get_args(pic_state *pic, const char *format, ...) +{ + char c; + int i = 1, argc = pic->ci->argc; + va_list ap; + bool opt = false; + + va_start(ap, format); + while ((c = *format++)) { + switch (c) { + default: + if (argc <= i && ! opt) { + pic_error(pic, "wrong number of arguments"); + } + break; + case '|': + break; + case '*': + break; + } + + /* 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 '|': + opt = true; + break; + case 'o': { + pic_value *p; + + p = va_arg(ap, pic_value*); + if (i < argc) { + *p = GET_OPERAND(pic,i); + i++; + } + break; + } + case 'f': { + double *f; + + 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++; + } + break; + } + case 'F': { + double *f; + bool *e; + + 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++; + } + break; + } + case 'I': { + int *k; + bool *e; + + 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++; + } + break; + } + case 'i': { + int *k; + + 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++; + } + break; + } + case 's': { + pic_str **str; + 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++; + } + break; + } + case 'z': { + const char **cstr; + 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++; + } + break; + } + case '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++; + } + break; + } + case 'v': { + struct pic_vector **vec; + 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++; + } + break; + } + case 'b': { + struct pic_blob **b; + 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++; + } + break; + } + case 'c': { + char *c; + pic_value v; + + c = va_arg(ap, char *); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_char_p(v)) { + *c = pic_char(v); + } + else { + pic_errorf(pic, "pic_get_args: expected char, but got ~s", v); + } + i++; + } + break; + } + case 'l': { + struct pic_proc **l; + 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++; + } + break; + } + case 'p': { + struct pic_port **p; + 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++; + } + break; + } + case 'd': { + struct pic_dict **d; + 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++; + } + break; + } + case 'r': { + struct pic_record **r; + 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++; + } + break; + } + case 'e': { + struct pic_error **e; + 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_error(pic, "pic_get_args, expected error"); + } + i++; + } + break; + } + default: + pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c); + } + } + if ('*' == c) { + size_t *n; + pic_value **argv; + + n = va_arg(ap, size_t *); + argv = va_arg(ap, pic_value **); + if (i <= argc) { + *n = argc - i; + *argv = &GET_OPERAND(pic, i); + i = argc; + } + } + else if (argc > i) { + pic_error(pic, "wrong number of arguments"); + } + va_end(ap); + return i - 1; +} + +void +pic_define(pic_state *pic, const char *name, pic_value val) +{ + pic_sym sym, rename; + + sym = pic_intern_cstr(pic, name); + + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { + rename = pic_add_rename(pic, pic->lib->env, sym); + } else { + pic_warn(pic, "redefining global"); + } + + /* push to the global arena */ + xh_put_int(&pic->globals, rename, &val); + + /* export! */ + pic_export(pic, sym); +} + +pic_value +pic_ref(pic_state *pic, const char *name) +{ + pic_sym sym, rename; + + sym = pic_intern_cstr(pic, name); + + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { + pic_errorf(pic, "symbol \"%s\" not defined", name); + } + + return xh_val(xh_get_int(&pic->globals, rename), pic_value); +} + +pic_value +pic_funcall(pic_state *pic, const char *name, pic_list args) +{ + pic_value proc; + + proc = pic_ref(pic, name); + + pic_assert_type(pic, proc, proc); + + return pic_apply(pic, pic_proc_ptr(proc), args); +} + +void +pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) +{ + struct pic_proc *proc; + + proc = pic_proc_new(pic, cfunc, name); + pic_define(pic, name, pic_obj_value(proc)); +} + +static void +vm_push_env(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) * ci->regc, PIC_TT_ENV); + ci->env->up = ci->up; + ci->env->regc = ci->regc; + ci->env->regs = ci->regs; +} + +static void +vm_tear_off(pic_callinfo *ci) +{ + struct pic_env *env; + int i; + + assert(ci->env != NULL); + + env = ci->env; + + if (env->regs == env->storage) { + return; /* is torn off */ + } + for (i = 0; i < env->regc; ++i) { + env->storage[i] = env->regs[i]; + } + env->regs = env->storage; +} + +void +pic_vm_tear_off(pic_state *pic) +{ + pic_callinfo *ci; + + for (ci = pic->ci; ci > pic->cibase; ci--) { + if (ci->env != NULL) { + vm_tear_off(ci); + } + } +} + +pic_value +pic_apply0(pic_state *pic, struct pic_proc *proc) +{ + return pic_apply(pic, proc, pic_nil_value()); +} + +pic_value +pic_apply1(pic_state *pic, struct pic_proc *proc, pic_value arg1) +{ + return pic_apply(pic, proc, pic_list1(pic, arg1)); +} + +pic_value +pic_apply2(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2) +{ + return pic_apply(pic, proc, pic_list2(pic, arg1, arg2)); +} + +pic_value +pic_apply3(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3) +{ + return pic_apply(pic, proc, pic_list3(pic, arg1, arg2, arg3)); +} + +pic_value +pic_apply4(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) +{ + return pic_apply(pic, proc, pic_list4(pic, arg1, arg2, arg3, arg4)); +} + +pic_value +pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) +{ + return pic_apply(pic, proc, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); +} + +#if VM_DEBUG +# define OPCODE_EXEC_HOOK pic_dump_code(c) +#else +# define OPCODE_EXEC_HOOK ((void)0) +#endif + +#if PIC_DIRECT_THREADED_VM +# define VM_LOOP JUMP; +# define CASE(x) L_##x: OPCODE_EXEC_HOOK; +# define NEXT pic->ip++; JUMP; +# define JUMP c = *pic->ip; goto *oplabels[c.insn]; +# define VM_LOOP_END +#else +# define VM_LOOP for (;;) { c = *pic->ip; switch (c.insn) { +# define CASE(x) case x: +# define NEXT pic->ip++; break +# define JUMP break +# define VM_LOOP_END } } +#endif + +#define PUSH(v) ((pic->sp >= pic->stend) ? abort() : (*pic->sp++ = (v))) +#define POP() (*--pic->sp) + +#define PUSHCI() (++pic->ci) +#define POPCI() (pic->ci--) + +pic_value +pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) +{ + pic_code c; + size_t ai = pic_gc_arena_preserve(pic); + size_t argc, i; + 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, + &&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_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 + }; +#endif + + if (! pic_list_p(argv)) { + pic_error(pic, "argv must be a proper list"); + } + + argc = pic_length(pic, argv) + 1; + +#if VM_DEBUG + puts("### booting VM... ###"); + pic_value *stbase = pic->sp; + pic_callinfo *cibase = pic->ci; +#endif + + PUSH(pic_obj_value(proc)); + for (i = 1; i < argc; ++i) { + PUSH(pic_car(pic, argv)); + argv = pic_cdr(pic, argv); + } + + /* boot! */ + boot[0].insn = OP_CALL; + boot[0].u.i = argc; + boot[1].insn = OP_STOP; + pic->ip = boot; + + VM_LOOP { + CASE(OP_NOP) { + NEXT; + } + CASE(OP_POP) { + POP(); + NEXT; + } + CASE(OP_PUSHNIL) { + PUSH(pic_nil_value()); + NEXT; + } + CASE(OP_PUSHTRUE) { + PUSH(pic_true_value()); + NEXT; + } + CASE(OP_PUSHFALSE) { + PUSH(pic_false_value()); + NEXT; + } + CASE(OP_PUSHINT) { + PUSH(pic_int_value(c.u.i)); + NEXT; + } + CASE(OP_PUSHCHAR) { + PUSH(pic_char_value(c.u.c)); + NEXT; + } + CASE(OP_PUSHCONST) { + pic_value self; + struct pic_irep *irep; + + self = pic->ci->fp[0]; + if (! pic_proc_p(self)) { + pic_error(pic, "logic flaw"); + } + irep = pic_proc_ptr(self)->u.irep; + if (! pic_proc_irep_p(pic_proc_ptr(self))) { + pic_error(pic, "logic flaw"); + } + PUSH(irep->pool[c.u.i]); + NEXT; + } + CASE(OP_GREF) { + xh_entry *e; + + 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)); + } + PUSH(xh_val(e, pic_value)); + NEXT; + } + CASE(OP_GSET) { + pic_value val; + + val = POP(); + xh_put_int(&pic->globals, c.u.i, &val); + NEXT; + } + CASE(OP_LREF) { + PUSH(pic->ci->fp[c.u.i]); + NEXT; + } + CASE(OP_LSET) { + pic->ci->fp[c.u.i] = POP(); + NEXT; + } + CASE(OP_CREF) { + int depth = c.u.r.depth; + struct pic_env *env; + + env = pic->ci->up; + while (--depth) { + env = env->up; + } + PUSH(env->regs[c.u.r.idx]); + NEXT; + } + CASE(OP_CSET) { + int depth = c.u.r.depth; + struct pic_env *env; + + env = pic->ci->up; + while (--depth) { + env = env->up; + } + env->regs[c.u.r.idx] = POP(); + NEXT; + } + CASE(OP_JMP) { + pic->ip += c.u.i; + JUMP; + } + CASE(OP_JMPIF) { + pic_value v; + + v = POP(); + if (! pic_false_p(v)) { + pic->ip += c.u.i; + JUMP; + } + NEXT; + } + CASE(OP_NOT) { + pic_value v; + + v = pic_false_p(POP()) ? pic_true_value() : pic_false_value(); + PUSH(v); + NEXT; + } + CASE(OP_CALL) { + pic_value x, v; + pic_callinfo *ci; + struct pic_proc *proc; + + if (c.u.i == -1) { + pic->sp += pic->ci[1].retc - 1; + c.u.i = pic->ci[1].retc + 1; + } + + L_CALL: + x = pic->sp[-c.u.i]; + if (! pic_proc_p(x)) { + + if (pic_var_p(x)) { + if (c.u.i != 1) { + pic_errorf(pic, "invalid call-sequence for var object"); + } + POP(); + PUSH(pic_var_ref(pic, pic_var_ptr(x))); + NEXT; + } + pic_errorf(pic, "invalid application: ~s", x); + } + proc = pic_proc_ptr(x); + +#if VM_DEBUG + 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) { + 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(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); + pic_dump_irep(proc->u.irep); + } + else { + printf(" cfunc = %p\n", (void *)proc->u.func.f); + printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); + } + puts("== end\n"); +#endif + + ci = PUSHCI(); + ci->argc = c.u.i; + ci->retc = 1; + ci->ip = pic->ip; + ci->fp = pic->sp - c.u.i; + ci->env = NULL; + if (pic_proc_func_p(pic_proc_ptr(x))) { + + /* invoke! */ + v = proc->u.func.f(pic); + pic->sp[0] = v; + pic->sp += pic->ci->retc; + + pic_gc_arena_restore(pic, ai); + goto L_RET; + } + else { + struct pic_irep *irep = proc->u.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 ? "+" : "")); + } + } + /* prepare rest args */ + if (irep->varg) { + rest = pic_nil_value(); + for (i = 0; i < ci->argc - irep->argc; ++i) { + pic_gc_protect(pic, v = POP()); + rest = pic_cons(pic, v, rest); + } + PUSH(rest); + } + /* prepare local variable area */ + if (irep->localc > 0) { + int l = irep->localc; + if (irep->varg) { + --l; + } + for (i = 0; i < l; ++i) { + PUSH(pic_undef_value()); + } + } + + /* prepare env */ + ci->up = proc->env; + ci->regc = irep->capturec; + ci->regs = ci->fp + irep->argc + irep->localc; + + pic->ip = irep->code; + pic_gc_arena_restore(pic, ai); + JUMP; + } + } + CASE(OP_TAILCALL) { + int i, argc; + pic_value *argv; + pic_callinfo *ci; + + if (pic->ci->env != NULL) { + vm_tear_off(pic->ci); + } + + if (c.u.i == -1) { + pic->sp += pic->ci[1].retc - 1; + c.u.i = pic->ci[1].retc + 1; + } + + argc = c.u.i; + argv = pic->sp - argc; + for (i = 0; i < argc; ++i) { + pic->ci->fp[i] = argv[i]; + } + ci = POPCI(); + pic->sp = ci->fp + argc; + pic->ip = ci->ip; + + /* c is not changed */ + goto L_CALL; + } + CASE(OP_RET) { + int i, retc; + pic_value *retv; + pic_callinfo *ci; + + if (pic->ci->env != NULL) { + vm_tear_off(pic->ci); + } + + pic->ci->retc = c.u.i; + + L_RET: + retc = pic->ci->retc; + retv = pic->sp - retc; + if (retc == 0) { + pic->ci->fp[0] = retv[0]; /* copy at least once */ + } + for (i = 0; i < retc; ++i) { + pic->ci->fp[i] = retv[i]; + } + ci = POPCI(); + pic->sp = ci->fp + 1; /* advance only one! */ + pic->ip = ci->ip; + + NEXT; + } + CASE(OP_LAMBDA) { + pic_value self; + struct pic_irep *irep; + struct pic_proc *proc; + + self = pic->ci->fp[0]; + if (! pic_proc_p(self)) { + pic_error(pic, "logic flaw"); + } + irep = pic_proc_ptr(self)->u.irep; + if (! pic_proc_irep_p(pic_proc_ptr(self))) { + pic_error(pic, "logic flaw"); + } + + if (pic->ci->env == NULL) { + vm_push_env(pic); + } + + proc = pic_proc_new_irep(pic, irep->irep[c.u.i], pic->ci->env); + PUSH(pic_obj_value(proc)); + pic_gc_arena_restore(pic, ai); + NEXT; + } + CASE(OP_CONS) { + pic_value a, b; + pic_gc_protect(pic, b = POP()); + pic_gc_protect(pic, a = POP()); + PUSH(pic_cons(pic, a, b)); + pic_gc_arena_restore(pic, ai); + NEXT; + } + CASE(OP_CAR) { + pic_value p; + p = POP(); + PUSH(pic_car(pic, p)); + NEXT; + } + CASE(OP_CDR) { + pic_value p; + p = POP(); + PUSH(pic_cdr(pic, p)); + NEXT; + } + CASE(OP_NILP) { + pic_value p; + p = POP(); + PUSH(pic_bool_value(pic_nil_p(p))); + NEXT; + } + +#define DEFINE_ARITH_OP(opcode, op, guard) \ + CASE(opcode) { \ + pic_value a, b; \ + b = POP(); \ + a = POP(); \ + if (pic_int_p(a) && pic_int_p(b)) { \ + double f = (double)pic_int(a) op (double)pic_int(b); \ + if (INT_MIN <= f && f <= INT_MAX && (guard)) { \ + PUSH(pic_int_value((int)f)); \ + } \ + else { \ + PUSH(pic_float_value(f)); \ + } \ + } \ + else if (pic_float_p(a) && pic_float_p(b)) { \ + PUSH(pic_float_value(pic_float(a) op pic_float(b))); \ + } \ + else if (pic_int_p(a) && pic_float_p(b)) { \ + PUSH(pic_float_value(pic_int(a) op pic_float(b))); \ + } \ + else if (pic_float_p(a) && pic_int_p(b)) { \ + PUSH(pic_float_value(pic_float(a) op pic_int(b))); \ + } \ + else { \ + pic_error(pic, #op " got non-number operands"); \ + } \ + NEXT; \ + } + + 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)); + + CASE(OP_MINUS) { + pic_value n; + n = POP(); + if (pic_int_p(n)) { + PUSH(pic_int_value(-pic_int(n))); + } + else if (pic_float_p(n)) { + PUSH(pic_float_value(-pic_float(n))); + } + else { + pic_error(pic, "unary - got a non-number operand"); + } + NEXT; + } + +#define DEFINE_COMP_OP(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 if (pic_float_p(a) && pic_float_p(b)) { \ + PUSH(pic_bool_value(pic_float(a) op pic_float(b))); \ + } \ + else if (pic_int_p(a) && pic_float_p(b)) { \ + PUSH(pic_bool_value(pic_int(a) op pic_float(b))); \ + } \ + else if (pic_float_p(a) && pic_int_p(b)) { \ + PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \ + } \ + else { \ + pic_error(pic, #op " got non-number operands"); \ + } \ + NEXT; \ + } + + DEFINE_COMP_OP(OP_EQ, ==); + DEFINE_COMP_OP(OP_LT, <); + DEFINE_COMP_OP(OP_LE, <=); + + CASE(OP_STOP) { + +#if VM_DEBUG + puts("**VM END STATE**"); + printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp); + printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci); + if (stbase < pic->sp - 1) { + pic_value *sp; + printf("* stack trace:"); + for (sp = stbase; pic->sp != sp; ++sp) { + pic_debug(pic, *sp); + puts(""); + } + } + if (stbase > pic->sp - 1) { + puts("*** stack underflow!"); + } +#endif + + return pic_gc_protect(pic, POP()); + } + } VM_LOOP_END; +} + +pic_value +pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) +{ + static const pic_code iseq[2] = { + { OP_NOP, {} }, + { OP_TAILCALL, { .i = -1 } } + }; + + pic_value v, *sp; + pic_callinfo *ci; + + *pic->sp++ = pic_obj_value(proc); + + sp = pic->sp; + pic_for_each (v, args) { + *sp++ = v; + } + + ci = PUSHCI(); + ci->ip = (pic_code *)iseq; + ci->fp = pic->sp; + ci->retc = pic_length(pic, args); + + if (ci->retc == 0) { + return pic_none_value(); + } else { + return pic_car(pic, args); + } +} diff --git a/write.c b/write.c new file mode 100644 index 00000000..70a547b9 --- /dev/null +++ b/write.c @@ -0,0 +1,506 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#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) +{ + 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)); +} + +static bool +is_quote(pic_state *pic, pic_value pair) +{ + return is_tagged(pic, pic->sQUOTE, pair); +} + +static bool +is_unquote(pic_state *pic, pic_value pair) +{ + return is_tagged(pic, pic->sUNQUOTE, pair); +} + +static bool +is_unquote_splicing(pic_state *pic, pic_value pair) +{ + return is_tagged(pic, pic->sUNQUOTE_SPLICING, pair); +} + +static bool +is_quasiquote(pic_state *pic, pic_value pair) +{ + return is_tagged(pic, pic->sQUASIQUOTE, pair); +} + +struct writer_control { + pic_state *pic; + xFILE *file; + int mode; + xhash labels; /* object -> int */ + xhash visited; /* object -> int */ + int cnt; +}; + +#define WRITE_MODE 1 +#define DISPLAY_MODE 2 + +static void +writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode) +{ + p->pic = pic; + p->file = file; + p->mode = mode; + p->cnt = 0; + xh_init_ptr(&p->labels, sizeof(int)); + xh_init_ptr(&p->visited, sizeof(int)); +} + +static void +writer_control_destroy(struct writer_control *p) +{ + xh_destroy(&p->labels); + xh_destroy(&p->visited); +} + +static void +traverse_shared(struct writer_control *p, pic_value obj) +{ + xh_entry *e; + size_t i; + int c; + + switch (pic_type(obj)) { + case PIC_TT_PAIR: + case PIC_TT_VECTOR: + e = xh_get_ptr(&p->labels, pic_obj_ptr(obj)); + if (e == NULL) { + c = -1; + xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); + } + else if (xh_val(e, int) == -1) { + c = p->cnt++; + xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); + break; + } + else { + break; + } + + if (pic_pair_p(obj)) { + traverse_shared(p, pic_car(p->pic, obj)); + traverse_shared(p, pic_cdr(p->pic, obj)); + } + else { + for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { + traverse_shared(p, pic_vec_ptr(obj)->data[i]); + } + } + break; + default: + /* pass */ + break; + } +} + +static void write_core(struct writer_control *p, pic_value); + +static void +write_pair(struct writer_control *p, struct pic_pair *pair) +{ + xh_entry *e; + int c; + + write_core(p, pair->car); + + if (pic_nil_p(pair->cdr)) { + return; + } + else if (pic_pair_p(pair->cdr)) { + + /* shared objects */ + if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) { + xfprintf(p->file, " . "); + + if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) { + xfprintf(p->file, "#%d#", xh_val(e, int)); + return; + } + else { + xfprintf(p->file, "#%d=", xh_val(e, int)); + c = 1; + xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c); + } + } + else { + xfprintf(p->file, " "); + } + + write_pair(p, pic_pair_ptr(pair->cdr)); + return; + } + else { + xfprintf(p->file, " . "); + write_core(p, pair->cdr); + } +} + +static void +write_str(pic_state *pic, struct pic_string *str, xFILE *file) +{ + size_t i; + const char *cstr = pic_str_cstr(str); + + UNUSED(pic); + + for (i = 0; i < pic_strlen(str); ++i) { + if (cstr[i] == '"' || cstr[i] == '\\') { + xfputc('\\', file); + } + xfputc(cstr[i], file); + } +} + +static void +write_record(pic_state *pic, struct pic_record *rec, xFILE *file) +{ + const pic_sym sWRITER = pic_intern_cstr(pic, "writer"); + pic_value type, writer, str; + +#if DEBUG + + xfprintf(file, "#", rec); + +#else + + type = pic_record_type(pic, rec); + if (! pic_record_p(type)) { + pic_errorf(pic, "\"@@type\" property of record object is not of record type"); + } + writer = pic_record_ref(pic, pic_record_ptr(type), sWRITER); + if (! pic_proc_p(writer)) { + pic_errorf(pic, "\"writer\" property of record type object is not a procedure"); + } + str = pic_apply1(pic, pic_proc_ptr(writer), pic_obj_value(rec)); + 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))); + +#endif +} + +static void +write_core(struct writer_control *p, pic_value obj) +{ + pic_state *pic = p->pic; + xFILE *file = p->file; + size_t i; + xh_entry *e; + xh_iter it; + int c; + float f; + + /* shared objects */ + if (pic_vtype(obj) == PIC_VTYPE_HEAP + && (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj))) + && xh_val(e, int) != -1) { + if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) { + xfprintf(file, "#%d#", xh_val(e, int)); + return; + } + else { + xfprintf(file, "#%d=", xh_val(e, int)); + c = 1; + xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c); + } + } + + switch (pic_type(obj)) { + case PIC_TT_UNDEF: + xfprintf(file, "#"); + break; + case PIC_TT_NIL: + xfprintf(file, "()"); + break; + case PIC_TT_BOOL: + if (pic_true_p(obj)) + xfprintf(file, "#t"); + else + xfprintf(file, "#f"); + break; + case PIC_TT_PAIR: + if (is_quote(pic, obj)) { + xfprintf(file, "'"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (is_unquote(pic, obj)) { + xfprintf(file, ","); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (is_unquote_splicing(pic, obj)) { + xfprintf(file, ",@"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (is_quasiquote(pic, obj)) { + xfprintf(file, "`"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + xfprintf(file, "("); + write_pair(p, pic_pair_ptr(obj)); + xfprintf(file, ")"); + break; + case PIC_TT_SYMBOL: + xfprintf(file, "%s", pic_symbol_name(pic, pic_sym(obj))); + break; + case PIC_TT_CHAR: + if (p->mode == DISPLAY_MODE) { + xfputc(pic_char(obj), file); + break; + } + switch (pic_char(obj)) { + default: xfprintf(file, "#\\%c", pic_char(obj)); break; + case '\a': xfprintf(file, "#\\alarm"); break; + case '\b': xfprintf(file, "#\\backspace"); break; + case 0x7f: xfprintf(file, "#\\delete"); break; + case 0x1b: xfprintf(file, "#\\escape"); break; + case '\n': xfprintf(file, "#\\newline"); break; + case '\r': xfprintf(file, "#\\return"); break; + case ' ': xfprintf(file, "#\\space"); break; + case '\t': xfprintf(file, "#\\tab"); break; + } + break; + case PIC_TT_FLOAT: + f = pic_float(obj); + if (isnan(f)) { + xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0"); + } else if (isinf(f)) { + xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0"); + } else { + xfprintf(file, "%f", pic_float(obj)); + } + break; + case PIC_TT_INT: + xfprintf(file, "%d", pic_int(obj)); + break; + case PIC_TT_EOF: + xfprintf(file, "#.(eof-object)"); + break; + case PIC_TT_STRING: + if (p->mode == DISPLAY_MODE) { + xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(obj))); + break; + } + xfprintf(file, "\""); + write_str(pic, pic_str_ptr(obj), file); + xfprintf(file, "\""); + break; + case PIC_TT_VECTOR: + xfprintf(file, "#("); + for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { + write_core(p, pic_vec_ptr(obj)->data[i]); + if (i + 1 < pic_vec_ptr(obj)->len) { + xfprintf(file, " "); + } + } + xfprintf(file, ")"); + break; + case PIC_TT_BLOB: + xfprintf(file, "#u8("); + for (i = 0; i < pic_blob_ptr(obj)->len; ++i) { + xfprintf(file, "%d", pic_blob_ptr(obj)->data[i]); + if (i + 1 < pic_blob_ptr(obj)->len) { + xfprintf(file, " "); + } + } + xfprintf(file, ")"); + break; + case PIC_TT_DICT: + xfprintf(file, "#.(dictionary"); + xh_begin(&it, &pic_dict_ptr(obj)->hash); + while (xh_next(&it)) { + xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it.e, pic_sym))); + write_core(p, xh_val(it.e, pic_value)); + } + xfprintf(file, ")"); + break; + case PIC_TT_RECORD: + write_record(pic, pic_record_ptr(obj), file); + break; + default: + xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); + break; + } +} + +static void +write(pic_state *pic, pic_value obj, xFILE *file) +{ + struct writer_control p; + + writer_control_init(&p, pic, file, WRITE_MODE); + + traverse_shared(&p, obj); /* FIXME */ + + write_core(&p, obj); + + writer_control_destroy(&p); +} + +static void +write_simple(pic_state *pic, pic_value obj, xFILE *file) +{ + struct writer_control p; + + writer_control_init(&p, pic, file, WRITE_MODE); + + /* no traverse here! */ + + write_core(&p, obj); + + writer_control_destroy(&p); +} + +static void +write_shared(pic_state *pic, pic_value obj, xFILE *file) +{ + struct writer_control p; + + writer_control_init(&p, pic, file, WRITE_MODE); + + traverse_shared(&p, obj); + + write_core(&p, obj); + + writer_control_destroy(&p); +} + +static void +display(pic_state *pic, pic_value obj, xFILE *file) +{ + struct writer_control p; + + writer_control_init(&p, pic, file, DISPLAY_MODE); + + traverse_shared(&p, obj); /* FIXME */ + + write_core(&p, obj); + + writer_control_destroy(&p); +} + +pic_value +pic_write(pic_state *pic, pic_value obj) +{ + return pic_fwrite(pic, obj, xstdout); +} + +pic_value +pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) +{ + write(pic, obj, file); + xfflush(file); + return obj; +} + +pic_value +pic_display(pic_state *pic, pic_value obj) +{ + return pic_fdisplay(pic, obj, xstdout); +} + +pic_value +pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) +{ + display(pic, obj, file); + xfflush(file); + return obj; +} + +void +pic_printf(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_str *str; + + va_start(ap, fmt); + + str = pic_str_ptr(pic_car(pic, pic_vformat(pic, fmt, ap))); + + va_end(ap); + + xprintf("%s", pic_str_cstr(str)); + xfflush(xstdout); +} + +static pic_value +pic_write_write(pic_state *pic) +{ + pic_value v; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "o|p", &v, &port); + write(pic, v, port->file); + return pic_none_value(); +} + +static pic_value +pic_write_write_simple(pic_state *pic) +{ + pic_value v; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "o|p", &v, &port); + write_simple(pic, v, port->file); + return pic_none_value(); +} + +static pic_value +pic_write_write_shared(pic_state *pic) +{ + pic_value v; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "o|p", &v, &port); + write_shared(pic, v, port->file); + return pic_none_value(); +} + +static pic_value +pic_write_display(pic_state *pic) +{ + pic_value v; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "o|p", &v, &port); + display(pic, v, port->file); + return pic_none_value(); +} + +void +pic_init_write(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme write)") { + pic_defun(pic, "write", pic_write_write); + pic_defun(pic, "write-simple", pic_write_write_simple); + pic_defun(pic, "write-shared", pic_write_write_shared); + pic_defun(pic, "display", pic_write_display); + } +} From ff21555a76bfb99e52dd7c21298f4c5ed2b5318d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 13:39:15 +0900 Subject: [PATCH 002/232] remove needless files --- CMakeLists.txt | 32 -------------------------------- include/.dir-locals.el | 3 --- include/picrin/.dir-locals.el | 4 ---- 3 files changed, 39 deletions(-) delete mode 100644 CMakeLists.txt delete mode 100644 include/.dir-locals.el delete mode 100644 include/picrin/.dir-locals.el diff --git a/CMakeLists.txt b/CMakeLists.txt deleted file mode 100644 index f3e51499..00000000 --- a/CMakeLists.txt +++ /dev/null @@ -1,32 +0,0 @@ -find_package(Perl REQUIRED) - -# xfile -set(XFILE_SOURCES extlib/xfile/xfile.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} - ) - -# build! -file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c) -add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${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 include/ DESTINATION include FILES_MATCHING PATTERN "*.h") diff --git a/include/.dir-locals.el b/include/.dir-locals.el deleted file mode 100644 index 02363d3f..00000000 --- a/include/.dir-locals.el +++ /dev/null @@ -1,3 +0,0 @@ -((c-mode . ((flycheck-clang-include-path . ( "../extlib")) - (flycheck-clang-warnings . ("all" "extra")) - (flycheck-clang-language-standard . "c99")))) diff --git a/include/picrin/.dir-locals.el b/include/picrin/.dir-locals.el deleted file mode 100644 index 24adc5af..00000000 --- a/include/picrin/.dir-locals.el +++ /dev/null @@ -1,4 +0,0 @@ -((c-mode . ((flycheck-clang-includes . ("../picrin.h")) - (flycheck-clang-include-path . ( "../../extlib")) - (flycheck-clang-warnings . ("all" "extra")) - (flycheck-clang-language-standard . "c99")))) From bfef3b35b0a0aaf9fc670b7538d78bcf6f01d7d7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 13:41:06 +0900 Subject: [PATCH 003/232] remove AUTHORS --- AUTHORS | 7 ------- 1 file changed, 7 deletions(-) delete mode 100644 AUTHORS diff --git a/AUTHORS b/AUTHORS deleted file mode 100644 index eb796f59..00000000 --- a/AUTHORS +++ /dev/null @@ -1,7 +0,0 @@ -Yuichi Nishiwaki (yuichi@idylls.jp) -Masanori Ogino (masanori.ogino@gmail.com) -Yuito Murase (themamedaifuku@gmail.com) -Hiromu Yakura (hiromu1996@gmail.com) -Wataru Nakanishi (stibear1996@gmail.com) -Hiroki Kobayashi (silentkiddie-2013@yahoo.co.jp) -Sunrim Kim (3han5chou7@gmail.com) From 96b9a5ecfd052b7d47d8c156532affbe5a9cf796 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 13:41:38 +0900 Subject: [PATCH 004/232] remove LICENSE --- LICENSE | 18 ------------------ 1 file changed, 18 deletions(-) delete mode 100644 LICENSE diff --git a/LICENSE b/LICENSE deleted file mode 100644 index 15ab73e5..00000000 --- a/LICENSE +++ /dev/null @@ -1,18 +0,0 @@ -Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors - -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: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -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. From 8a98394400d3485d8bfc06e54470880ce58270cd Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 13:46:03 +0900 Subject: [PATCH 005/232] update README --- README.md | 116 ++++++++++++------------------------------------------ 1 file changed, 25 insertions(+), 91 deletions(-) diff --git a/README.md b/README.md index dceed0be..e7232ff3 100644 --- a/README.md +++ b/README.md @@ -1,95 +1,29 @@ -# Picrin [![Build Status](https://travis-ci.org/wasabiz/picrin.png)](https://travis-ci.org/wasabiz/picrin) +# Benz -Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not requires any special external libraries installed on the platform. - -## Features - -- 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`) - -## Documentation - -See http://picrin.readthedocs.org/ - -## Homepage - -Currently picrin is hosted on Github. You can freely send a bug report or pull-request, and fork the repository. - -https://github.com/wasabiz/picrin - -## IRC - -There is a chat room on chat.freenode.org, channel #picrin. IRC logs here: https://botbot.me/freenode/picrin/ - -## How to use it - -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/. - - $ 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 ccmake. - - $ 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 .. - - -## Requirement - -Picrin scheme depends on some external libraries to build the binary: - -- perl -- getopt -- 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 :( +Benz is a core module of the Picrin Scheme interpreter. It includes every components necessary to run in a stand-alone environment. ## Authors -See `AUTHORS` +See https://github.com/picrin-scheme/benz and https://github.com/picrin-scheme/picrin for details. + +## LICENSE + +Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors + +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: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +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. + From 9746db3b9bc902713e016eee44e38c237ab13fe0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 13:48:26 +0900 Subject: [PATCH 006/232] remove auto-generated files --- init_contrib.c | 17 - load_piclib.c | 3978 ------------------------------------------------ 2 files changed, 3995 deletions(-) delete mode 100644 init_contrib.c delete mode 100644 load_piclib.c diff --git a/init_contrib.c b/init_contrib.c deleted file mode 100644 index 50542d47..00000000 --- a/init_contrib.c +++ /dev/null @@ -1,17 +0,0 @@ -/** - * !!NOTICE!! - * This file was automatically generated by mkinit.pl, and includes all of - * the prelude files required by Picrin. PLEASE DO NOT EDIT THIS FILE, changes - * will be overwritten the next time the script runs. - */ - -#include "picrin.h" - -void -pic_init_contrib(pic_state *pic) -{ - void pic_init_random(pic_state *); - void pic_init_regexp(pic_state *); - pic_init_random(pic); - pic_init_regexp(pic); -} diff --git a/load_piclib.c b/load_piclib.c deleted file mode 100644 index 84e241a7..00000000 --- a/load_piclib.c +++ /dev/null @@ -1,3978 +0,0 @@ -/** - * !!NOTICE!! - * This file was automatically generated by mkloader.pl, and includes all of - * the prelude files required by Picrin. PLEASE DO NOT EDIT THIS FILE, changes - * will be overwritten the next time the script runs. - */ - -#include "picrin.h" -#include "picrin/error.h" - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_base = -"(define-library (picrin base)\n" -" (import (rename (picrin base core) (define define*))\n" -" (picrin base macro)\n" -" (picrin base list)\n" -" (picrin base symbol))\n" -"\n" -" (define-syntax define\n" -" (lambda (form use-env mac-env)\n" -" (if (symbol? (car (cdr form)))\n" -" (cons (make-identifier 'define* mac-env) (cdr form))\n" -" (cons (make-identifier 'define mac-env)\n" -" (cons (car (car (cdr form)))\n" -" (cons (cons (make-identifier 'lambda mac-env)\n" -" (cons (cdr (car (cdr form)))\n" -" (cdr (cdr form))))\n" -" '()))))))\n" -"\n" -" (export define\n" -" set!\n" -" quote\n" -" lambda\n" -" if\n" -" begin\n" -" define-syntax))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_list = -"(define-library (picrin list)\n" -" (import (picrin base list))\n" -"\n" -" (export pair?\n" -" cons\n" -" car\n" -" cdr\n" -" set-car!\n" -" set-cdr!\n" -" null?\n" -" caar\n" -" cadr\n" -" cdar\n" -" cddr\n" -" list?\n" -" make-list\n" -" list\n" -" length\n" -" append\n" -" reverse\n" -" list-tail\n" -" list-ref\n" -" list-set!\n" -" list-copy\n" -" memq\n" -" memv\n" -" member\n" -" assq\n" -" assv\n" -" assoc))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_symbol = -"(define-library (picrin symbol)\n" -" (import (picrin base symbol))\n" -"\n" -" (export symbol?\n" -" symbol=?\n" -" symbol->string\n" -" string->symbol))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_macro = -";;; Hygienic Macros\n" -"\n" -"(define-library (picrin macro)\n" -" (import (picrin base macro)\n" -" (picrin base)\n" -" (picrin list)\n" -" (picrin symbol)\n" -" (scheme base)\n" -" (picrin dictionary))\n" -"\n" -" ;; assumes no derived expressions are provided yet\n" -"\n" -" (define (walk proc expr)\n" -" \"walk on symbols\"\n" -" (if (null? expr)\n" -" '()\n" -" (if (pair? expr)\n" -" (cons (walk proc (car expr))\n" -" (walk proc (cdr expr)))\n" -" (if (vector? expr)\n" -" (list->vector (walk proc (vector->list expr)))\n" -" (if (symbol? expr)\n" -" (proc expr)\n" -" expr)))))\n" -"\n" -" (define (memoize f)\n" -" \"memoize on symbols\"\n" -" (define cache (make-dictionary))\n" -" (lambda (sym)\n" -" (if (dictionary-has? cache sym)\n" -" (dictionary-ref cache sym)\n" -" (begin\n" -" (define val (f sym))\n" -" (dictionary-set! cache sym val)\n" -" val))))\n" -"\n" -" (define (identifier=? env1 sym1 env2 sym2)\n" -"\n" -" (define (resolve sym env)\n" -" (define x (make-identifier sym env))\n" -" (define y (make-identifier sym env))\n" -" (if (eq? x y)\n" -" x\n" -" sym)) ; resolved to no variable\n" -"\n" -" (eq? (resolve sym1 env1)\n" -" (resolve sym2 env2)))\n" -"\n" -" (define (make-syntactic-closure env free form)\n" -"\n" -" (define resolve\n" -" (memoize\n" -" (lambda (sym)\n" -" (make-identifier sym env))))\n" -"\n" -" (walk\n" -" (lambda (sym)\n" -" (if (memq sym free)\n" -" sym\n" -" (resolve sym)))\n" -" form))\n" -"\n" -" (define (close-syntax form env)\n" -" (make-syntactic-closure env '() form))\n" -"\n" -" (define-syntax capture-syntactic-environment\n" -" (lambda (form use-env mac-env)\n" -" (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))\n" -"\n" -" (define (sc-macro-transformer f)\n" -" (lambda (expr use-env mac-env)\n" -" (make-syntactic-closure mac-env '() (f expr use-env))))\n" -"\n" -" (define (rsc-macro-transformer f)\n" -" (lambda (expr use-env mac-env)\n" -" (make-syntactic-closure use-env '() (f expr mac-env))))\n" -"\n" -" (define (er-macro-transformer f)\n" -" (lambda (expr use-env mac-env)\n" -"\n" -" (define rename\n" -" (memoize\n" -" (lambda (sym)\n" -" (make-identifier sym mac-env))))\n" -"\n" -" (define (compare x y)\n" -" (if (not (symbol? x))\n" -" #f\n" -" (if (not (symbol? y))\n" -" #f\n" -" (identifier=? use-env x use-env y))))\n" -"\n" -" (f expr rename compare)))\n" -"\n" -" (define (ir-macro-transformer f)\n" -" (lambda (expr use-env mac-env)\n" -"\n" -" (define icache* (make-dictionary))\n" -"\n" -" (define inject\n" -" (memoize\n" -" (lambda (sym)\n" -" (define id (make-identifier sym use-env))\n" -" (dictionary-set! icache* id sym)\n" -" id)))\n" -"\n" -" (define rename\n" -" (memoize\n" -" (lambda (sym)\n" -" (make-identifier sym mac-env))))\n" -"\n" -" (define (compare x y)\n" -" (if (not (symbol? x))\n" -" #f\n" -" (if (not (symbol? y))\n" -" #f\n" -" (identifier=? mac-env x mac-env y))))\n" -"\n" -" (walk (lambda (sym)\n" -" (if (dictionary-has? icache* sym)\n" -" (dictionary-ref icache* sym)\n" -" (rename sym)))\n" -" (f (walk inject expr) inject compare))))\n" -"\n" -" (define (strip-syntax form)\n" -" (walk ungensym form))\n" -"\n" -" (define-syntax define-macro\n" -" (er-macro-transformer\n" -" (lambda (expr r c)\n" -" (define formal (car (cdr expr)))\n" -" (define body (cdr (cdr expr)))\n" -" (if (symbol? formal)\n" -" (list (r 'define-syntax) formal\n" -" (list (r 'lambda) (list (r 'form) '_ '_)\n" -" (list (r 'apply) (car body) (list (r 'cdr) (r 'form)))))\n" -" (list (r 'define-macro) (car formal)\n" -" (cons (r 'lambda)\n" -" (cons (cdr formal)\n" -" body)))))))\n" -"\n" -" (export identifier?\n" -" identifier=?\n" -" make-identifier\n" -" make-syntactic-closure\n" -" close-syntax\n" -" capture-syntactic-environment\n" -" sc-macro-transformer\n" -" rsc-macro-transformer\n" -" er-macro-transformer\n" -" ir-macro-transformer\n" -" strip-syntax\n" -" define-macro))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_base = -"(define-library (scheme base)\n" -" (import (picrin base)\n" -" (picrin list)\n" -" (picrin symbol)\n" -" (picrin macro))\n" -"\n" -" (export define set! lambda quote\n" -" if begin define-syntax)\n" -"\n" -" ;; core syntax\n" -"\n" -" (define-syntax syntax-error\n" -" (er-macro-transformer\n" -" (lambda (expr rename compare)\n" -" (apply error (cdr expr)))))\n" -"\n" -" (define-syntax define-auxiliary-syntax\n" -" (er-macro-transformer\n" -" (lambda (expr r c)\n" -" (list (r 'define-syntax) (cadr expr)\n" -" (list (r 'lambda) '_\n" -" (list (r 'error) \"invalid use of auxiliary syntax\"))))))\n" -"\n" -" (define-auxiliary-syntax else)\n" -" (define-auxiliary-syntax =>)\n" -" (define-auxiliary-syntax _)\n" -" (define-auxiliary-syntax ...)\n" -" (define-auxiliary-syntax unquote)\n" -" (define-auxiliary-syntax unquote-splicing)\n" -"\n" -" (define-syntax let\n" -" (er-macro-transformer\n" -" (lambda (expr r compare)\n" -" (if (symbol? (cadr expr))\n" -" (begin\n" -" (define name (car (cdr expr)))\n" -" (define bindings (car (cdr (cdr expr))))\n" -" (define body (cdr (cdr (cdr expr))))\n" -" (list (r 'let) '()\n" -" (list (r 'define) name\n" -" (cons (r 'lambda) (cons (map car bindings) body)))\n" -" (cons name (map cadr bindings))))\n" -" (begin\n" -" (set! bindings (cadr expr))\n" -" (set! body (cddr expr))\n" -" (cons (cons (r 'lambda) (cons (map car bindings) body))\n" -" (map cadr bindings)))))))\n" -"\n" -" (define-syntax cond\n" -" (er-macro-transformer\n" -" (lambda (expr r compare)\n" -" (let ((clauses (cdr expr)))\n" -" (if (null? clauses)\n" -" #f\n" -" (begin\n" -" (define clause (car clauses))\n" -" (if (compare (r 'else) (car clause))\n" -" (cons (r 'begin) (cdr clause))\n" -" (if (if (>= (length clause) 2)\n" -" (compare (r '=>) (list-ref clause 1))\n" -" #f)\n" -" (list (r 'let) (list (list (r 'x) (car clause)))\n" -" (list (r 'if) (r 'x)\n" -" (list (list-ref clause 2) (r 'x))\n" -" (cons (r 'cond) (cdr clauses))))\n" -" (list (r 'if) (car clause)\n" -" (cons (r 'begin) (cdr clause))\n" -" (cons (r 'cond) (cdr clauses)))))))))))\n" -"\n" -" (define-syntax and\n" -" (er-macro-transformer\n" -" (lambda (expr r compare)\n" -" (let ((exprs (cdr expr)))\n" -" (cond\n" -" ((null? exprs)\n" -" #t)\n" -" ((= (length exprs) 1)\n" -" (car exprs))\n" -" (else\n" -" (list (r 'let) (list (list (r 'it) (car exprs)))\n" -" (list (r 'if) (r 'it)\n" -" (cons (r 'and) (cdr exprs))\n" -" (r 'it)))))))))\n" -"\n" -" (define-syntax or\n" -" (er-macro-transformer\n" -" (lambda (expr r compare)\n" -" (let ((exprs (cdr expr)))\n" -" (cond\n" -" ((null? exprs)\n" -" #t)\n" -" ((= (length exprs) 1)\n" -" (car exprs))\n" -" (else\n" -" (list (r 'let) (list (list (r 'it) (car exprs)))\n" -" (list (r 'if) (r 'it)\n" -" (r 'it)\n" -" (cons (r 'or) (cdr exprs))))))))))\n" -"\n" -" (define-syntax quasiquote\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare)\n" -"\n" -" (define (quasiquote? form)\n" -" (and (pair? form) (compare (car form) 'quasiquote)))\n" -"\n" -" (define (unquote? form)\n" -" (and (pair? form) (compare (car form) 'unquote)))\n" -"\n" -" (define (unquote-splicing? form)\n" -" (and (pair? form) (pair? (car form))\n" -" (compare (car (car form)) '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 'list\n" -" (list 'quote (inject 'unquote))\n" -" (qq (- depth 1) (car (cdr expr))))))\n" -" ;; unquote-splicing\n" -" ((unquote-splicing? expr)\n" -" (if (= depth 1)\n" -" (list 'append\n" -" (car (cdr (car expr)))\n" -" (qq depth (cdr expr)))\n" -" (list 'cons\n" -" (list 'list\n" -" (list 'quote (inject 'unquote-splicing))\n" -" (qq (- depth 1) (car (cdr (car expr)))))\n" -" (qq depth (cdr expr)))))\n" -" ;; quasiquote\n" -" ((quasiquote? expr)\n" -" (list 'list\n" -" (list 'quote (inject 'quasiquote))\n" -" (qq (+ depth 1) (car (cdr expr)))))\n" -" ;; list\n" -" ((pair? expr)\n" -" (list 'cons\n" -" (qq depth (car expr))\n" -" (qq depth (cdr expr))))\n" -" ;; vector\n" -" ((vector? expr)\n" -" (list 'list->vector (qq depth (vector->list expr))))\n" -" ;; simple datum\n" -" (else\n" -" (list '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 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-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" -" (import (scheme read) (scheme file))\n" -"\n" -" (define-syntax include\n" -" (letrec ((read-file\n" -" (lambda (filename)\n" -" (let ((port (open-input-file filename)))\n" -" (dynamic-wind\n" -" (lambda () #f)\n" -" (lambda ()\n" -" (let loop ((expr (read port)) (exprs '()))\n" -" (if (eof-object? expr)\n" -" (reverse exprs)\n" -" (loop (read port) (cons expr exprs)))))\n" -" (lambda ()\n" -" (close-port port)))))))\n" -" (er-macro-transformer\n" -" (lambda (form rename compare)\n" -" (let ((filenames (cdr form)))\n" -" (let ((exprs (apply append (map read-file filenames))))\n" -" `(,(rename 'begin) ,@exprs)))))))\n" -"\n" -" (export let let* letrec letrec*\n" -" quasiquote unquote unquote-splicing\n" -" and or\n" -" cond case else =>\n" -" do when unless\n" -" let-syntax letrec-syntax\n" -" include\n" -" _ ... syntax-error)\n" -"\n" -"\n" -" ;; utility functions\n" -"\n" -" (define (walk proc expr)\n" -" (cond\n" -" ((null? expr)\n" -" '())\n" -" ((pair? expr)\n" -" (cons (walk proc (car expr))\n" -" (walk proc (cdr expr))))\n" -" ((vector? expr)\n" -" (list->vector (map proc (vector->list expr))))\n" -" (else\n" -" (proc expr))))\n" -"\n" -" (define (flatten expr)\n" -" (let ((list '()))\n" -" (walk\n" -" (lambda (x)\n" -" (set! list (cons x list)))\n" -" expr)\n" -" (reverse list)))\n" -"\n" -" (define (reverse* l)\n" -" ;; (reverse* '(a b c d . e)) => (e d c b a)\n" -" (let loop ((a '())\n" -" (d l))\n" -" (if (pair? d)\n" -" (loop (cons (car d) a) (cdr d))\n" -" (cons d a))))\n" -"\n" -" (define (every? pred l)\n" -" (if (null? l)\n" -" #t\n" -" (and (pred (car l)) (every? pred (cdr l)))))\n" -"\n" -"\n" -" ;; extra syntax\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 uniq\n" -" (let ((counter 0))\n" -" (lambda (x)\n" -" (let ((sym (string->symbol (string-append \"var$\" (number->string counter)))))\n" -" (set! counter (+ counter 1))\n" -" sym))))\n" -"\n" -" (define-syntax define-values\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare)\n" -" (let* ((formal (cadr form))\n" -" (formal* (walk uniq formal))\n" -" (exprs (cddr form)))\n" -" `(begin\n" -" ,@(map\n" -" (lambda (var) `(define ,var #f))\n" -" (flatten formal))\n" -" (call-with-values (lambda () ,@exprs)\n" -" (lambda ,formal*\n" -" ,@(map\n" -" (lambda (var val) `(set! ,var ,val))\n" -" (flatten formal)\n" -" (flatten formal*)))))))))\n" -"\n" -" (export let-values\n" -" let*-values\n" -" define-values)\n" -"\n" -" (define-syntax syntax-rules\n" -" (er-macro-transformer\n" -" (lambda (form r compare)\n" -" (define _define (r 'define))\n" -" (define _let (r 'let))\n" -" (define _if (r 'if))\n" -" (define _begin (r 'begin))\n" -" (define _lambda (r 'lambda))\n" -" (define _set! (r 'set!))\n" -" (define _not (r 'not))\n" -" (define _and (r 'and))\n" -" (define _car (r 'car))\n" -" (define _cdr (r 'cdr))\n" -" (define _cons (r 'cons))\n" -" (define _pair? (r 'pair?))\n" -" (define _null? (r 'null?))\n" -" (define _symbol? (r 'symbol?))\n" -" (define _vector? (r 'vector?))\n" -" (define _eqv? (r 'eqv?))\n" -" (define _string=? (r 'string=?))\n" -" (define _map (r 'map))\n" -" (define _vector->list (r 'vector->list))\n" -" (define _list->vector (r 'list->vector))\n" -" (define _quote (r 'quote))\n" -" (define _quasiquote (r 'quasiquote))\n" -" (define _unquote (r 'unquote))\n" -" (define _unquote-splicing (r 'unquote-splicing))\n" -" (define _syntax-error (r 'syntax-error))\n" -" (define _call/cc (r 'call/cc))\n" -" (define _er-macro-transformer (r 'er-macro-transformer))\n" -"\n" -" (define (var->sym v)\n" -" (let loop ((cnt 0)\n" -" (v v))\n" -" (if (symbol? v)\n" -" (string->symbol\n" -" (string-append (symbol->string v) \"/\" (number->string cnt)))\n" -" (loop (+ 1 cnt) (car v)))))\n" -"\n" -" (define push-var list)\n" -"\n" -" (define (compile-match ellipsis literals pattern)\n" -" (letrec ((compile-match-base\n" -" (lambda (pattern)\n" -" (cond ((member pattern literals compare)\n" -" (values\n" -" `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))\n" -" #f\n" -" (exit #f))\n" -" '()))\n" -" ((compare pattern (r '_)) (values #f '()))\n" -" ((and ellipsis (compare pattern ellipsis))\n" -" (values `(,_syntax-error \"invalid pattern\") '()))\n" -" ((symbol? pattern)\n" -" (values `(,_set! ,(var->sym pattern) expr) (list pattern)))\n" -" ((pair? pattern)\n" -" (compile-match-list pattern))\n" -" ((vector? pattern)\n" -" (compile-match-vector pattern))\n" -" ((string? pattern)\n" -" (values\n" -" `(,_if (,_not (,_string=? ',pattern expr))\n" -" (exit #f))\n" -" '()))\n" -" (else\n" -" (values\n" -" `(,_if (,_not (,_eqv? ',pattern expr))\n" -" (exit #f))\n" -" '())))))\n" -"\n" -" (compile-match-list\n" -" (lambda (pattern)\n" -" (let loop ((pattern pattern)\n" -" (matches '())\n" -" (vars '())\n" -" (accessor 'expr))\n" -" (cond ;; (hoge)\n" -" ((not (pair? (cdr pattern)))\n" -" (let*-values (((match1 vars1) (compile-match-base (car pattern)))\n" -" ((match2 vars2) (compile-match-base (cdr pattern))))\n" -" (values\n" -" `(,_begin ,@(reverse matches)\n" -" (,_if (,_pair? ,accessor)\n" -" (,_begin\n" -" (,_let ((expr (,_car ,accessor)))\n" -" ,match1)\n" -" (,_let ((expr (,_cdr ,accessor)))\n" -" ,match2))\n" -" (exit #f)))\n" -" (append vars (append vars1 vars2)))))\n" -" ;; (hoge ... rest args)\n" -" ((and ellipsis (compare (cadr pattern) ellipsis))\n" -" (let-values (((match-r vars-r) (compile-match-list-reverse pattern)))\n" -" (values\n" -" `(,_begin ,@(reverse matches)\n" -" (,_let ((expr (,_let loop ((a ())\n" -" (d ,accessor))\n" -" (,_if (,_pair? d)\n" -" (loop (,_cons (,_car d) a) (,_cdr d))\n" -" (,_cons d a)))))\n" -" ,match-r))\n" -" (append vars vars-r))))\n" -" (else\n" -" (let-values (((match1 vars1) (compile-match-base (car pattern))))\n" -" (loop (cdr pattern)\n" -" (cons `(,_if (,_pair? ,accessor)\n" -" (,_let ((expr (,_car ,accessor)))\n" -" ,match1)\n" -" (exit #f))\n" -" matches)\n" -" (append vars vars1)\n" -" `(,_cdr ,accessor))))))))\n" -"\n" -" (compile-match-list-reverse\n" -" (lambda (pattern)\n" -" (let loop ((pattern (reverse* pattern))\n" -" (matches '())\n" -" (vars '())\n" -" (accessor 'expr))\n" -" (cond ((and ellipsis (compare (car pattern) ellipsis))\n" -" (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))\n" -" (values\n" -" `(,_begin ,@(reverse matches)\n" -" (,_let ((expr ,accessor))\n" -" ,match1))\n" -" (append vars vars1))))\n" -" (else\n" -" (let-values (((match1 vars1) (compile-match-base (car pattern))))\n" -" (loop (cdr pattern)\n" -" (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)\n" -" (append vars vars1)\n" -" `(,_cdr ,accessor))))))))\n" -"\n" -" (compile-match-ellipsis\n" -" (lambda (pattern)\n" -" (let-values (((match vars) (compile-match-base pattern)))\n" -" (values\n" -" `(,_let loop ((expr expr))\n" -" (,_if (,_not (,_null? expr))\n" -" (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)\n" -" (,_let ((expr (,_car expr)))\n" -" ,match)\n" -" ,@(map\n" -" (lambda (var)\n" -" `(,_set! ,(var->sym (push-var var))\n" -" (,_cons ,(var->sym var) ,(var->sym (push-var var)))))\n" -" vars)\n" -" (loop (,_cdr expr)))))\n" -" (map push-var vars)))))\n" -"\n" -" (compile-match-vector\n" -" (lambda (pattern)\n" -" (let-values (((match vars) (compile-match-base (vector->list pattern))))\n" -" (values\n" -" `(,_if (,_vector? expr)\n" -" (,_let ((expr (,_vector->list expr)))\n" -" ,match)\n" -" (exit #f))\n" -" vars)))))\n" -"\n" -" (let-values (((match vars) (compile-match-base (cdr pattern))))\n" -" (values `(,_let ((expr (,_cdr expr)))\n" -" ,match\n" -" #t)\n" -" vars))))\n" -"\n" -" ;;; compile expand\n" -" (define (compile-expand ellipsis reserved template)\n" -" (letrec ((compile-expand-base\n" -" (lambda (template ellipsis-valid)\n" -" (cond ((member template reserved eq?)\n" -" (values (var->sym template) (list template)))\n" -" ((symbol? template)\n" -" (values `(rename ',template) '()))\n" -" ((pair? template)\n" -" (compile-expand-list template ellipsis-valid))\n" -" ((vector? template)\n" -" (compile-expand-vector template ellipsis-valid))\n" -" (else\n" -" (values `',template '())))))\n" -"\n" -" (compile-expand-list\n" -" (lambda (template ellipsis-valid)\n" -" (let loop ((template template)\n" -" (expands '())\n" -" (vars '()))\n" -" (cond ;; (... hoge)\n" -" ((and ellipsis-valid\n" -" (pair? template)\n" -" (compare (car template) ellipsis))\n" -" (if (and (pair? (cdr template)) (null? (cddr template)))\n" -" (compile-expand-base (cadr template) #f)\n" -" (values '(,_syntax-error \"invalid template\") '())))\n" -" ;; hoge\n" -" ((not (pair? template))\n" -" (let-values (((expand1 vars1)\n" -" (compile-expand-base template ellipsis-valid)))\n" -" (values\n" -" `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))\n" -" (append vars vars1))))\n" -" ;; (a ... rest syms)\n" -" ((and ellipsis-valid\n" -" (pair? (cdr template))\n" -" (compare (cadr template) ellipsis))\n" -" (let-values (((expand1 vars1)\n" -" (compile-expand-base (car template) ellipsis-valid)))\n" -" (loop (cddr template)\n" -" (cons\n" -" `(,_unquote-splicing\n" -" (,_map (,_lambda ,(map var->sym vars1) ,expand1)\n" -" ,@(map (lambda (v) (var->sym (push-var v))) vars1)))\n" -" expands)\n" -" (append vars (map push-var vars1)))))\n" -" (else\n" -" (let-values (((expand1 vars1)\n" -" (compile-expand-base (car template) ellipsis-valid)))\n" -" (loop (cdr template)\n" -" (cons\n" -" `(,_unquote ,expand1)\n" -" expands)\n" -" (append vars vars1))))))))\n" -"\n" -" (compile-expand-vector\n" -" (lambda (template ellipsis-valid)\n" -" (let-values (((expand1 vars1)\n" -" (compile-expand-base (vector->list template) ellipsis-valid)))\n" -" (values\n" -" `(,_list->vector ,expand1)\n" -" vars1)))))\n" -"\n" -" (compile-expand-base template ellipsis)))\n" -"\n" -" (define (check-vars vars-pattern vars-template)\n" -" ;;fixme\n" -" #t)\n" -"\n" -" (define (compile-rule ellipsis literals rule)\n" -" (let ((pattern (car rule))\n" -" (template (cadr rule)))\n" -" (let*-values (((match vars-match)\n" -" (compile-match ellipsis literals pattern))\n" -" ((expand vars-expand)\n" -" (compile-expand ellipsis (flatten vars-match) template)))\n" -" (if (check-vars vars-match vars-expand)\n" -" (list vars-match match expand)\n" -" 'mismatch))))\n" -"\n" -" (define (expand-clauses clauses rename)\n" -" (cond ((null? clauses)\n" -" `(,_quote (syntax-error \"no matching pattern\")))\n" -" ((compare (car clauses) 'mismatch)\n" -" `(,_syntax-error \"invalid rule\"))\n" -" (else\n" -" (let ((vars (list-ref (car clauses) 0))\n" -" (match (list-ref (car clauses) 1))\n" -" (expand (list-ref (car clauses) 2)))\n" -" `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)\n" -" (,_let ((result (,_call/cc (,_lambda (exit) ,match))))\n" -" (,_if result\n" -" ,expand\n" -" ,(expand-clauses (cdr clauses) rename))))))))\n" -"\n" -" (define (normalize-form form)\n" -" (if (and (list? form) (>= (length form) 2))\n" -" (let ((ellipsis '...)\n" -" (literals (cadr form))\n" -" (rules (cddr form)))\n" -"\n" -" (when (symbol? literals)\n" -" (set! ellipsis literals)\n" -" (set! literals (car rules))\n" -" (set! rules (cdr rules)))\n" -"\n" -" (if (and (symbol? ellipsis)\n" -" (list? literals)\n" -" (every? symbol? literals)\n" -" (list? rules)\n" -" (every? (lambda (l) (and (list? l) (= (length l) 2))) rules))\n" -" (if (member ellipsis literals compare)\n" -" `(syntax-rules #f ,literals ,@rules)\n" -" `(syntax-rules ,ellipsis ,literals ,@rules))\n" -" #f))\n" -" #f))\n" -"\n" -" (let ((form (normalize-form form)))\n" -" (if form\n" -" (let ((ellipsis (list-ref form 1))\n" -" (literals (list-ref form 2))\n" -" (rules (list-tail form 3)))\n" -" (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))\n" -" rules)))\n" -" `(,_er-macro-transformer\n" -" (,_lambda (expr rename cmp)\n" -" ,(expand-clauses clauses r)))))\n" -"\n" -" `(,_syntax-error \"malformed syntax-rules\"))))))\n" -"\n" -" (export syntax-rules)\n" -"\n" -"\n" -" ;; 4.2.6. Dynamic bindings\n" -"\n" -" (import (picrin parameter))\n" -"\n" -" (define-syntax parameterize\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare)\n" -" (let ((formal (car (cdr form)))\n" -" (body (cdr (cdr form))))\n" -" (let ((vars (map car formal))\n" -" (vals (map cadr formal)))\n" -" `(begin\n" -" ,@(map (lambda (var val) `(parameter-push! ,var ,val)) vars vals)\n" -" (let ((result (begin ,@body)))\n" -" ,@(map (lambda (var) `(parameter-pop! ,var)) vars)\n" -" result)))))))\n" -"\n" -" (export parameterize make-parameter)\n" -"\n" -"\n" -" ;; 4.2.7. Exception handling\n" -"\n" -" (define-syntax guard-aux\n" -" (syntax-rules (else =>)\n" -" ((guard-aux reraise (else result1 result2 ...))\n" -" (begin result1 result2 ...))\n" -" ((guard-aux reraise (test => result))\n" -" (let ((temp test))\n" -" (if temp\n" -" (result temp)\n" -" reraise)))\n" -" ((guard-aux reraise (test => result)\n" -" clause1 clause2 ...)\n" -" (let ((temp test))\n" -" (if temp\n" -" (result temp)\n" -" (guard-aux reraise clause1 clause2 ...))))\n" -" ((guard-aux reraise (test))\n" -" (or test reraise))\n" -" ((guard-aux reraise (test) clause1 clause2 ...)\n" -" (let ((temp test))\n" -" (if temp\n" -" temp\n" -" (guard-aux reraise clause1 clause2 ...))))\n" -" ((guard-aux reraise (test result1 result2 ...))\n" -" (if test\n" -" (begin result1 result2 ...)\n" -" reraise))\n" -" ((guard-aux reraise\n" -" (test result1 result2 ...)\n" -" clause1 clause2 ...)\n" -" (if test\n" -" (begin result1 result2 ...)\n" -" (guard-aux reraise clause1 clause2 ...)))))\n" -"\n" -" (define-syntax guard\n" -" (syntax-rules ()\n" -" ((guard (var clause ...) e1 e2 ...)\n" -" ((call/cc\n" -" (lambda (guard-k)\n" -" (with-exception-handler\n" -" (lambda (condition)\n" -" ((call/cc\n" -" (lambda (handler-k)\n" -" (guard-k\n" -" (lambda ()\n" -" (let ((var condition))\n" -" (guard-aux\n" -" (handler-k\n" -" (lambda ()\n" -" (raise-continuable condition)))\n" -" clause ...))))))))\n" -" (lambda ()\n" -" (call-with-values\n" -" (lambda () e1 e2 ...)\n" -" (lambda args\n" -" (guard-k\n" -" (lambda ()\n" -" (apply values args)))))))))))))\n" -"\n" -" (export guard)\n" -"\n" -" ;; 5.5 Recored-type definitions\n" -"\n" -" (import (picrin record)\n" -" (scheme write))\n" -"\n" -" (define ((default-record-writer ctor) obj)\n" -" (let ((port (open-output-string)))\n" -" (display \"#.(\" port)\n" -" (display (car ctor) port)\n" -" (for-each\n" -" (lambda (field)\n" -" (display \" \" port)\n" -" (write (record-ref obj field) port))\n" -" (cdr ctor))\n" -" (display \")\" port)\n" -" (get-output-string port)))\n" -"\n" -" (define ((boot-make-record-type ) name ctor)\n" -" (let ((rectype (make-record )))\n" -" (record-set! rectype 'name name)\n" -" (record-set! rectype 'writer (default-record-writer ctor))\n" -" rectype))\n" -"\n" -" (define \n" -" (let ((\n" -" ((boot-make-record-type #t) 'record-type '(record-type name writer))))\n" -" (record-set! '@@type )\n" -" ))\n" -"\n" -" (define make-record-type (boot-make-record-type ))\n" -"\n" -" (define-syntax define-record-constructor\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare?)\n" -" (let ((rectype (car (cdr form)))\n" -" (name (car (cdr (cdr form))))\n" -" (fields (cdr (cdr (cdr form)))))\n" -" `(define (,name ,@fields)\n" -" (let ((record (make-record ,rectype)))\n" -" ,@(map (lambda (field)\n" -" `(record-set! record ',field ,field))\n" -" fields)\n" -" record))))))\n" -"\n" -" (define-syntax define-record-predicate\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare?)\n" -" (let ((rectype (car (cdr form)))\n" -" (name (car (cdr (cdr form)))))\n" -" `(define (,name obj)\n" -" (and (record? obj)\n" -" (eq? (record-type obj)\n" -" ,rectype)))))))\n" -"\n" -" (define-syntax define-record-field\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare?)\n" -" (let ((pred (car (cdr form)))\n" -" (field-name (car (cdr (cdr form))))\n" -" (accessor (car (cdr (cdr (cdr form)))))\n" -" (modifier? (cdr (cdr (cdr (cdr form))))))\n" -" (if (null? modifier?)\n" -" `(define (,accessor record)\n" -" (if (,pred record)\n" -" (record-ref record ',field-name)\n" -" (error \"wrong record type\" record)))\n" -" `(begin\n" -" (define (,accessor record)\n" -" (if (,pred record)\n" -" (record-ref record ',field-name)\n" -" (error \"wrong record type\" record)))\n" -" (define (,(car modifier?) record val)\n" -" (if (,pred record)\n" -" (record-set! record ',field-name val)\n" -" (error \"wrong record type\" record)))))))))\n" -"\n" -" (define-syntax define-record-type\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare?)\n" -" (let ((name (car (cdr form)))\n" -" (ctor (car (cdr (cdr form))))\n" -" (pred (car (cdr (cdr (cdr form)))))\n" -" (fields (cdr (cdr (cdr (cdr form))))))\n" -" `(begin\n" -" (define ,name (make-record-type ',name ',ctor))\n" -" (define-record-constructor ,name ,@ctor)\n" -" (define-record-predicate ,name ,pred)\n" -" ,@(map (lambda (field) `(define-record-field ,pred ,@field))\n" -" fields))))))\n" -"\n" -" (export define-record-type)\n" -"\n" -" ;; 6.4 Pairs and lists\n" -"\n" -" (export pair?\n" -" cons\n" -" car\n" -" cdr\n" -" set-car!\n" -" set-cdr!\n" -" null?\n" -" caar\n" -" cadr\n" -" cdar\n" -" cddr\n" -" list?\n" -" make-list\n" -" list\n" -" length\n" -" append\n" -" reverse\n" -" list-tail\n" -" list-ref\n" -" list-set!\n" -" list-copy\n" -" memq\n" -" memv\n" -" member\n" -" assq\n" -" assv\n" -" assoc)\n" -"\n" -" ;; 6.5 Symbols\n" -"\n" -" (export symbol?\n" -" symbol=?\n" -" symbol->string\n" -" string->symbol)\n" -"\n" -" ;; 6.6 Characters\n" -"\n" -" (define-macro (define-char-transitive-predicate name op)\n" -" `(define (,name . cs)\n" -" (apply ,op (map char->integer cs))))\n" -"\n" -" (define-char-transitive-predicate char=? =)\n" -" (define-char-transitive-predicate char? >)\n" -" (define-char-transitive-predicate char<=? <=)\n" -" (define-char-transitive-predicate char>=? >=)\n" -"\n" -" (export char=?\n" -" char?\n" -" char<=?\n" -" char>=?)\n" -"\n" -" ;; 6.7 String\n" -"\n" -" (define (string->list string . opts)\n" -" (let ((start (if (pair? opts) (car opts) 0))\n" -" (end (if (>= (length opts) 2)\n" -" (cadr opts)\n" -" (string-length string))))\n" -" (do ((i start (+ i 1))\n" -" (res '()))\n" -" ((= i end)\n" -" (reverse res))\n" -" (set! res (cons (string-ref string i) res)))))\n" -"\n" -" (define (list->string list)\n" -" (let ((len (length list)))\n" -" (let ((v (make-string len)))\n" -" (do ((i 0 (+ i 1))\n" -" (l list (cdr l)))\n" -" ((= i len)\n" -" v)\n" -" (string-set! v i (car l))))))\n" -"\n" -" (define (string . objs)\n" -" (list->string objs))\n" -"\n" -" (export string string->list list->string)\n" -"\n" -" ;; 6.8. Vector\n" -"\n" -" (define (vector . objs)\n" -" (list->vector objs))\n" -"\n" -" (define (vector->string . args)\n" -" (list->string (apply vector->list args)))\n" -"\n" -" (define (string->vector . args)\n" -" (list->vector (apply string->list args)))\n" -"\n" -" (export vector vector->string string->vector)\n" -"\n" -" ;; 6.9 bytevector\n" -"\n" -" (define (bytevector->list v start end)\n" -" (do ((i start (+ i 1))\n" -" (res '()))\n" -" ((= i end)\n" -" (reverse res))\n" -" (set! res (cons (bytevector-u8-ref v i) res))))\n" -"\n" -" (define (list->bytevector list)\n" -" (let ((len (length list)))\n" -" (let ((v (make-bytevector len)))\n" -" (do ((i 0 (+ i 1))\n" -" (l list (cdr l)))\n" -" ((= i len)\n" -" v)\n" -" (bytevector-u8-set! v i (car l))))))\n" -"\n" -" (define (bytevector . objs)\n" -" (list->bytevector objs))\n" -"\n" -" (define (utf8->string v . opts)\n" -" (let ((start (if (pair? opts) (car opts) 0))\n" -" (end (if (>= (length opts) 2)\n" -" (cadr opts)\n" -" (bytevector-length v))))\n" -" (list->string (map integer->char (bytevector->list v start end)))))\n" -"\n" -" (define (string->utf8 s . opts)\n" -" (let ((start (if (pair? opts) (car opts) 0))\n" -" (end (if (>= (length opts) 2)\n" -" (cadr opts)\n" -" (string-length s))))\n" -" (list->bytevector (map char->integer (string->list s start end)))))\n" -"\n" -" (export bytevector\n" -" bytevector->list\n" -" list->bytevector\n" -" utf8->string\n" -" string->utf8)\n" -"\n" -" ;; 6.10 control features\n" -"\n" -" (define (string-map f . strings)\n" -" (list->string (apply map f (map string->list strings))))\n" -"\n" -" (define (string-for-each f . strings)\n" -" (apply for-each f (map string->list strings)))\n" -"\n" -" (define (vector-map f . vectors)\n" -" (list->vector (apply map f (map vector->list vectors))))\n" -"\n" -" (define (vector-for-each f . vectors)\n" -" (apply for-each f (map vector->list vectors)))\n" -"\n" -" (export string-map string-for-each\n" -" vector-map vector-for-each)\n" -"\n" -" ;; 6.13. Input and output\n" -"\n" -" (define (call-with-port port proc)\n" -" (dynamic-wind\n" -" (lambda () #f)\n" -" (lambda () (proc port))\n" -" (lambda () (close-port port))))\n" -"\n" -" (export call-with-port))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_record = -"(define-library (picrin record)\n" -" (import (scheme base))\n" -"\n" -" (define (define-record-writer* record-type writer)\n" -" (record-set! record-type 'writer writer))\n" -"\n" -" (define-syntax define-record-writer\n" -" (syntax-rules ()\n" -" ((_ (type obj) body ...)\n" -" (define-record-writer* type\n" -" (lambda (obj)\n" -" body ...)))\n" -" ((_ type writer)\n" -" (define-record-writer* type\n" -" writer))))\n" -"\n" -" (export define-record-writer))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_array = -"(define-library (picrin array)\n" -" (import (scheme base)\n" -" (scheme write)\n" -" (picrin record))\n" -"\n" -" (define-record-type \n" -" (create-array data size head tail)\n" -" array?\n" -" (data array-data set-array-data!)\n" -" (size array-size set-array-size!)\n" -" (head array-head set-array-head!)\n" -" (tail array-tail set-array-tail!))\n" -"\n" -" (define (translate ary i)\n" -" (floor-remainder i (array-size ary)))\n" -"\n" -" (define (array-length ary)\n" -" (let ((size (- (array-tail ary) (array-head ary))))\n" -" (translate ary size)))\n" -"\n" -" (define (array-rotate! ary)\n" -" (when (< (array-tail ary) (array-head ary))\n" -" (let ((xs (vector-copy (array-data ary) 0 (array-head ary)))\n" -" (ys (vector-copy (array-data ary) (array-head ary))))\n" -" (set-array-data! ary (vector-append ys xs))\n" -" (set-array-tail! ary (array-length ary))\n" -" (set-array-head! ary 0))))\n" -"\n" -" (define (array-reserve! ary size)\n" -" (set! size (+ size 1)) ; capa == size - 1\n" -" (when (< (array-size ary) size)\n" -" (array-rotate! ary)\n" -" (set-array-data! ary (vector-append\n" -" (array-data ary)\n" -" (make-vector (- size (array-size ary)))))\n" -" (set-array-size! ary size)))\n" -"\n" -" (define (make-array . rest)\n" -" (if (null? rest)\n" -" (make-array 0)\n" -" (let ((capacity (car rest))\n" -" (ary (create-array (vector) 0 0 0)))\n" -" (array-reserve! ary capacity)\n" -" ary)))\n" -"\n" -" (define (array-ref ary i)\n" -" (let ((data (array-data ary)))\n" -" (vector-ref data (translate ary (+ (array-head ary) i)))))\n" -"\n" -" (define (array-set! ary i obj)\n" -" (let ((data (array-data ary)))\n" -" (vector-set! data (translate ary (+ (array-head ary) i)) obj)))\n" -"\n" -" (define (array-push! ary obj)\n" -" (array-reserve! ary (+ (array-length ary) 1))\n" -" (array-set! ary (array-length ary) obj)\n" -" (set-array-tail! ary (translate ary (+ (array-tail ary) 1))))\n" -"\n" -" (define (array-pop! ary)\n" -" (set-array-tail! ary (translate ary (- (array-tail ary) 1)))\n" -" (array-ref ary (array-length ary)))\n" -"\n" -" (define (array-shift! ary)\n" -" (set-array-head! ary (translate ary (+ (array-head ary) 1)))\n" -" (array-ref ary -1))\n" -"\n" -" (define (array-unshift! ary obj)\n" -" (array-reserve! ary (+ (array-length ary) 1))\n" -" (array-set! ary -1 obj)\n" -" (set-array-head! ary (translate ary (- (array-head ary) 1))))\n" -"\n" -" (define (array->list ary)\n" -" (do ((i 0 (+ i 1))\n" -" (x '() (cons (array-ref ary i) x)))\n" -" ((= i (array-length ary))\n" -" (reverse x))))\n" -"\n" -" (define (list->array list)\n" -" (let ((ary (make-array)))\n" -" (for-each (lambda (x) (array-push! ary x)) list)\n" -" ary))\n" -"\n" -" (define (array . objs)\n" -" (list->array objs))\n" -"\n" -" (define (array-map proc ary)\n" -" (list->array (map proc (array->list ary))))\n" -"\n" -" (define (array-for-each proc ary)\n" -" (for-each proc (array->list ary)))\n" -"\n" -" (define-record-writer ( array)\n" -" (call-with-port (open-output-string)\n" -" (lambda (port)\n" -" (display \"#.(array\" port)\n" -" (array-for-each\n" -" (lambda (obj)\n" -" (display \" \" port)\n" -" (write obj port))\n" -" array)\n" -" (display \")\" port)\n" -" (get-output-string port))))\n" -"\n" -" (export make-array\n" -" array\n" -" array?\n" -" array-length\n" -" array-ref\n" -" array-set!\n" -" array-push!\n" -" array-pop!\n" -" array-shift!\n" -" array-unshift!\n" -" array-map\n" -" array-for-each\n" -" array->list\n" -" list->array))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_dictionary = -"(define-library (picrin dictionary)\n" -" (import (scheme base))\n" -"\n" -" (define (dictionary-map proc dict)\n" -" (let ((kvs '()))\n" -" (dictionary-for-each\n" -" (lambda (key val)\n" -" (set! kvs (cons (proc key val) kvs)))\n" -" dict)\n" -" (reverse kvs)))\n" -"\n" -" (define (dictionary->plist dict)\n" -" (let ((kvs '()))\n" -" (dictionary-for-each\n" -" (lambda (key val)\n" -" (set! kvs (cons val (cons key kvs))))\n" -" dict)\n" -" (reverse kvs)))\n" -"\n" -" (define (plist->dictionary plist)\n" -" (let ((dict (make-dictionary)))\n" -" (do ((kv plist (cddr kv)))\n" -" ((null? kv)\n" -" dict)\n" -" (dictionary-set! dict (car kv) (cadr kv)))))\n" -"\n" -" (define (dictionary->alist dict)\n" -" (dictionary-map\n" -" (lambda (key val)\n" -" (cons key val))\n" -" dict))\n" -"\n" -" (define (alist->dictionary alist)\n" -" (let ((dict (make-dictionary)))\n" -" (do ((kv alist (cdr kv)))\n" -" ((null? kv)\n" -" dict)\n" -" (dictionary-set! dict (car kv) (cdr kv)))))\n" -"\n" -" (define (dictionary . plist)\n" -" (plist->dictionary plist))\n" -"\n" -" (export dictionary\n" -" dictionary-map\n" -" dictionary->plist\n" -" plist->dictionary\n" -" dictionary->alist\n" -" alist->dictionary))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_test = -"(define-library (picrin test)\n" -" (import (scheme base)\n" -" (scheme write)\n" -" (scheme read)\n" -" (scheme process-context))\n" -" (define test-counter 0)\n" -" (define counter 0)\n" -" (define failure-counter 0)\n" -"\n" -" (define fails '())\n" -"\n" -" (define (print-statistics)\n" -" (newline)\n" -" (display \"Test Result: \")\n" -" (write (- counter failure-counter))\n" -" (display \" / \")\n" -" (write counter)\n" -" (display \" (\")\n" -" (write (* (/ (- counter failure-counter) counter) 100))\n" -" (display \"%)\")\n" -" (display \" [PASS/TOTAL]\")\n" -" (display \"\")\n" -" (newline)\n" -" (for-each\n" -" (lambda (fail)\n" -" (display fail))\n" -" (reverse fails)))\n" -"\n" -" (define (test-begin . o)\n" -" (set! test-counter (+ test-counter 1)))\n" -"\n" -" (define (test-end . o)\n" -" (set! test-counter (- test-counter 1))\n" -" (if (= test-counter 0)\n" -" (print-statistics)))\n" -"\n" -" (define-syntax test\n" -" (syntax-rules ()\n" -" ((test expected expr)\n" -" (let ((res expr))\n" -" (display \"case \")\n" -" (write counter)\n" -" (cond\n" -" ((equal? res expected)\n" -" (display \" PASS: \")\n" -" (write 'expr)\n" -" (display \" equals \")\n" -" (write expected)\n" -" (display \"\")\n" -" (newline)\n" -" )\n" -" ((not (equal? res expected))\n" -" (set! failure-counter (+ failure-counter 1))\n" -" (let ((out (open-output-string)))\n" -" (display \" FAIL: \" out)\n" -" (write 'expr out)\n" -" (newline out)\n" -" (display \" expected \" out)\n" -" (write expected out)\n" -" (display \" but got \" out)\n" -" (write res out)\n" -" (display \"\" out)\n" -" (newline out)\n" -" (let ((str (get-output-string out)))\n" -" (set! fails (cons str fails))\n" -" (display str)))))\n" -" (set! counter (+ counter 1))))))\n" -"\n" -" (define-syntax test-values\n" -" (syntax-rules ()\n" -" ((_ expect expr)\n" -" (test (call-with-values (lambda () expect) (lambda results results))\n" -" (call-with-values (lambda () expr) (lambda results results))))))\n" -"\n" -"\n" -" (define (test-failure-count)\n" -" (length fails))\n" -"\n" -" (define (test-exit)\n" -" (exit (zero? (test-failure-count))))\n" -"\n" -" (define-syntax test-syntax-error\n" -" (syntax-rules ()\n" -" ((_) (syntax-error \"invalid use of test-syntax-error\"))))\n" -"\n" -" (export test test-begin test-end test-values test-exit test-syntax-error))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_experimental_lambda = -"(define-library (picrin experimental lambda)\n" -" (import (scheme base)\n" -" (picrin macro))\n" -"\n" -" (define-syntax destructuring-bind\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare)\n" -" (let ((formal (car (cdr form)))\n" -" (value (car (cdr (cdr form))))\n" -" (body (cdr (cdr (cdr form)))))\n" -" (cond\n" -" ((symbol? formal)\n" -" `(let ((,formal ,value))\n" -" ,@body))\n" -" ((pair? formal)\n" -" `(let ((value# ,value))\n" -" (destructuring-bind ,(car formal) (car value#)\n" -" (destructuring-bind ,(cdr formal) (cdr value#)\n" -" ,@body))))\n" -" ((vector? formal)\n" -" ;; TODO\n" -" (error \"fixme\"))\n" -" (else\n" -" `(if (equal? ,value ',formal)\n" -" (begin\n" -" ,@body)\n" -" (error \"match failure\" ,value ',formal))))))))\n" -"\n" -" (define-syntax destructuring-lambda\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare)\n" -" (let ((args (car (cdr form)))\n" -" (body (cdr (cdr form))))\n" -" `(lambda formal# (destructuring-bind ,args formal# ,@body))))))\n" -"\n" -" (define-syntax destructuring-define\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare)\n" -" (let ((maybe-formal (cadr form)))\n" -" (if (symbol? maybe-formal)\n" -" `(define ,@(cdr form))\n" -" `(destructuring-define ,(car maybe-formal)\n" -" (destructuring-lambda ,(cdr maybe-formal)\n" -" ,@(cddr form))))))))\n" -"\n" -" (export (rename destructuring-bind bind)\n" -" (rename destructuring-lambda lambda)\n" -" (rename destructuring-define define)))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_promise = -"(define-library (picrin promise)\n" -" (import (scheme base)\n" -" (picrin experimental lambda))\n" -"\n" -" (define (identity x)\n" -" x)\n" -"\n" -" (define-record-type \n" -" (create-promise status reactors cache)\n" -" promise?\n" -" (status promise-status set-promise-status!)\n" -" (reactors promise-reactors set-promise-reactors!)\n" -" (cache promise-cache set-promise-cache!))\n" -"\n" -" (define (push-promise-reactor! promise reactor)\n" -" (set-promise-reactors! promise (cons reactor (promise-reactors promise))))\n" -"\n" -" #;\n" -" (define (print x)\n" -" (write x)\n" -" (newline)\n" -" (flush-output-port)\n" -" x)\n" -"\n" -" (define (make-promise handler)\n" -" (let ((self (create-promise 'pending '() #f)))\n" -"\n" -" (define (on-resolved result)\n" -" (when (eq? (promise-status self) 'pending)\n" -" (for-each\n" -" (lambda (((resolve . reject) on-resolved _))\n" -" (call/cc\n" -" (lambda (exit)\n" -" (with-exception-handler\n" -" (lambda (e)\n" -" (reject e)\n" -" (exit #f))\n" -" (lambda ()\n" -" (resolve (on-resolved result)))))))\n" -" (promise-reactors self))\n" -" (set-promise-status! self 'resolved)\n" -" (set-promise-cache! self result)\n" -" (set-promise-reactors! self '())))\n" -"\n" -" (define (on-rejected reason)\n" -" (when (eq? (promise-status 'pending) 'pending)\n" -" (for-each\n" -" (lambda (((resolve . reject) _ on-rejected))\n" -" (call/cc\n" -" (lambda (exit)\n" -" (with-exception-handler\n" -" (lambda (e)\n" -" (reject e)\n" -" (exit #f))\n" -" (lambda ()\n" -" (resolve (on-rejected reason)))))))\n" -" (promise-reactors self))\n" -" (set-promise-status! self 'rejected)\n" -" (set-promise-cache! self reason)\n" -" (set-promise-reactors! self '())))\n" -"\n" -" (handler on-resolved on-rejected)\n" -"\n" -" self))\n" -"\n" -" (define (promise-chain self on-resolved on-rejected)\n" -"\n" -" (define (handler resolve reject)\n" -" (case (promise-status self)\n" -" (pending\n" -" (push-promise-reactor! self `((,resolve . ,reject) ,on-resolved ,on-rejected)))\n" -" (resolved\n" -" (call/cc\n" -" (lambda (exit)\n" -" (with-exception-handler\n" -" (lambda (e)\n" -" (reject e)\n" -" (exit #f))\n" -" (lambda ()\n" -" (resolve (on-resolved (promise-cache self))))))))\n" -" (rejected\n" -" (call/cc\n" -" (lambda (exit)\n" -" (with-exception-handler\n" -" (lambda (e)\n" -" (reject e)\n" -" (exit #f))\n" -" (lambda ()\n" -" (resolve (on-rejected (promise-cache self))))))))))\n" -"\n" -" (make-promise handler))\n" -"\n" -" (define (promise-then self on-resolved)\n" -" (promise-chain self on-resolved identity))\n" -"\n" -" (define (promise-else self on-rejected)\n" -" (promise-chain self identity on-rejected))\n" -"\n" -" (define (promise-all promises)\n" -"\n" -" (define (handler resolve reject)\n" -" (do ((i 0 (+ i 1))\n" -" (x promises (cdr x))\n" -" (c 0)\n" -" (v (make-vector (length promises))))\n" -" ((null? x))\n" -"\n" -" (define (on-resolved result)\n" -" (vector-set! v i result)\n" -" (set! c (+ c 1))\n" -" (when (= c (length promises))\n" -" (resolve (vector->list v))))\n" -"\n" -" (define (on-rejected reason)\n" -" (reject reason))\n" -"\n" -" (promise-chain (car x) on-resolved on-rejected)))\n" -"\n" -" (make-promise handler))\n" -"\n" -" (define (promise-any promises)\n" -"\n" -" (define (handler resolve reject)\n" -" (do ((i 0 (+ i 1))\n" -" (x promises (cdr x))\n" -" (c 0)\n" -" (v (make-vector (length promises))))\n" -" ((null? x))\n" -"\n" -" (define (on-resolved result)\n" -" (resolve result))\n" -"\n" -" (define (on-rejected reason)\n" -" (vector-set! v i reason)\n" -" (set! c (+ c 1))\n" -" (when (= c (length promises))\n" -" (reject (vector->list v))))\n" -"\n" -" (promise-chain (car x) on-resolved on-rejected)))\n" -"\n" -" (make-promise handler))\n" -"\n" -" ; experimental API\n" -" (define (promise-race promises)\n" -" (make-promise\n" -" (lambda (resolve reject)\n" -" (for-each\n" -" (lambda (x)\n" -" (promise-chain x resolve reject))\n" -" promises))))\n" -"\n" -" (export promise?\n" -" make-promise\n" -" promise-then\n" -" promise-else\n" -" promise-all\n" -" promise-any))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_async = -"(define-library (picrin async)\n" -" (import (scheme base)\n" -" (picrin promise))\n" -"\n" -" (define (async-timer ms)\n" -" (make-promise\n" -" (lambda (resolve reject)\n" -" (set-timeout\n" -" (lambda ()\n" -" (resolve #t))\n" -" ms))))\n" -"\n" -" (export async-timer))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_cxr = -";;; Appendix A. Standard Libraries CxR\n" -"\n" -"(define-library (scheme cxr)\n" -" (import (scheme base))\n" -"\n" -" (define (caaar p) (car (caar p)))\n" -" (define (caadr p) (car (cadr p)))\n" -" (define (cadar p) (car (cdar p)))\n" -" (define (caddr p) (car (cddr p)))\n" -" (define (cdaar p) (cdr (caar p)))\n" -" (define (cdadr p) (cdr (cadr p)))\n" -" (define (cddar p) (cdr (cdar p)))\n" -" (define (cdddr p) (cdr (cddr p)))\n" -" (define (caaaar p) (caar (caar p)))\n" -" (define (caaadr p) (caar (cadr p)))\n" -" (define (caadar p) (caar (cdar p)))\n" -" (define (caaddr p) (caar (cddr p)))\n" -" (define (cadaar p) (cadr (caar p)))\n" -" (define (cadadr p) (cadr (cadr p)))\n" -" (define (caddar p) (cadr (cdar p)))\n" -" (define (cadddr p) (cadr (cddr p)))\n" -" (define (cdaaar p) (cdar (caar p)))\n" -" (define (cdaadr p) (cdar (cadr p)))\n" -" (define (cdadar p) (cdar (cdar p)))\n" -" (define (cdaddr p) (cdar (cddr p)))\n" -" (define (cddaar p) (cddr (caar p)))\n" -" (define (cddadr p) (cddr (cadr p)))\n" -" (define (cdddar p) (cddr (cdar p)))\n" -" (define (cddddr p) (cddr (cddr p)))\n" -"\n" -" (export caaar caadr cadar caddr\n" -" cdaar cdadr cddar cdddr\n" -" caaaar caaadr caadar caaddr\n" -" cadaar cadadr caddar cadddr\n" -" cdaaar cdaadr cdadar cdaddr\n" -" cddaar cddadr cdddar cddddr))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_file = -"(define-library (scheme file)\n" -" (import (scheme base))\n" -"\n" -" (define (call-with-input-file filename callback)\n" -" (call-with-port (open-input-file filename) callback))\n" -"\n" -" (define (call-with-output-file filename callback)\n" -" (call-with-port (open-output-file filename) callback))\n" -"\n" -" (define (with-input-from-file filename thunk)\n" -" (call-with-input-file filename\n" -" (lambda (port)\n" -" (parameterize ((current-input-port port))\n" -" (thunk)))))\n" -"\n" -" (define (with-output-to-file filename thunk)\n" -" (call-with-output-file filename\n" -" (lambda (port)\n" -" (parameterize ((current-output-port port))\n" -" (thunk)))))\n" -"\n" -" (export call-with-input-file\n" -" call-with-output-file\n" -" with-input-from-file\n" -" with-output-to-file))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_case_lambda = -"(define-library (scheme case-lambda)\n" -" (import (scheme base))\n" -"\n" -" (define-syntax case-lambda\n" -" (syntax-rules ()\n" -" ((case-lambda (params body0 ...) ...)\n" -" (lambda args\n" -" (let ((len (length args)))\n" -" (letrec-syntax\n" -" ((cl (syntax-rules ::: ()\n" -" ((cl)\n" -" (error \"no matching clause\"))\n" -" ((cl ((p :::) . body) . rest)\n" -" (if (= len (length '(p :::)))\n" -" (apply (lambda (p :::)\n" -" . body)\n" -" args)\n" -" (cl . rest)))\n" -" ((cl ((p ::: . tail) . body)\n" -" . rest)\n" -" (if (>= len (length '(p :::)))\n" -" (apply\n" -" (lambda (p ::: . tail)\n" -" . body)\n" -" args)\n" -" (cl . rest))))))\n" -" (cl (params body0 ...) ...)))))))\n" -"\n" -" (export case-lambda))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_lazy = -";;; Appendix A. Standard Libraries Lazy\n" -"\n" -"(define-library (scheme lazy)\n" -" (import (scheme base)\n" -" (picrin macro))\n" -"\n" -" (define-record-type \n" -" (make-promise% done obj)\n" -" promise?\n" -" (done promise-done? promise-done!)\n" -" (obj promise-value promise-value!))\n" -"\n" -" (define-syntax delay-force\n" -" (ir-macro-transformer\n" -" (lambda (form rename compare?)\n" -" (let ((expr (cadr form)))\n" -" `(make-promise% #f (lambda () ,expr))))))\n" -"\n" -" (define-syntax delay\n" -" (ir-macro-transformer\n" -" (lambda (form rename compare?)\n" -" (let ((expr (cadr form)))\n" -" `(delay-force (make-promise% #t ,expr))))))\n" -"\n" -" (define (promise-update! new old)\n" -" (promise-done! old (promise-done? new))\n" -" (promise-value! old (promise-value new)))\n" -"\n" -" (define (force promise)\n" -" (if (promise-done? promise)\n" -" (promise-value promise)\n" -" (let ((promise* ((promise-value promise))))\n" -" (unless (promise-done? promise)\n" -" (promise-update! promise* promise))\n" -" (force promise))))\n" -"\n" -" (define (make-promise obj)\n" -" (if (promise? obj)\n" -" obj\n" -" (make-promise% #t obj)))\n" -"\n" -" (export delay-force delay force make-promise promise?))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_eval = -"(define-library (scheme eval)\n" -" (import (scheme base))\n" -"\n" -" (define (null-environment n)\n" -" (if (not (= n 5))\n" -" (error \"unsupported environment version\" n)\n" -" '(scheme null)))\n" -"\n" -" (define (scheme-report-environment n)\n" -" (if (not (= n 5))\n" -" (error \"unsupported environment version\" n)\n" -" '(scheme r5rs)))\n" -"\n" -" (define environment\n" -" (let ((counter 0))\n" -" (lambda specs\n" -" (let ((library-name `(picrin @@my-environment ,counter)))\n" -" (set! counter (+ counter 1))\n" -" (eval\n" -" `(define-library ,library-name\n" -" ,@(map (lambda (spec)\n" -" `(import ,spec))\n" -" specs))\n" -" '(scheme base))\n" -" library-name))))\n" -"\n" -" (export null-environment\n" -" scheme-report-environment\n" -" environment))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_r5rs = -"(define-library (scheme r5rs)\n" -" (import (scheme base)\n" -" (scheme inexact)\n" -" (scheme write)\n" -" (scheme read)\n" -" (scheme file)\n" -" (scheme cxr)\n" -" (scheme lazy)\n" -" (scheme eval)\n" -" (scheme load))\n" -"\n" -" (export * + - / < <= = > >=\n" -" abs acos and\n" -" ;; angle\n" -" append apply asin assoc assq assv atan\n" -" begin boolean?\n" -" caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr\n" -" call-with-current-continuation\n" -" call-with-input-file\n" -" call-with-output-file\n" -" call-with-values\n" -" car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr\n" -" ceiling\n" -" ;; char->integer char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char=? char>? char?\n" -" close-input-port close-output-port complex? cond cons cos current-input-port current-output-port\n" -" define define-syntax delay\n" -" ;; denominator\n" -" display do dynamic-wind\n" -" eof-object? eq? equal? eqv? eval even?\n" -" (rename inexact exact->inexact)\n" -" exact? exp expt\n" -" floor for-each force\n" -" gcd\n" -" if\n" -" ;; imag-part\n" -" (rename exact inexact->exact)\n" -" inexact? input-port? integer->char integer?\n" -" ;; interaction-environment\n" -" lambda lcm length let\n" -" peek-char procedure?\n" -" quote\n" -" rational? read\n" -" ;; real-part\n" -" remainder round\n" -" scheme-report-environment\n" -" set! set-cdr! sqrt string->list string->symbol\n" -" ;; string-ci<=? string-ci=? string-ci>?\n" -" string-fill! string-ref string<=? string=? string>? substring symbol?\n" -" truncate\n" -" vector vector-fill! vector-ref vector? with-output-to-file write-char\n" -" output-port?\n" -" let-syntax\n" -" letrec-syntax\n" -" list->string\n" -" list-ref\n" -" list?\n" -" log\n" -" ;; make-polar\n" -" make-string\n" -" map\n" -" member\n" -" memv\n" -" modulo\n" -" newline\n" -" null-environment\n" -" number->string\n" -" ;; numerator\n" -" open-input-file\n" -" or\n" -" pair?\n" -" positive?\n" -" quasiquote\n" -" quotient\n" -" ;; rationalize\n" -" read-char\n" -" real?\n" -" reverse\n" -" let*\n" -" letrec\n" -" list\n" -" list->vector\n" -" list-tail\n" -" load\n" -" ;; magnitude\n" -" ;; make-rectangular\n" -" make-vector\n" -" max\n" -" memq\n" -" min\n" -" negative?\n" -" not\n" -" null?\n" -" number?\n" -" odd?\n" -" open-output-file\n" -" set-car!\n" -" sin\n" -" string\n" -" string->number\n" -" string-append\n" -" ;; string-ci=?\n" -" string-copy\n" -" string-length\n" -" string-set!\n" -" string=?\n" -" string?\n" -" symbol->string\n" -" tan\n" -" values\n" -" vector->list\n" -" vector-length\n" -" vector-set!\n" -" with-input-from-file\n" -" write\n" -" zero?\n" -" ))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_null = -"(define-library (scheme null)\n" -" (import (scheme base))\n" -" (export define\n" -" lambda\n" -" if\n" -" quote\n" -" quasiquote\n" -" unquote\n" -" unquote-splicing\n" -" begin\n" -" set!\n" -" define-syntax))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_1 = -"(define-library (srfi 1)\n" -" (import (scheme base)\n" -" (scheme cxr))\n" -"\n" -" ;; # Constructors\n" -" ;; cons list\n" -" ;; xcons cons* make-list list-tabulate\n" -" ;; list-copy circular-list iota\n" -" (define (xcons a b)\n" -" (cons b a))\n" -"\n" -" ;; means for inter-referential definition\n" -" (define append-reverse #f)\n" -"\n" -" (define (cons* x . args)\n" -" (let rec ((acc '()) (x x) (lst args))\n" -" (if (null? lst)\n" -" (append-reverse acc x)\n" -" (rec (cons x acc) (car lst) (cdr lst)))))\n" -"\n" -" (define (list-tabulate n init-proc)\n" -" (let rec ((acc '()) (n (- n 1)))\n" -" (if (zero? n)\n" -" (cons n acc)\n" -" (rec (cons n acc) (- n 1)))))\n" -"\n" -" (define (circular-list elt . args)\n" -" (let ((lst (cons elt args)))\n" -" (let rec ((l lst))\n" -" (if (null? (cdr l))\n" -" (set-cdr! l lst)\n" -" (rec (cdr l))))\n" -" lst))\n" -"\n" -" (define (iota count . lst)\n" -" (let ((start (if (pair? lst) (car lst) 0))\n" -" (step (if (and (pair? lst) (pair? (cdr lst)))\n" -" (cadr lst) 1)))\n" -" (let rec ((count (- count 1)) (acc '()))\n" -" (if (zero? count)\n" -" (cons start acc)\n" -" (rec (- count 1)\n" -" (cons (+ start (* count step)) acc))))))\n" -"\n" -" (export cons list xcons make-list list-tabulate list-copy circular-list iota)\n" -"\n" -" ;; # Predicates\n" -" ;; pair? null?\n" -" ;; proper-list? circular-list? dotted-list?\n" -" ;; not-pair? null-list?\n" -" ;; list=\n" -" (define (not-pair? x)\n" -" (not (pair? x)))\n" -" ;; detects circular list using Floyd's cycle-finding algorithm\n" -" (define (circular-list? x)\n" -" (let rec ((rapid x) (local x))\n" -" (if (and (pair? rapid) (pair? (cdr rapid)))\n" -" (if (eq? (cddr rapid) (cdr local))\n" -" #t\n" -" (rec (cddr rapid) (cdr local)))\n" -" #f)))\n" -"\n" -" (define proper-list? list?)\n" -"\n" -" (define (dotted-list? x)\n" -" (and (pair? x)\n" -" (not (proper-list? x))\n" -" (not (circular-list? x))))\n" -"\n" -" (define (null-list? x)\n" -" (cond ((pair? x) #f)\n" -" ((null? x) #t)\n" -" (else (error \"null-list?: argument out of domain\" x))))\n" -"\n" -" (define (list= elt= . lists)\n" -" (or (null? lists)\n" -" (let rec1 ((list1 (car lists)) (others (cdr lists)))\n" -" (or (null? others)\n" -" (let ((list2 (car others))\n" -" (others (cdr others)))\n" -" (if (eq? list1 list2)\n" -" (rec1 list2 others)\n" -" (let rec2 ((l1 list1) (l2 list2))\n" -" (if (null-list? l1)\n" -" (and (null-list? l2)\n" -" (rec1 list2 others))\n" -" (and (not (null-list? l2))\n" -" (elt= (car l1) (car l2))\n" -" (rec2 (cdr l1) (cdr l2)))))))))))\n" -"\n" -" (export pair? null? not-pair? proper-list? circular-list? null-list? list=)\n" -"\n" -" ;; # Selectors\n" -" ;; car cdr ... cddadr cddddr list-ref\n" -" ;; first second third fourth fifth sixth seventh eighth ninth tenth\n" -" ;; car+cdr\n" -" ;; take drop\n" -" ;; take-right drop-right\n" -" ;; take! drop-right!\n" -" ;; split-at split-at!\n" -" ;; last last-pair\n" -" (define (car+cdr pair)\n" -" (values (car pair) (cdr pair)))\n" -"\n" -" (define (take x i)\n" -" (if (zero? i)\n" -" '()\n" -" (cons (car x)\n" -" (take (cdr x) (- i 1)))))\n" -"\n" -" (define (drop x i)\n" -" (if (zero? i)\n" -" x\n" -" (drop (cdr x) (- i 1))))\n" -"\n" -" (define (take-right flist i)\n" -" (let ((len (length flist)))\n" -" (drop flist (- len i))))\n" -"\n" -" (define (drop-right flist i)\n" -" (let ((len (length flist)))\n" -" (take flist (- len i))))\n" -"\n" -" (define (take! x i)\n" -" (let rec ((lis x) (n (- i 1)))\n" -" (if (zero? n)\n" -" (begin (set-cdr! lis '()) x)\n" -" (rec (cdr lis) (- n 1)))))\n" -"\n" -" (define (drop-right! flist i)\n" -" (let ((lead (drop flist i)))\n" -" (if (not-pair? lead)\n" -" '()\n" -" (let rec ((lis1 flist) (lis2 (cdr lead)))\n" -" (if (pair? lis2)\n" -" (rec (cdr lis1) (cdr lis2))\n" -" (begin (set-cdr! lis1 '()) flist))))))\n" -"\n" -" (define (split-at x i)\n" -" (values (take x i) (drop x i)))\n" -"\n" -" (define (split-at! x i)\n" -" (values (take! x i) (drop x i)))\n" -"\n" -" (define (last pair)\n" -" (car (take-right pair 1)))\n" -"\n" -" (define (last-pair pair)\n" -" (take-right pair 1))\n" -"\n" -" (define first car)\n" -" (define second cadr)\n" -" (define third caddr)\n" -" (define fourth cadddr)\n" -" (define (fifth pair)\n" -" (list-ref pair 4))\n" -" (define (sixth pair)\n" -" (list-ref pair 5))\n" -" (define (seventh pair)\n" -" (list-ref pair 6))\n" -" (define (eighth pair)\n" -" (list-ref pair 7))\n" -" (define (ninth pair)\n" -" (list-ref pair 8))\n" -" (define (tenth pair)\n" -" (list-ref pair 9))\n" -"\n" -"\n" -" (export car cdr car+cdr list-ref\n" -" caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr\n" -" caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr\n" -" cdadar cdaddr cddaar cddadr cdddar cddddr\n" -" first second third fourth fifth sixth seventh eighth ninth tenth\n" -" take drop take-right drop-right take! drop-right!\n" -" split-at split-at! last last-pair)\n" -"\n" -" ;; # Miscellaneous\n" -" ;; length length+\n" -" ;; append concatenate reverse\n" -" ;; append! concatenate! reverse!\n" -" ;; append-reverse append-reverse!\n" -" ;; zip unzip1 unzip2 unzip3 unzip4 unzip5\n" -" ;; count\n" -" (define (length+ lst)\n" -" (if (not (circular-list? lst))\n" -" (length lst)))\n" -"\n" -" (define (concatenate lists)\n" -" (apply append lists))\n" -"\n" -" (define (append! . lists)\n" -" (if (null? lists)\n" -" '()\n" -" (let rec ((lst lists))\n" -" (if (not-pair? (cdr lst))\n" -" (car lst)\n" -" (begin (set-cdr! (last-pair (car lst)) (cdr lst))\n" -" (rec (cdr lst)))))))\n" -"\n" -" (define (concatenate! lists)\n" -" (apply append! lists))\n" -"\n" -" (define (reverse! list)\n" -" (let rec ((lst list) (acc '()))\n" -" (if (null? lst)\n" -" acc\n" -" (let ((rst (cdr lst)))\n" -" (set-cdr! lst acc)\n" -" (rec rst lst)))))\n" -"\n" -" (set! append-reverse\n" -" (lambda (rev-head tail)\n" -" (if (null? rev-head)\n" -" tail\n" -" (append-reverse (cdr rev-head) (cons (car rev-head) tail)))))\n" -"\n" -" (define (append-reverse! rev-head tail)\n" -" (let ((rst (cdr rev-head)))\n" -" (if (null? rev-head)\n" -" tail\n" -" (begin (set-cdr! rev-head tail)\n" -" (append-reverse! rst rev-head)))))\n" -"\n" -" (define (zip . lists)\n" -" (apply map list lists))\n" -"\n" -" (define (unzip1 list)\n" -" (map first list))\n" -"\n" -" (define (unzip2 list)\n" -" (values (map first list)\n" -" (map second list)))\n" -"\n" -" (define (unzip3 list)\n" -" (values (map first list)\n" -" (map second list)\n" -" (map third list)))\n" -"\n" -" (define (unzip4 list)\n" -" (values (map first list)\n" -" (map second list)\n" -" (map third list)\n" -" (map fourth list)))\n" -"\n" -" (define (unzip5 list)\n" -" (values (map first list)\n" -" (map second list)\n" -" (map third list)\n" -" (map fourth list)\n" -" (map fifth list)))\n" -"\n" -" (define (count pred . clists)\n" -" (let rec ((tflst (apply map pred clists)) (n 0))\n" -" (if (null? tflst)\n" -" n\n" -" (rec (cdr tflst) (if (car tflst) (+ n 1) n)))))\n" -"\n" -" (export length length+\n" -" append append! concatenate concatenate!\n" -" reverse reverse! append-reverse append-reverse!\n" -" zip unzip1 unzip2 unzip3 unzip4 unzip5\n" -" count)\n" -"\n" -" ;; # Fold, unfold & map\n" -" ;; map for-each\n" -" ;; fold unfold pair-fold reduce\n" -" ;; fold-right unfold-right pair-fold right reduce-right\n" -" ;; append-map append-map!\n" -" ;; map! pair-for-each filter-map map-in-order\n" -"\n" -" ;; means for inter-referential definition\n" -" (define every #f)\n" -"\n" -" (define (fold kons knil clist . clists)\n" -" (if (null? clists)\n" -" (let rec ((acc knil) (clist clist))\n" -" (if (null? clist)\n" -" acc\n" -" (rec (kons (car clist) acc) (cdr clist))))\n" -" (let rec ((acc knil) (clists (cons clist clists)))\n" -" (if (every pair? clists)\n" -" (rec (apply kons (append (map car clists) (list acc)))\n" -" (map cdr clists))\n" -" acc))))\n" -"\n" -" (define (fold-right kons knil clist . clists)\n" -" (if (null? clists)\n" -" (let rec ((clist clist) (cont values))\n" -" (if (null? clist)\n" -" (cont knil)\n" -" (rec (cdr clist) (lambda (x) (cont (kons (car clist) x))))))\n" -" (let rec ((clists (cons clist clists)) (cont values))\n" -" (if (every pair? clists)\n" -" (rec (map cdr clists)\n" -" (lambda (x)\n" -" (cont (apply kons (append (map car clists) (list x))))))\n" -" (cont knil)))))\n" -"\n" -" (define (pair-fold kons knil clist . clists)\n" -" (if (null? clists)\n" -" (let rec ((acc knil) (clist clist))\n" -" (if (null? clist)\n" -" acc\n" -" (let ((tail (cdr clist)))\n" -" (rec (kons clist acc) tail))))\n" -" (let rec ((acc knil) (clists (cons clist clists)))\n" -" (if (every pair? clists)\n" -" (let ((tail (map cdr clists)))\n" -" (rec (apply kons (append clists (list acc)))\n" -" tail))\n" -" acc))))\n" -"\n" -" (define (pair-fold-right kons knil clist . clists)\n" -" (if (null? clists)\n" -" (let rec ((clist clist) (cont values))\n" -" (if (null? clist)\n" -" (cont knil)\n" -" (let ((tail (map cdr clists)))\n" -" (rec tail (lambda (x) (cont (kons clist x)))))))\n" -" (let rec ((clists (cons clist clists)) (cont values))\n" -" (if (every pair? clists)\n" -" (let ((tail (map cdr clists)))\n" -" (rec tail\n" -" (lambda (x)\n" -" (cont (apply kons (append clists (list x)))))))\n" -" (cont knil)))))\n" -"\n" -" (define (reduce f ridentity list)\n" -" (if (null? list)\n" -" ridentity\n" -" (fold f (car list) (cdr list))))\n" -"\n" -" (define (reduce-right f ridentity list)\n" -" (fold-right f ridentity list))\n" -"\n" -" (define (unfold p f g seed . tail-gen)\n" -" (let ((tail-gen (if (null? tail-gen)\n" -" (lambda (x) '())\n" -" (car tail-gen))))\n" -" (let rec ((seed seed) (cont values))\n" -" (if (p seed)\n" -" (cont (tail-gen seed))\n" -" (rec (g seed) (lambda (x) (cont (cons (f seed) x))))))))\n" -"\n" -" (define (unfold-right p f g seed . tail)\n" -" (let rec ((seed seed) (lst tail))\n" -" (if (p seed)\n" -" lst\n" -" (rec (g seed) (cons (f seed) lst)))))\n" -"\n" -" (define (append-map f . clists)\n" -" (apply append (apply map f clists)))\n" -"\n" -" (define (append-map! f . clists)\n" -" (apply append! (apply map f clists)))\n" -"\n" -" (define (pair-for-each f clist . clists)\n" -" (if (null? clist)\n" -" (let rec ((clist clist))\n" -" (if (pair? clist)\n" -" (begin (f clist) (rec (cdr clist)))))\n" -" (let rec ((clists (cons clist clists)))\n" -" (if (every pair? clists)\n" -" (begin (apply f clists) (rec (map cdr clists)))))))\n" -"\n" -" (define (map! f list . lists)\n" -" (if (null? lists)\n" -" (pair-for-each (lambda (x) (set-car! x (f (car x)))) list)\n" -" (let rec ((list list) (lists lists))\n" -" (if (pair? list)\n" -" (let ((head (map car lists))\n" -" (rest (map cdr lists)))\n" -" (set-car! list (apply f (car list) head))\n" -" (rec (cdr list) rest)))))\n" -" list)\n" -"\n" -" (define (map-in-order f clist . clists)\n" -" (if (null? clists)\n" -" (let rec ((clist clist) (acc '()))\n" -" (if (null? clist)\n" -" (reverse! acc)\n" -" (rec (cdr clist) (cons (f (car clist)) acc))))\n" -" (let rec ((clists (cons clist clists)) (acc '()))\n" -" (if (every pair? clists)\n" -" (rec (map cdr clists)\n" -" (cons* (apply f (map car clists)) acc))\n" -" (reverse! acc)))))\n" -"\n" -" (define (filter-map f clist . clists)\n" -" (let recur ((l (apply map f clist clists)))\n" -" (cond ((null? l) '())\n" -" ((car l) (cons (car l) (recur (cdr l))))\n" -" (else (recur (cdr l))))))\n" -"\n" -" (export map for-each\n" -" fold unfold pair-fold reduce\n" -" fold-right unfold-right pair-fold-right reduce-right\n" -" append-map append-map!\n" -" map! pair-for-each filter-map map-in-order)\n" -"\n" -" ;; # Filtering & partitioning\n" -" ;; filter partition remove\n" -" ;; filter! partition! remove!\n" -" (define (filter pred list)\n" -" (let ((pcons (lambda (v acc) (if (pred v) (cons v acc) acc))))\n" -" (reverse (fold pcons '() list))))\n" -"\n" -" (define (remove pred list)\n" -" (filter (lambda (x) (not (pred x))) list))\n" -"\n" -" (define (partition pred list)\n" -" (values (filter pred list)\n" -" (remove pred list)))\n" -"\n" -" (define (filter! pred list)\n" -" (let rec ((lst list))\n" -" (if (null? lst)\n" -" lst\n" -" (if (pred (car lst))\n" -" (begin (set-cdr! lst (rec (cdr lst)))\n" -" lst)\n" -" (rec (cdr lst))))))\n" -"\n" -" (define (remove! pred list)\n" -" (filter! (lambda (x) (not (pred x))) list))\n" -"\n" -" (define (partition! pred list)\n" -" (values (filter! pred list)\n" -" (remove! pred list)))\n" -"\n" -" (export filter partition remove\n" -" filter! partition! remove!)\n" -"\n" -" ;; # Searching\n" -" ;; member memq memv\n" -" ;; find find-tail\n" -" ;; any every\n" -" ;; list-index\n" -" ;; take-while drop-while take-while!\n" -" ;; span break span! break!\n" -"\n" -" (define (find-tail pred list)\n" -" (if (null? list)\n" -" #f\n" -" (if (pred (car list))\n" -" list\n" -" (find-tail pred (cdr list)))))\n" -"\n" -" (define (find pred list)\n" -" (let ((tail (find-tail pred list)))\n" -" (if tail\n" -" (car tail)\n" -" #f)))\n" -"\n" -" (define (take-while pred clist)\n" -" (let rec ((clist clist) (cont values))\n" -" (if (null? clist)\n" -" (cont '())\n" -" (if (pred (car clist))\n" -" (rec (cdr clist)\n" -" (lambda (x) (cont (cons (car clist) x))))\n" -" (cont '())))))\n" -"\n" -" (define (take-while! pred clist)\n" -" (let rec ((clist clist))\n" -" (if (null? clist)\n" -" '()\n" -" (if (pred (car clist))\n" -" (begin (set-cdr! clist (rec (cdr clist)))\n" -" clist)\n" -" '()))))\n" -"\n" -" (define (drop-while pred clist)\n" -" (let rec ((clist clist))\n" -" (if (null? clist)\n" -" '()\n" -" (if (pred (car clist))\n" -" (rec (cdr clist))\n" -" clist))))\n" -"\n" -" (define (span pred clist)\n" -" (values (take-while pred clist)\n" -" (drop-while pred clist)))\n" -"\n" -" (define (span! pred clist)\n" -" (values (take-while! pred clist)\n" -" (drop-while pred clist)))\n" -"\n" -" (define (break pred clist)\n" -" (values (take-while (lambda (x) (not (pred x))) clist)\n" -" (drop-while (lambda (x) (not (pred x))) clist)))\n" -"\n" -" (define (break! pred clist)\n" -" (values (take-while! (lambda (x) (not (pred x))) clist)\n" -" (drop-while (lambda (x) (not (pred x))) clist)))\n" -"\n" -" (define (any pred clist . clists)\n" -" (if (null? clists)\n" -" (let rec ((clist clist))\n" -" (if (pair? clist)\n" -" (or (pred (car clist))\n" -" (rec (cdr clist)))))\n" -" (let rec ((clists (cons clist clists)))\n" -" (if (every pair? clists)\n" -" (or (apply pred (map car clists))\n" -" (rec (map cdr clists)))))))\n" -"\n" -" (set! every\n" -" (lambda (pred clist . clists)\n" -" (if (null? clists)\n" -" (let rec ((clist clist))\n" -" (or (null? clist)\n" -" (if (pred (car clist))\n" -" (rec (cdr clist)))))\n" -" (let rec ((clists (cons clist clists)))\n" -" (or (any null? clists)\n" -" (if (apply pred (map car clists))\n" -" (rec (map cdr clists))))))))\n" -"\n" -" (define (list-index pred clist . clists)\n" -" (if (null? clists)\n" -" (let rec ((clist clist) (n 0))\n" -" (if (pair? clist)\n" -" (if (pred (car clist))\n" -" n\n" -" (rec (cdr clist) (+ n 1)))))\n" -" (let rec ((clists (cons clist clists)) (n 0))\n" -" (if (every pair? clists)\n" -" (if (apply pred (map car clists))\n" -" n\n" -" (rec (map cdr clists) (+ n 1)))))))\n" -"\n" -" (export member memq memv\n" -" find find-tail\n" -" any every\n" -" list-index\n" -" take-while drop-while take-while!\n" -" span break span! break!)\n" -"\n" -" ;; # Deleting\n" -" ;; delete delete-duplicates\n" -" ;; delete! delete-duplicates!\n" -" (define (delete x list . =)\n" -" (let ((= (if (null? =) equal? (car =))))\n" -" (remove (lambda (a) (= x a)) list)))\n" -"\n" -" (define (delete! x list . =)\n" -" (let ((= (if (null? =) equal? (car =))))\n" -" (remove! (lambda (a) (= x a)) list)))\n" -"\n" -" (define (delete-duplicates list . =)\n" -" (let ((= (if (null? =) equal? (car =))))\n" -" (let rec ((list list) (cont values))\n" -" (if (null? list)\n" -" (cont '())\n" -" (let* ((x (car list))\n" -" (rest (cdr list))\n" -" (deleted (delete x rest =)))\n" -" (rec deleted (lambda (y) (cont (cons x y)))))))))\n" -"\n" -" (define (delete-duplicates! list . =)\n" -" (let ((= (if (null? =) equal? (car =))))\n" -" (let rec ((list list) (cont values))\n" -" (if (null? list)\n" -" (cont '())\n" -" (let* ((x (car list))\n" -" (rest (cdr list))\n" -" (deleted (delete! x list =)))\n" -" (rec deleted (lambda (y) (cont (cons x y)))))))))\n" -"\n" -" (export delete delete-duplicates\n" -" delete! delete-duplicates!)\n" -"\n" -" ;; # Association lists\n" -" ;; assoc assq assv\n" -" ;; alist-cons alist-copy\n" -" ;; alist-delete alist-delete!\n" -" (define (alist-cons key datum alist)\n" -" (cons (cons key datum) alist))\n" -"\n" -" (define (alist-copy alist)\n" -" (map (lambda (elt) (cons (car elt) (cdr elt))) alist))\n" -"\n" -" (define (alist-delete key alist . =)\n" -" (let ((= (if (null? =) equal? (car =))))\n" -" (remove (lambda (x) (= key (car x))) alist)))\n" -"\n" -" (define (alist-delete! key alist . =)\n" -" (let ((= (if (null? =) equal? (car =))))\n" -" (remove! (lambda (x) (= key (car x))) alist)))\n" -"\n" -" (export assoc assq assv\n" -" alist-cons alist-copy\n" -" alist-delete alist-delete!)\n" -"\n" -" ;; # Set operations on lists\n" -" ;; lset<= lset= lset-adjoin\n" -" ;; lset-union lset-union!\n" -" ;; lset-intersection lset-intersection!\n" -" ;; lset-difference lset-difference!\n" -" ;; lset-xor lset-xor!\n" -" ;; lset-diff+intersenction lset-diff+intersection!\n" -" (define (lset<= = . lists)\n" -" (or (null? lists)\n" -" (let rec ((head (car lists)) (rest (cdr lists)))\n" -" (or (null? rest)\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (and (or (eq? head next)\n" -" (every (lambda (x) (member x next =)) head))\n" -" (rec next rest)))))))\n" -"\n" -" (define (lset= = . lists)\n" -" (or (null? lists)\n" -" (let rec ((head (car lists)) (rest (cdr lists)))\n" -" (or (null? rest)\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (and (or (eq? head next)\n" -" (and (every (lambda (x) (member x next =)) head)\n" -" (every (lambda (x) (member x head =)) next))\n" -" (rec next rest))))))))\n" -"\n" -" (define (lset-adjoin = list . elts)\n" -" (let rec ((list list) (elts elts))\n" -" (if (null? elts)\n" -" list\n" -" (if (member (car elts) list)\n" -" (rec list (cdr elts))\n" -" (rec (cons (car elts) list) (cdr elts))))))\n" -"\n" -" (define (lset-union = . lists)\n" -" (if (null? lists)\n" -" lists\n" -" (let rec ((head (car lists)) (rest (cdr lists)))\n" -" (if (null? rest)\n" -" head\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (if (eq? head next)\n" -" (rec head rest)\n" -" (rec (apply lset-adjoin = head next) rest)))))))\n" -"\n" -" (define (lset-intersection = . lists)\n" -" (if (null? lists)\n" -" lists\n" -" (let rec ((head (car lists)) (rest (cdr lists)))\n" -" (if (null? rest)\n" -" head\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (if (eq? head next)\n" -" (rec head rest)\n" -" (rec (filter (lambda (x) (member x next =)) head)\n" -" rest)))))))\n" -"\n" -" (define (lset-difference = list . lists)\n" -" (let rec ((head list) (rest lists))\n" -" (if (null? rest)\n" -" head\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (if (eq? head next)\n" -" '()\n" -" (rec (remove (lambda (x) (member x next =)) head)\n" -" rest))))))\n" -"\n" -" (define (lset-xor = . lists)\n" -" (if (null? lists)\n" -" lists\n" -" (let rec ((head (car lists)) (rest (cdr lists)))\n" -" (if (null? rest)\n" -" head\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (if (eq? head next)\n" -" '()\n" -" (rec (append (remove (lambda (x) (member x next =)) head)\n" -" (remove (lambda (x) (member x head =)) next))\n" -" rest)))))))\n" -"\n" -" (define (lset-diff+intersection = list . lists)\n" -" (values (apply lset-difference = list lists)\n" -" (lset-intersection = list (apply lset-union lists))))\n" -"\n" -" (define (lset-adjoin! = list . elts)\n" -" (let rec ((list list) (elts elts))\n" -" (if (null? elts)\n" -" list\n" -" (if (member (car elts) list)\n" -" (rec list (cdr elts))\n" -" (let ((tail (cdr elts)))\n" -" (set-cdr! elts list)\n" -" (rec elts tail))))))\n" -"\n" -" (define (lset-union! = . lists)\n" -" (letrec ((adjoin\n" -" (lambda (lst1 lst2)\n" -" (if (null? lst2)\n" -" lst1\n" -" (if (member (car lst2) lst1 =)\n" -" (adjoin lst1 (cdr lst2))\n" -" (let ((tail (cdr lst2)))\n" -" (set-cdr! lst2 lst1)\n" -" (adjoin lst2 tail)))))))\n" -" (if (null? lists)\n" -" lists\n" -" (let rec ((head (car lists)) (rest (cdr lists)))\n" -" (if (null? rest)\n" -" head\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (if (eq? head next)\n" -" (rec head rest)\n" -" (rec (adjoin head next) rest))))))))\n" -"\n" -" (define (lset-intersection! = . lists)\n" -" (if (null? lists)\n" -" lists\n" -" (let rec ((head (car lists)) (rest (cdr lists)))\n" -" (if (null? rest)\n" -" head\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (if (eq? head next)\n" -" (rec head rest)\n" -" (rec (filter! (lambda (x) (member x next =)) head)\n" -" rest)))))))\n" -"\n" -" (define (lset-difference! = list . lists)\n" -" (let rec ((head list) (rest lists))\n" -" (if (null? rest)\n" -" head\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (if (eq? head next)\n" -" '()\n" -" (rec (remove! (lambda (x) (member x next =)) head)\n" -" rest))))))\n" -"\n" -" (define (lset-xor! = . lists)\n" -" (if (null? lists)\n" -" lists\n" -" (let rec ((head (car lists)) (rest (cdr lists)))\n" -" (if (null? rest)\n" -" head\n" -" (let ((next (car rest)) (rest (cdr rest)))\n" -" (if (eq? head next)\n" -" '()\n" -" (rec (append! (remove! (lambda (x) (member x next =)) head)\n" -" (remove! (lambda (x) (member x head =)) next))\n" -" rest)))))))\n" -"\n" -" (define (lset-diff+intersection! = list . lists)\n" -" (values (apply lset-difference! = list lists)\n" -" (lset-intersection! = list (apply lset-union! lists))))\n" -"\n" -" (export lset<= lset= lset-adjoin\n" -" lset-union lset-union!\n" -" lset-intersection lset-intersection!\n" -" lset-difference lset-difference!\n" -" lset-xor lset-xor!\n" -" lset-diff+intersection lset-diff+intersection!)\n" -"\n" -" ;; # Primitive side-effects\n" -" ;; set-car! set-cdr!\n" -" (export set-car! set-cdr!))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_8 = -"(define-library (srfi 8)\n" -" (import (scheme base))\n" -"\n" -" (define-syntax receive\n" -" (syntax-rules ()\n" -" ((receive formals expression body ...)\n" -" (call-with-values (lambda () expression)\n" -" (lambda formals body ...)))))\n" -"\n" -" (export receive))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_26 = -"(define-library (srfi 26)\n" -" (import (scheme base)\n" -" (picrin macro)\n" -" (srfi 1))\n" -"\n" -" (define-syntax cut%\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare?)\n" -" (let ((slots (second form))\n" -" (combi (third form))\n" -" (se (cdddr form)))\n" -" (cond ((null? se)\n" -" `(lambda ,slots ((begin ,(car combi)) ,@(cdr combi))))\n" -" ((and (symbol? (car se))\n" -" (compare? (car se) '<...>))\n" -" `(lambda (,@slots . rest-slot) (apply ,@combi rest-slot)))\n" -" ((and (symbol? (car se))\n" -" (compare? (car se) '<>))\n" -" `(cut% (,@slots x) (,@combi x) ,@(cdr se)))\n" -" (else `(cut% ,slots (,@combi ,(car se)) ,@(cdr se))))))))\n" -"\n" -" (define-syntax cute%\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare?)\n" -" (let ((slots (second form))\n" -" (binds (third form))\n" -" (combi (fourth form))\n" -" (se (cddddr form)))\n" -" (cond ((null? se)\n" -" `(let ,binds\n" -" (lambda ,slots ((begin ,(car combi)) ,@(cdr combi)))))\n" -" ((and (symbol? (car se))\n" -" (compare? (car se) '<...>))\n" -" `(let ,binds\n" -" (lambda (,@slots . rest-slot) (apply ,@combi rest-slot))))\n" -" ((and (symbol? (car se))\n" -" (compare? (car se) '<>))\n" -" `(cute% (,@slots x) ,binds (,@combi x) ,@(cdr se)))\n" -" (else\n" -" `(cute% ,slots ((x ,(car se)) ,@binds)\n" -" (,@combi x) ,@(cdr se))))))))\n" -" \n" -" (define-syntax cut\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare?)\n" -" `(cut% () () ,@(cdr form)))))\n" -"\n" -" (define-syntax cute\n" -" (ir-macro-transformer\n" -" (lambda (form inject compare?)\n" -" `(cute% () () () ,@(cdr form)))))\n" -"\n" -" (export cut cute))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_43 = -"(define-library (srfi 43)\n" -" (import (scheme base)\n" -" (srfi 8))\n" -" \n" -" ;; # Constructors\n" -" (define (vector-unfold f length . seeds)\n" -" (let ((seeds (if (null? seeds) '(0) seeds))\n" -" (vect (make-vector length)))\n" -" (letrec ((tabulate\n" -" (lambda (count . args)\n" -" (if (= length count)\n" -" vect\n" -" (receive lst (apply f count args)\n" -" (vector-set! vect count (car lst))\n" -" (apply tabulate (+ 1 count) (cdr lst)))))))\n" -" (apply tabulate 0 seeds))))\n" -"\n" -" (define (vector-unfold-right f length . seeds)\n" -" (let ((seeds (if (null? seeds) '(0) seeds))\n" -" (vect (make-vector length)))\n" -" (letrec ((tabulate\n" -" (lambda (count . args)\n" -" (if (< count 0)\n" -" vect\n" -" (receive lst (apply f count args)\n" -" (vector-set! vect count (car lst))\n" -" (apply tabulate (- count 1) (cdr lst)))))))\n" -" (apply tabulate (- length 1) seeds))))\n" -"\n" -" (define (vector-reverse-copy vec . rst)\n" -" (let* ((start (if (null? rst) 0 (car rst)))\n" -" (end (if (or (null? rst) (null? (cdr rst)))\n" -" (vector-length vec)\n" -" (cadr rst)))\n" -" (new-vect (make-vector (- end start))))\n" -" (let loop ((i (- end 1)) (count 0))\n" -" (if (< i start)\n" -" new-vect\n" -" (begin\n" -" (vector-set! new-vect count (vector-ref vec i))\n" -" (loop (- i 1) (+ 1 count)))))))\n" -"\n" -" (define (vector-concatenate list-of-vectors)\n" -" (apply vector-append list-of-vectors))\n" -"\n" -" \n" -" ;; # Predicates\n" -" (define (vector-empty? vec)\n" -" (zero? (vector-length vec)))\n" -"\n" -" ; for the symmetry, this should be rather 'vector=?' than 'vector='.\n" -" (define (vector= elt=? . vects)\n" -" (letrec ((vector2=\n" -" (lambda (v1 v2)\n" -" (let ((ln1 (vector-length v1)))\n" -" (and (= ln1 (vector-length v2))\n" -" (let loop ((count 0))\n" -" (if (= ln1 count)\n" -" #t\n" -" (and (elt=? (vector-ref v1 count)\n" -" (vector-ref v2 count))\n" -" (loop (+ 1 count))))))))))\n" -" (or (null? vects)\n" -" (let rec1 ((vect1 (car vects)) (others (cdr vects)))\n" -" (or (null? others)\n" -" (let ((vect2 (car others))\n" -" (others (cdr others)))\n" -" (if (eq? vect1 vect2)\n" -" (rec1 vect1 others)\n" -" (and (vector2= vect1 vect2)\n" -" (rec1 vect2 others)))))))))\n" -"\n" -" \n" -" ;; # Iteration\n" -" (define (vector-fold kons knil vec . vects)\n" -" (let* ((vects (cons vec vects))\n" -" (veclen (apply min (map vector-length vects))))\n" -" (let rec ((acc knil) (count 0))\n" -" (if (= count veclen)\n" -" acc\n" -" (rec (apply kons count acc\n" -" (map (lambda (v) (vector-ref v count)) vects))\n" -" (+ 1 count))))))\n" -"\n" -" (define (vector-fold-right kons knil vec . vects)\n" -" (let* ((vects (cons vec vects))\n" -" (veclen (apply min (map vector-length vects))))\n" -" (let rec ((acc knil) (count (- veclen 1)))\n" -" (if (< count 0)\n" -" acc\n" -" (rec (apply kons count acc\n" -" (map (lambda (v) (vector-ref v count)) vects))\n" -" (- count 1))))))\n" -"\n" -" (define (vector-map! f vec . vects)\n" -" (let* ((vects (cons vec vects))\n" -" (veclen (apply min (map vector-length vects)))\n" -" (new-vect (make-vector veclen)))\n" -" (let rec ((count 0))\n" -" (if (< count veclen)\n" -" (begin\n" -" (vector-set! vec count\n" -" (apply f (map (lambda (v) (vector-ref v count))\n" -" vects)))\n" -" (rec (+ 1 count)))))))\n" -"\n" -" (define (vector-count pred? vec . vects)\n" -" (let* ((vects (cons vec vects))\n" -" (veclen (apply min (map vector-length vects))))\n" -" (let rec ((i 0) (count 0))\n" -" (if (= i veclen)\n" -" count\n" -" (if (apply pred? count (map (lambda (v) (vector-ref v count)) vects))\n" -" (rec (+ 1 i) (+ 1 count))\n" -" (rec (+ 1 i) count))))))\n" -"\n" -" ;; # Searching\n" -" (define (vector-index pred? vec . vects)\n" -" (let* ((vects (cons vec vects))\n" -" (veclen (apply min (map vector-length vects))))\n" -" (let rec ((count 0))\n" -" (cond\n" -" ((= count veclen) #f)\n" -" ((apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" -" count)\n" -" (else (rec (+ 1 count)))))))\n" -"\n" -" (define (vector-index-right pred? vec . vects)\n" -" (let ((vects (cons vec vects))\n" -" (veclen (vector-length vec)))\n" -" (let rec ((count (- veclen 1)))\n" -" (cond\n" -" ((< count 0) #f)\n" -" ((apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" -" count)\n" -" (else (rec (- count 1)))))))\n" -"\n" -" (define (vector-skip pred? vec . vects)\n" -" (apply vector-index (lambda args (not (apply pred? args))) vec vects))\n" -"\n" -" (define (vector-skip-right pred? vec . vects)\n" -" (apply vector-index-right (lambda args (not (apply pred? args))) vec vects))\n" -"\n" -" (define (vector-binary-search vec value cmp)\n" -" (let rec ((start 0) (end (vector-length vec)) (n -1))\n" -" (let ((count (floor/ (+ start end) 2)))\n" -" (if (or (= start end) (= count n))\n" -" #f\n" -" (let ((comparison (cmp (vector-ref vec count) value)))\n" -" (cond\n" -" ((zero? comparison) count)\n" -" ((positive? comparison) (rec start count count))\n" -" (else (rec count end count))))))))\n" -"\n" -" (define (vector-any pred? vec . vects)\n" -" (let* ((vects (cons vec vects))\n" -" (veclen (vector-length vec)))\n" -" (let rec ((count 0))\n" -" (if (= count veclen)\n" -" #f\n" -" (or (apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" -" (rec (+ 1 count)))))))\n" -"\n" -" (define (vector-every pred? vec . vects)\n" -" (let* ((vects (cons vec vects))\n" -" (veclen (vector-length vec)))\n" -" (let rec ((count 0))\n" -" (if (= count veclen)\n" -" #t\n" -" (and (apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" -" (rec (+ 1 count)))))))\n" -"\n" -" ;; # Mutators\n" -" (define (vector-swap! vec i j)\n" -" (let ((tmp (vector-ref vec i)))\n" -" (vector-set! vec i (vector-ref vec j))\n" -" (vector-set! vec j tmp)))\n" -"\n" -" (define (vector-reverse! vec . rst)\n" -" (let ((start (if (null? rst) 0 (car rst)))\n" -" (end (if (or (null? rst) (cdr rst))\n" -" (vector-length vec)\n" -" (cadr rst))))\n" -" (let rec ((i start) (j (- end 1)))\n" -" (if (< i j)\n" -" (begin\n" -" (vector-swap! vec i j)\n" -" (rec (+ 1 i) (- j 1)))))))\n" -"\n" -" (define (vector-reverse-copy! target tstart source . rst)\n" -" (let ((sstart (if (null? rst) 0 (car rst)))\n" -" (send (if (or (null? rst) (cdr rst))\n" -" (vector-length source)\n" -" (cadr rst))))\n" -" (let rec ((i tstart) (j (- send 1)))\n" -" (if (>= j sstart)\n" -" (begin\n" -" (vector-set! target i (vector-ref source j))\n" -" (rec (+ 1 i) (- j 1)))))))\n" -"\n" -" ;; # Conversion\n" -" (define (reverse-vector->list vec . rst)\n" -" (let ((start (if (null? rst) 0 (car rst)))\n" -" (end (if (or (null? rst) (cdr rst))\n" -" (vector-length vec)\n" -" (cadr rst))))\n" -" (let rec ((i start) (acc '()))\n" -" (if (= i end)\n" -" acc\n" -" (rec (+ 1 i) (cons (vector-ref vec i) acc))))))\n" -"\n" -" (define (reverse-list->vector proper-list)\n" -" (apply vector (reverse proper-list)))\n" -"\n" -" (export vector?\n" -" make-vector\n" -" vector\n" -" vector-length\n" -" vector-ref\n" -" vector-set!\n" -" vector->list\n" -" list->vector\n" -" vector-fill!\n" -" vector-copy!\n" -"\n" -" vector-unfold\n" -" vector-unfold-right\n" -" vector-reverse-copy\n" -" vector-concatenate\n" -" vector-empty?\n" -" vector=\n" -" vector-fold\n" -" vector-fold-right\n" -" vector-map!\n" -" vector-count\n" -" vector-index\n" -" vector-index-right\n" -" vector-skip\n" -" vector-skip-right\n" -" vector-binary-search\n" -" vector-any\n" -" vector-every\n" -" vector-swap!\n" -" vector-reverse!\n" -" vector-reverse-copy!\n" -" reverse-vector->list\n" -" reverse-list->vector))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_60 = -"(define-library (srfi 60)\n" -" (import (scheme base)\n" -" (srfi 1))\n" -"\n" -" ;; # Bitwise Operations\n" -" (define (logand . args)\n" -" (letrec ((lgand\n" -" (lambda (x y)\n" -" (if (or (zero? x) (zero? y))\n" -" 0\n" -" (+ (* (lgand (floor/ x 2) (floor/ y 2)) 2)\n" -" (if (or (even? x) (even? y)) 0 1))))))\n" -" (fold lgand -1 args)))\n" -"\n" -" (define bitwise-and logand)\n" -"\n" -" (define (logior . args)\n" -" (letrec ((lgior\n" -" (lambda (x y)\n" -" (cond\n" -" ((= x y) x)\n" -" ((zero? x) y)\n" -" ((zero? y) x)\n" -" (else\n" -" (+ (* (lgior (truncate-quotient x 2)\n" -" (truncate-quotient y 2))\n" -" 2)\n" -" (if (and (even? x) (even? y)) 0 1)))))))\n" -" (fold lgior 0 args)))\n" -"\n" -" (define bitwise-ior logior)\n" -"\n" -" (define (logxor . args)\n" -" (letrec ((lgxor\n" -" (lambda (x y)\n" -" (cond\n" -" ((zero? x) y)\n" -" ((zero? y) x)\n" -" (else\n" -" (+ (* (lgxor (floor/ x 2) (floor/ y 2)) 2)\n" -" (if (even? x)\n" -" (if (even? y) 0 1)\n" -" (if (even? y) 1 0))))))))\n" -" (fold lgxor 0 args)))\n" -"\n" -" (define bitwise-xor logxor)\n" -"\n" -" (define (lognot n)\n" -" (- -1 n))\n" -"\n" -" (define bitwise-not lognot)\n" -"\n" -" (define (bitwise-if mask n0 n1)\n" -" (logior (logand mask n0)\n" -" (logand (lognot mask) n1)))\n" -"\n" -" (define bitwise-merge bitwise-if)\n" -"\n" -" (define (logtest j k)\n" -" (not (zero? (logand j k))))\n" -"\n" -" (define any-bits-set? logtest)\n" -"\n" -" ;; # Integer Properties\n" -" (define (logcount n)\n" -" (letrec ((lgcnt\n" -" (lambda (n)\n" -" (if (zero? n) 0\n" -" (+ (lgcnt (floor/ n 2))\n" -" (if (even? n) 0 1))))))\n" -" (if (negative? n)\n" -" (lgcnt (lognot n))\n" -" (lgcnt n))))\n" -"\n" -" (define bit-count logcount)\n" -"\n" -" (define (integer-length n)\n" -" (let loop ((n n) (count 0))\n" -" (if (zero? n)\n" -" count\n" -" (loop (floor/ n 2) (+ count 1)))))\n" -"\n" -" (define (log2-binary-factors n)\n" -" (+ -1 (integer-length (logand n (- n)))))\n" -"\n" -" (define first-set-bit log2-binary-factors)\n" -" \n" -" ;; # Bit Within Word\n" -" (define (logbit? index n)\n" -" (logtest (expt 2 index) n))\n" -"\n" -" (define bit-set? logbit?)\n" -"\n" -" (define (copy-bit index from bit)\n" -" (if bit\n" -" (logior from (expt 2 index))\n" -" (logand from (lognot (expt 2 index)))))\n" -"\n" -"\n" -" ;; # Field of Bits\n" -" (define (ash n count)\n" -" (if (negative? count)\n" -" (let ((k (expt 2 (- count))))\n" -" (if (negative? n)\n" -" (+ -1 (truncate-quotient (+ 1 n) k))\n" -" (truncate-quotient n k)))\n" -" (* (expt 2 count) n)))\n" -"\n" -" (define arithmetic-shift ash)\n" -"\n" -" (define (bit-field n start end)\n" -" (logand (lognot (ash -1 (- end start)))\n" -" (ash n (- start))))\n" -"\n" -" (define (copy-bit-field to from start end)\n" -" (bitwise-if (ash (lognot (ash -1 (- end start))) start)\n" -" (ash from start)\n" -" to))\n" -"\n" -" (define (rotate-bit-field n count start end)\n" -" (let* ((width (- start end))\n" -" (count (floor-remainder count width))\n" -" (mask (lognot (ash -1 width)))\n" -" (zn (logand mask (ash n (- start)))))\n" -" (logior (ash (logior (logand mask (ash zn count))\n" -" (ash zn (- count width)))\n" -" start)\n" -" (logand (lognot (ash mask start)) n))))\n" -"\n" -" (define (reverse-bit-field n start end)\n" -" (letrec ((bit-reverse\n" -" (lambda (k n)\n" -" (let loop ((m (if (negative? n) (lognot n) n))\n" -" (k (- k 1))\n" -" (rvs 0))\n" -" (if (negative? k)\n" -" (if (negative? n) (lognot rvs) rvs)\n" -" (loop (ash m -1)\n" -" (- k 1)\n" -" (logior (ash rvs 1) (logand 1 m))))))))\n" -" (let* ((width (- start end))\n" -" (mask (lognot (ash -1 width)))\n" -" (zn (logand mask (ash n (- start)))))\n" -" (logior (ash (bit-reverse width zn) start)\n" -" (logand (lognot (ash mask start)) n)))))\n" -"\n" -" ;; Bits as Booleans\n" -" (define (integer->list k . len)\n" -" (let ((len (if (null? len) (integer-length k) len)))\n" -" (let loop ((k k) (len len) (acc '()))\n" -" (if (or (zero? k) (zero? len))\n" -" acc\n" -" (loop (floor/ k 2) (- len 1) (cons (if (even? k) #f #t) acc))))))\n" -"\n" -" (define (list->integer lst)\n" -" (let loop ((lst lst) (acc 0))\n" -" (if (null? lst)\n" -" acc\n" -" (loop (cdr lst) (+ (* acc 2) (if (car lst) 1 0))))))\n" -"\n" -" (define (booleans->integer . args)\n" -" (list->integer args))\n" -"\n" -" (export logand bitwise-and\n" -" logior bitwise-ior\n" -" logxor bitwise-xor\n" -" lognot bitwise-not\n" -" bitwise-if bitwise-merge\n" -" logtest any-bits-set?\n" -" logcount bit-count\n" -" integer-length\n" -" log2-binary-factors first-set-bit\n" -" logbit? bit-set?\n" -" copy-bit\n" -" bit-field\n" -" copy-bit-field\n" -" ash arithmetic-shift\n" -" rotate-bit-field\n" -" reverse-bit-field\n" -" integer->list\n" -" list->integer\n" -" booleans->integer))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_95 = -"(define-library (srfi 95)\n" -" (import (scheme base)\n" -" (scheme load)\n" -" (srfi 1))\n" -"\n" -" (define (list-sorted? ls less?)\n" -" (let loop ((cur ls))\n" -" (if (<= (length cur) 1)\n" -" #t\n" -" (if (less? (second cur) (first cur))\n" -" #f\n" -" (loop (cdr cur))))))\n" -"\n" -" (define (identity x)\n" -" x)\n" -"\n" -" (define (merge ls1 ls2 less? . opt-key)\n" -" (let ((key (if (null? opt-key) identity (car opt-key))))\n" -" (let rec ((arg1 ls1) (arg2 ls2))\n" -" (cond ((null? arg1)\n" -" arg2)\n" -" ((null? arg2)\n" -" arg1)\n" -" ((less? (key (car arg1)) (key (car arg2)))\n" -" (cons (car arg1) (rec (cdr arg1) arg2)))\n" -" (else\n" -" (cons (car arg2) (rec arg1 (cdr arg2))))))))\n" -"\n" -" (define (merge-sub! ls1 ls2 less? key)\n" -" (let rec ((arg1 ls1) (arg2 ls2))\n" -" (cond ((null? arg1)\n" -" arg2)\n" -" ((null? arg2)\n" -" arg1)\n" -" ((not (less? (key (car arg2)) (key (car arg1))))\n" -" (set-cdr! arg1 (rec (cdr arg1) arg2)) arg1)\n" -" (else\n" -" (set-cdr! arg2 (rec arg1 (cdr arg2))) arg2))))\n" -"\n" -" (define (merge! ls1 ls2 less? . opt-key)\n" -" (let ((key (if (null? opt-key) identity (car opt-key)))\n" -" (c1 (car ls1))\n" -" (c2 (car ls2))\n" -" (d1 (cdr ls1))\n" -" (d2 (cdr ls2)))\n" -" (when (less? (key c2) (key c1))\n" -" (set-car! ls1 c2)\n" -" (set-car! ls2 c1)\n" -" (set-cdr! ls1 d2)\n" -" (set-cdr! ls2 d1))\n" -" (merge-sub! ls1 ls2 less? key)))\n" -"\n" -" (define (merge-sort ls less?)\n" -" (if (<= (length ls) 1)\n" -" ls\n" -" (let* ((n (length ls))\n" -" (p (quotient n 2))\n" -" (as (take ls p))\n" -" (bs (drop ls p))\n" -" (sa (merge-sort as less?))\n" -" (sb (merge-sort bs less?)))\n" -" (merge sa sb less?))))\n" -"\n" -" (define (merge-sort! ls less?)\n" -" (if (<= (length ls) 1) ls\n" -" (let* ((n (length ls))\n" -" (p (quotient n 2))\n" -" (bs (drop ls p))\n" -" (as (take! ls p))\n" -" (sa (merge-sort! as less?))\n" -" (sb (merge-sort! bs less?)))\n" -" (merge! sa sb less?))))\n" -"\n" -" (export list-sorted?\n" -" merge\n" -" merge!\n" -" merge-sort\n" -" merge-sort!))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_111 = -"(define-library (srfi 111)\n" -" (import (scheme base))\n" -"\n" -" (define-record-type \n" -" (box value)\n" -" box?\n" -" (value unbox set-box!))\n" -"\n" -" (export box box?\n" -" unbox set-box!))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_user = -"; the default repl environment\n" -"\n" -"(define-library (picrin user)\n" -" (import (scheme base)\n" -" (scheme load)\n" -" (scheme process-context)\n" -" (scheme read)\n" -" (scheme write)\n" -" (scheme file)\n" -" (scheme inexact)\n" -" (scheme cxr)\n" -" (scheme lazy)\n" -" (scheme time)\n" -" (picrin macro)\n" -" (picrin dictionary)\n" -" (picrin array)\n" -" (picrin library)))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_repl = -"(define-library (picrin repl)\n" -" (import (scheme base)\n" -" (scheme read)\n" -" (scheme file)\n" -" (scheme write)\n" -" (scheme eval)\n" -" (scheme process-context))\n" -"\n" -" (define (join sep strs)\n" -" (let loop ((result (car strs)) (rest (cdr strs)))\n" -" (if (null? rest)\n" -" result\n" -" (loop (string-append result sep (car rest)) (cdr rest)))))\n" -"\n" -" (define (file->string file)\n" -" (with-input-from-file file\n" -" (lambda ()\n" -" (let loop ((line (read-line)) (acc '()))\n" -" (if (eof-object? line)\n" -" (join \"\\n\" (reverse acc))\n" -" (loop (read-line) (cons line acc)))))))\n" -"\n" -" (define (print obj . port)\n" -" (let ((port (if (null? port) (current-output-port) (car port))))\n" -" (write obj port)\n" -" (newline port)\n" -" obj))\n" -"\n" -" (define (print-help)\n" -" (display \"picrin scheme\\n\")\n" -" (display \"\\n\")\n" -" (display \"Usage: picrin [options] [file]\\n\")\n" -" (display \"\\n\")\n" -" (display \"Options:\\n\")\n" -" (display \" -e [program] run one liner script\\n\")\n" -" (display \" -h or --help show this help\\n\"))\n" -"\n" -" (define (getopt)\n" -" (let ((args (cdr (command-line))))\n" -" (if (null? args)\n" -" #f\n" -" (case (string->symbol (car args))\n" -" ((-h --help)\n" -" (print-help)\n" -" (exit 1))\n" -" ((-e)\n" -" (cadr args))\n" -" (else\n" -" (file->string (car args)))))))\n" -"\n" -" (define (main-loop in out on-err)\n" -" (display \"> \" out)\n" -" (let ((expr (read in)))\n" -" (if (eof-object? expr)\n" -" (newline out) ; exit\n" -" (begin\n" -" (call/cc\n" -" (lambda (leave)\n" -" (with-exception-handler\n" -" (lambda (condition)\n" -" (display (error-object-message condition) (current-error-port))\n" -" (newline)\n" -" (if on-err\n" -" (on-err)\n" -" (leave)))\n" -" (lambda ()\n" -" (print (eval expr '(picrin user)) out)))))\n" -" (main-loop in out on-err)))))\n" -"\n" -" (define (run-repl program)\n" -" (let ((in (if program\n" -" (open-input-string program)\n" -" (current-input-port)))\n" -" (out (if program\n" -" (open-output-string) ; ignore output\n" -" (current-output-port)))\n" -" (on-err (if program\n" -" (lambda () (exit 1))\n" -" #f)))\n" -" (main-loop in out on-err)))\n" -"\n" -" (define (repl)\n" -" (let ((program (getopt)))\n" -" (run-repl program)))\n" -"\n" -" (export repl))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_10_partcont_piclib_partcont = -"(define-library (picrin control)\n" -" (import (scheme base))\n" -"\n" -" ; based on paper \"Representing Monads\" (Filinski 1994)\n" -"\n" -" (define m #f)\n" -"\n" -" (define (abort t)\n" -" (let ((v (t))) ; (t) may update m. do not place me like (m (t))\n" -" (m v)))\n" -"\n" -" (define (reset t)\n" -" (let ((n m))\n" -" (call/cc\n" -" (lambda (k)\n" -" (set! m (lambda (r)\n" -" (set! m n)\n" -" (k r)))\n" -" (abort t)))))\n" -"\n" -" (define (shift h)\n" -" (call/cc\n" -" (lambda (k)\n" -" (abort\n" -" (lambda ()\n" -" (h (lambda (v)\n" -" (reset (lambda ()\n" -" (k v))))))))))\n" -"\n" -" (export shift\n" -" reset))\n" -"\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_10_pretty_print_pretty_print = -"(define-library (picrin pretty-print)\n" -" (import (scheme base)\n" -" (scheme write))\n" -"\n" -" ; (reverse-string-append l) = (apply string-append (reverse l))\n" -"\n" -" (define (reverse-string-append l)\n" -"\n" -" (define (rev-string-append l i)\n" -" (if (pair? l)\n" -" (let* ((str (car l))\n" -" (len (string-length str))\n" -" (result (rev-string-append (cdr l) (+ i len))))\n" -" (let loop ((j 0) (k (- (- (string-length result) i) len)))\n" -" (if (< j len)\n" -" (begin\n" -" (string-set! result k (string-ref str j))\n" -" (loop (+ j 1) (+ k 1)))\n" -" result)))\n" -" (make-string i)))\n" -"\n" -" (rev-string-append l 0))\n" -"\n" -" ;; We define a pretty printer for Scheme S-expressions (sexp). While\n" -" ;; Petite Scheme supports that by its own, mzscheme does not. If you\n" -" ;; get a sexp (like from proof-to-expr) prefix it with a call to spp and\n" -" ;; the output is nicely formated to fit into pp-width many columns:\n" -" ;;\n" -" ;; (spp (proof-to-expr (current-proof)))\n" -" ;;\n" -"\n" -" (define pp-width 80)\n" -"\n" -" ;;\"genwrite.scm\" generic write used by pretty-print and truncated-print.\n" -" ;; Copyright (c) 1991, Marc Feeley\n" -" ;; Author: Marc Feeley (feeley@iro.umontreal.ca)\n" -" ;; Distribution restrictions: none\n" -" ;;\n" -" ;; Modified for Minlog by Stefan Schimanski \n" -" ;; Taken from slib 2d6, genwrite.scm and pp.scm\n" -"\n" -" (define genwrite:newline-str (make-string 1 #\\newline))\n" -"\n" -" (define (generic-write obj display? width output)\n" -"\n" -" (define (read-macro? l)\n" -" (define (length1? l) (and (pair? l) (null? (cdr l))))\n" -" (let ((head (car l)) (tail (cdr l)))\n" -" (case head\n" -" ((quote quasiquote unquote unquote-splicing) (length1? tail))\n" -" (else #f))))\n" -"\n" -" (define (read-macro-body l)\n" -" (cadr l))\n" -"\n" -" (define (read-macro-prefix l)\n" -" (let ((head (car l)) (tail (cdr l)))\n" -" (case head\n" -" ((quote) \"'\")\n" -" ((quasiquote) \"`\")\n" -" ((unquote) \",\")\n" -" ((unquote-splicing) \",@\"))))\n" -"\n" -" (define (out str col)\n" -" (and col (output str) (+ col (string-length str))))\n" -"\n" -" (define (wr obj col)\n" -"\n" -" (define (wr-lst l col)\n" -" (if (pair? l)\n" -" (let loop ((l (cdr l))\n" -" (col (and col (wr (car l) (out \"(\" col)))))\n" -" (cond ((not col) col)\n" -" ((pair? l)\n" -" (loop (cdr l) (wr (car l) (out \" \" col))))\n" -" ((null? l) (out \")\" col))\n" -" (else (out \")\" (wr l (out \" . \" col))))))\n" -" (out \"()\" col)))\n" -"\n" -" (define (wr-expr expr col)\n" -" (if (read-macro? expr)\n" -" (wr (read-macro-body expr) (out (read-macro-prefix expr) col))\n" -" (wr-lst expr col)))\n" -"\n" -" (cond ((pair? obj) (wr-expr obj col))\n" -" ((null? obj) (wr-lst obj col))\n" -" ((vector? obj) (wr-lst (vector->list obj) (out \"#\" col)))\n" -" ((boolean? obj) (out (if obj \"#t\" \"#f\") col))\n" -" ((number? obj) (out (number->string obj) col))\n" -" ((symbol? obj) (out (symbol->string obj) col))\n" -" ((procedure? obj) (out \"#[procedure]\" col))\n" -" ((string? obj) (if display?\n" -" (out obj col)\n" -" (let loop ((i 0) (j 0) (col (out \"\\\"\" col)))\n" -" (if (and col (< j (string-length obj)))\n" -" (let ((c (string-ref obj j)))\n" -" (if (or (char=? c #\\\\)\n" -" (char=? c #\\\"))\n" -" (loop j\n" -" (+ j 1)\n" -" (out \"\\\\\"\n" -" (out (substring obj i j)\n" -" col)))\n" -" (loop i (+ j 1) col)))\n" -" (out \"\\\"\"\n" -" (out (substring obj i j) col))))))\n" -" ((char? obj) (if display?\n" -" (out (make-string 1 obj) col)\n" -" (out (case obj\n" -" ((#\\space) \"space\")\n" -" ((#\\newline) \"newline\")\n" -" (else (make-string 1 obj)))\n" -" (out \"#\\\\\" col))))\n" -" ((input-port? obj) (out \"#[input-port]\" col))\n" -" ((output-port? obj) (out \"#[output-port]\" col))\n" -" ((eof-object? obj) (out \"#[eof-object]\" col))\n" -" (else (out \"#[unknown]\" col))))\n" -"\n" -" (define (pp obj col)\n" -"\n" -" (define (spaces n col)\n" -" (if (> n 0)\n" -" (if (> n 7)\n" -" (spaces (- n 8) (out \" \" col))\n" -" (out (substring \" \" 0 n) col))\n" -" col))\n" -"\n" -" (define (indent to col)\n" -" (and col\n" -" (if (< to col)\n" -" (and (out genwrite:newline-str col) (spaces to 0))\n" -" (spaces (- to col) col))))\n" -"\n" -" (define pp-list #f)\n" -" (define pp-expr #f)\n" -" (define pp-call #f)\n" -" (define pp-down #f)\n" -" (define pp-general #f)\n" -" (define pp-width #f)\n" -" (define pp-expr-list #f)\n" -"\n" -" (define indent-general #f)\n" -" (define max-expr-width #f)\n" -" (define max-call-head-width #f)\n" -" (define style #f)\n" -"\n" -" (define pr\n" -" (lambda (obj col extra pp-pair)\n" -" (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines\n" -" (let ((result '())\n" -" (left (min (+ (- (- width col) extra) 1) max-expr-width)))\n" -" (generic-write obj display? #f\n" -" (lambda (str)\n" -" (set! result (cons str result))\n" -" (set! left (- left (string-length str)))\n" -" (> left 0)))\n" -" (if (> left 0) ; all can be printed on one line\n" -" (out (reverse-string-append result) col)\n" -" (if (pair? obj)\n" -" (pp-pair obj col extra)\n" -" (pp-list (vector->list obj) (out \"#\" col) extra pp-expr))))\n" -" (wr obj col))))\n" -"\n" -" (set! pp-expr\n" -" (lambda (expr col extra)\n" -" (if (read-macro? expr)\n" -" (pr (read-macro-body expr)\n" -" (out (read-macro-prefix expr) col)\n" -" extra\n" -" pp-expr)\n" -" (let ((head (car expr)))\n" -" (if (symbol? head)\n" -" (let ((proc (style head)))\n" -" (if proc\n" -" (proc expr col extra)\n" -" (if (> (string-length (symbol->string head))\n" -" max-call-head-width)\n" -" (pp-general expr col extra #f #f #f pp-expr)\n" -" (pp-call expr col extra pp-expr))))\n" -" (pp-list expr col extra pp-expr))))))\n" -"\n" -" ; (head item1\n" -" ; item2\n" -" ; item3)\n" -" (set! pp-call\n" -" (lambda (expr col extra pp-item)\n" -" (let ((col* (wr (car expr) (out \"(\" col))))\n" -" (and col\n" -" (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))))\n" -"\n" -" ; (item1\n" -" ; item2\n" -" ; item3)\n" -" (set! pp-list\n" -" (lambda (l col extra pp-item)\n" -" (let ((col (out \"(\" col)))\n" -" (pp-down l col col extra pp-item))))\n" -"\n" -" (set! pp-down\n" -" (lambda (l col1 col2 extra pp-item)\n" -" (let loop ((l l) (col col1))\n" -" (and col\n" -" (cond ((pair? l)\n" -" (let ((rest (cdr l)))\n" -" (let ((extra (if (null? rest) (+ extra 1) 0)))\n" -" (loop rest\n" -" (pr (car l) (indent col2 col) extra pp-item)))))\n" -" ((null? l)\n" -" (out \")\" col))\n" -" (else\n" -" (out \")\"\n" -" (pr l\n" -" (indent col2 (out \".\" (indent col2 col)))\n" -" (+ extra 1)\n" -" pp-item))))))))\n" -"\n" -" (set! pp-general\n" -" (lambda (expr col extra named? pp-1 pp-2 pp-3)\n" -"\n" -" (define (tail3 rest col1 col2)\n" -" (pp-down rest col2 col1 extra pp-3))\n" -"\n" -" (define (tail2 rest col1 col2 col3)\n" -" (if (and pp-2 (pair? rest))\n" -" (let* ((val1 (car rest))\n" -" (rest (cdr rest))\n" -" (extra (if (null? rest) (+ extra 1) 0)))\n" -" (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))\n" -" (tail3 rest col1 col2)))\n" -"\n" -" (define (tail1 rest col1 col2 col3)\n" -" (if (and pp-1 (pair? rest))\n" -" (let* ((val1 (car rest))\n" -" (rest (cdr rest))\n" -" (extra (if (null? rest) (+ extra 1) 0)))\n" -" (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))\n" -" (tail2 rest col1 col2 col3)))\n" -"\n" -" (let* ((head (car expr))\n" -" (rest (cdr expr))\n" -" (col* (wr head (out \"(\" col))))\n" -" (if (and named? (pair? rest))\n" -" (let* ((name (car rest))\n" -" (rest (cdr rest))\n" -" (col** (wr name (out \" \" col*))))\n" -" (tail1 rest (+ col indent-general) col** (+ col** 1)))\n" -" (tail1 rest (+ col indent-general) col* (+ col* 1))))))\n" -"\n" -" (set! pp-expr-list\n" -" (lambda (l col extra)\n" -" (pp-list l col extra pp-expr)))\n" -"\n" -" (define (pp-LAMBDA expr col extra)\n" -" (pp-general expr col extra #f pp-expr-list #f pp-expr))\n" -"\n" -" (define (pp-IF expr col extra)\n" -" (pp-general expr col extra #f pp-expr #f pp-expr))\n" -"\n" -" (define (pp-COND expr col extra)\n" -" (pp-call expr col extra pp-expr-list))\n" -"\n" -" (define (pp-CASE expr col extra)\n" -" (pp-general expr col extra #f pp-expr #f pp-expr-list))\n" -"\n" -" (define (pp-AND expr col extra)\n" -" (pp-call expr col extra pp-expr))\n" -"\n" -" (define (pp-LET expr col extra)\n" -" (let* ((rest (cdr expr))\n" -" (named? (and (pair? rest) (symbol? (car rest)))))\n" -" (pp-general expr col extra named? pp-expr-list #f pp-expr)))\n" -"\n" -" (define (pp-BEGIN expr col extra)\n" -" (pp-general expr col extra #f #f #f pp-expr))\n" -"\n" -" (define (pp-DO expr col extra)\n" -" (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))\n" -"\n" -" ; define formatting style (change these to suit your style)\n" -"\n" -" (set! indent-general 2)\n" -"\n" -" (set! max-call-head-width 5)\n" -"\n" -" (set! max-expr-width 50)\n" -"\n" -" (set! style\n" -" (lambda (head)\n" -" (case head\n" -" ((lambda let* letrec define) pp-LAMBDA)\n" -" ((if set!) pp-IF)\n" -" ((cond) pp-COND)\n" -" ((case) pp-CASE)\n" -" ((and or) pp-AND)\n" -" ((let) pp-LET)\n" -" ((begin) pp-BEGIN)\n" -" ((do) pp-DO)\n" -" (else #f))))\n" -"\n" -" (pr obj col 0 pp-expr))\n" -"\n" -" (if width\n" -" (out genwrite:newline-str (pp obj 0))\n" -" (wr obj 0)))\n" -"\n" -" (define (pretty-print obj . opt)\n" -" (let ((port (if (pair? opt) (car opt) (current-output-port))))\n" -" (generic-write obj #f pp-width\n" -" (lambda (s) (display s port) #t))\n" -" (display \"\")))\n" -"\n" -" (export pretty-print))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_20_async_piclib_async = -"(define-library (picrin control async)\n" -" (import (scheme base)\n" -" (picrin control)\n" -" (picrin promise))\n" -"\n" -" (define (promise-unit x)\n" -" (make-promise\n" -" (lambda (resolve _)\n" -" (resolve x))))\n" -"\n" -" (define (promise-bind m f)\n" -" (promise-then m f))\n" -"\n" -" (define-syntax async\n" -" (syntax-rules ()\n" -" ((_ x ...)\n" -" (reset (lambda ()\n" -" (promise-unit (begin x ...)))))))\n" -"\n" -" (define (await m)\n" -" (shift (lambda (f)\n" -" (promise-bind m f))))\n" -"\n" -" (export async await))\n" -; - -static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_20_for_piclib_for = -"(define-library (picrin control list)\n" -" (import (scheme base)\n" -" (picrin control))\n" -"\n" -" (define-syntax for\n" -" (syntax-rules ()\n" -" ((_ expr)\n" -" (reset (lambda () expr)))))\n" -"\n" -" (define (in m)\n" -" (shift (lambda (k)\n" -" (apply append (map k m)))))\n" -"\n" -" (define (yield x)\n" -" (list x))\n" -"\n" -" (define (null . x)\n" -" '())\n" -"\n" -" (export for in yield null))\n" -; - -void -pic_load_piclib(pic_state *pic) -{ - pic_try { - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_base); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_list); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_symbol); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_macro); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_base); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_record); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_array); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_dictionary); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_test); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_experimental_lambda); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_promise); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_async); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_cxr); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_file); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_case_lambda); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_lazy); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_eval); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_r5rs); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_null); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_1); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_8); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_26); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_43); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_60); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_95); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_111); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_user); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_repl); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_10_partcont_piclib_partcont); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_10_pretty_print_pretty_print); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_20_async_piclib_async); - pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_20_for_piclib_for); - } - pic_catch { - /* error! */ - fputs("fatal error: failure in loading built-in.scm\n", stderr); - fputs(pic_errmsg(pic), stderr); - abort(); - } - -#if DEBUG - puts("successfully loaded stdlib"); -#endif -} From aa3b385e27000b766cf93ed032df50b1a5b51656 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 16:21:32 +0900 Subject: [PATCH 007/232] extlibs should be placed under include/picrin/ --- include/picrin.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index e58d5a61..a1893b6f 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -36,10 +36,10 @@ extern "C" { #include #include -#include "xvect/xvect.h" -#include "xhash/xhash.h" -#include "xfile/xfile.h" -#include "xrope/xrope.h" +#include "picrin/xvect.h" +#include "picrin/xhash.h" +#include "picrin/xfile.h" +#include "picrin/xrope.h" #include "picrin/config.h" #include "picrin/util.h" From 1861aff2d101e34125996f2afad64fa33da3e7c7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 16:21:55 +0900 Subject: [PATCH 008/232] import xhash, xrope, xfile, and xvect --- include/picrin/xfile.h | 78 ++++++++ include/picrin/xhash.h | 407 +++++++++++++++++++++++++++++++++++++ include/picrin/xrope.h | 329 ++++++++++++++++++++++++++++++ include/picrin/xvect.h | 185 +++++++++++++++++ xfile.c | 445 +++++++++++++++++++++++++++++++++++++++++ 5 files changed, 1444 insertions(+) create mode 100644 include/picrin/xfile.h create mode 100644 include/picrin/xhash.h create mode 100644 include/picrin/xrope.h create mode 100644 include/picrin/xvect.h create mode 100644 xfile.c diff --git a/include/picrin/xfile.h b/include/picrin/xfile.h new file mode 100644 index 00000000..86fcb458 --- /dev/null +++ b/include/picrin/xfile.h @@ -0,0 +1,78 @@ +#ifndef XFILE_H__ +#define XFILE_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include + +typedef struct { + int ungot; + int flags; + /* 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; +} xFILE; + +/* generic file constructor */ +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 *)); + +/* resource aquisition */ +xFILE *xfopen(const char *, const char *); +xFILE *xfpopen(FILE *); +xFILE *xmopen(); +int xfclose(xFILE *); + +/* buffer management */ +int xfflush(xFILE *); + +/* direct IO with buffering */ +size_t xfread(void *, size_t, size_t, xFILE *); +size_t xfwrite(const void *, size_t, size_t, xFILE *); + +/* indicator positioning */ +long xfseek(xFILE *, long offset, int whence); +long xftell(xFILE *); +void xrewind(xFILE *); + +/* stream status */ +void xclearerr(xFILE *); +int xfeof(xFILE *); +int xferror(xFILE *); + +/* character IO */ +int xfgetc(xFILE *); +char *xfgets(char *, int, xFILE *); +int xfputc(int, xFILE *); +int xfputs(const char *, xFILE *); +char xgetc(xFILE *); +int xgetchar(void); +int xputc(int, xFILE *); +int xputchar(int); +int xputs(char *); +int xungetc(int, xFILE *); + +/* formatted I/O */ +int xprintf(const char *, ...); +int xfprintf(xFILE *, const char *, ...); +int xvfprintf(xFILE *, const char *, va_list); + +/* standard I/O */ +extern xFILE *xstdin; +extern xFILE *xstdout; +extern xFILE *xstderr; + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/xhash.h b/include/picrin/xhash.h new file mode 100644 index 00000000..a249e2ff --- /dev/null +++ b/include/picrin/xhash.h @@ -0,0 +1,407 @@ +#ifndef XHASH_H__ +#define XHASH_H__ + +/* + * Copyright (c) 2013-2014 by Yuichi Nishiwaki + */ + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include +#include +#include + +/* simple object to object hash table */ + +#define XHASH_INIT_SIZE 11 +#define XHASH_RESIZE_RATIO 0.75 + +#define XHASH_ALIGNMENT 3 /* quad word alignment */ +#define XHASH_MASK (~((1 << XHASH_ALIGNMENT) - 1)) +#define XHASH_ALIGN(i) ((((i) - 1) & XHASH_MASK) + (1 << XHASH_ALIGNMENT)) + +typedef struct xh_entry { + struct xh_entry *next; + int hash; + const char *key; /* == val + XHASH_ALIGN(vwidth) */ + char val[]; +} xh_entry; + +#define xh_key(e,type) (*(type *)((e)->key)) +#define xh_val(e,type) (*(type *)((e)->val)) + +typedef int (*xh_hashf)(const void *, void *); +typedef int (*xh_equalf)(const void *, const void *, void *); + +typedef struct xhash { + xh_entry **buckets; + size_t size, count, kwidth, vwidth; + xh_hashf hashf; + xh_equalf equalf; + void *data; +} xhash; + +static inline void xh_init_(xhash *x, size_t, size_t, xh_hashf, xh_equalf, void *); +static inline xh_entry *xh_get_(xhash *x, const void *key); +static inline xh_entry *xh_put_(xhash *x, const void *key, void *val); +static inline void xh_del_(xhash *x, const void *key); +static inline void xh_clear(xhash *x); +static inline void xh_destroy(xhash *x); + +/* 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); + +/* 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); + +/* 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); + +typedef struct xh_iter { + xhash *x; + xh_entry *e, *next; + size_t bidx; +} xh_iter; + +static inline void xh_begin(xh_iter *it, xhash *x); +static inline int xh_next(xh_iter *it); + + +static inline void +xh_bucket_realloc(xhash *x, size_t newsize) +{ + x->size = newsize; + x->buckets = realloc(x->buckets, (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) +{ + x->size = 0; + x->buckets = NULL; + x->count = 0; + x->kwidth = kwidth; + x->vwidth = vwidth; + x->hashf = hashf; + x->equalf = equalf; + x->data = data; + + xh_bucket_realloc(x, XHASH_INIT_SIZE); +} + +static inline xh_entry * +xh_get_(xhash *x, const void *key) +{ + int hash; + size_t idx; + xh_entry *e; + + hash = x->hashf(key, x->data); + idx = ((unsigned)hash) % x->size; + for (e = x->buckets[idx]; e; e = e->next) { + if (e->hash == hash && x->equalf(key, e->key, x->data)) + break; + } + return e; +} + +static inline void +xh_resize_(xhash *x, size_t newsize) +{ + xhash y; + xh_iter it; + size_t idx; + + xh_init_(&y, x->kwidth, x->vwidth, x->hashf, x->equalf, x->data); + xh_bucket_realloc(&y, newsize); + + xh_begin(&it, x); + while (xh_next(&it)) { + idx = ((unsigned)it.e->hash) % y.size; + /* reuse entry object */ + it.e->next = y.buckets[idx]; + y.buckets[idx] = it.e; + y.count++; + } + + free(x->buckets); + + /* copy all members from y to x */ + memcpy(x, &y, sizeof(xhash)); +} + +static inline xh_entry * +xh_put_(xhash *x, const void *key, void *val) +{ + int hash; + size_t idx; + xh_entry *e; + + if ((e = xh_get_(x, key))) { + memcpy(e->val, val, x->vwidth); + return e; + } + + if (x->count + 1 > x->size * XHASH_RESIZE_RATIO) { + xh_resize_(x, x->size * 2 + 1); + } + + hash = x->hashf(key, x->data); + idx = ((unsigned)hash) % x->size; + e = (xh_entry *)malloc(offsetof(xh_entry, val) + XHASH_ALIGN(x->vwidth) + x->kwidth); + e->next = x->buckets[idx]; + e->hash = hash; + e->key = e->val + XHASH_ALIGN(x->vwidth); + memcpy((void *)e->key, key, x->kwidth); + memcpy(e->val, val, x->vwidth); + + x->count++; + + return x->buckets[idx] = e; +} + +static inline void +xh_del_(xhash *x, const void *key) +{ + int hash; + size_t idx; + xh_entry *e, *d; + + hash = x->hashf(key, x->data); + idx = ((unsigned)hash) % x->size; + if (x->buckets[idx]->hash == hash && x->equalf(key, x->buckets[idx]->key, x->data)) { + e = x->buckets[idx]->next; + free(x->buckets[idx]); + x->buckets[idx] = e; + } + else { + for (e = x->buckets[idx]; ; e = e->next) { + if (e->next->hash == hash && x->equalf(key, e->next->key, x->data)) + break; + } + d = e->next->next; + free(e->next); + e->next = d; + } + + x->count--; +} + +static inline void +xh_clear(xhash *x) +{ + size_t i; + xh_entry *e, *d; + + for (i = 0; i < x->size; ++i) { + e = x->buckets[i]; + while (e) { + d = e->next; + free(e); + e = d; + } + x->buckets[i] = NULL; + } + + x->count = 0; +} + +static inline void +xh_destroy(xhash *x) +{ + xh_clear(x); + free(x->buckets); +} + +/* string map */ + +static inline int +xh_str_hash(const void *key, void *data) +{ + const char *str = *(const char **)key; + int hash = 0; + + (void)data; + + while (*str) { + hash = hash * 31 + *str++; + } + return hash; +} + +static inline int +xh_str_equal(const void *key1, const void *key2, void *data) +{ + (void)data; + + return strcmp(*(const char **)key1, *(const char **)key2) == 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); +} + +static inline xh_entry * +xh_get_str(xhash *x, const char *key) +{ + return xh_get_(x, &key); +} + +static inline xh_entry * +xh_put_str(xhash *x, const char *key, void *val) +{ + return xh_put_(x, &key, val); +} + +static inline void +xh_del_str(xhash *x, const char *key) +{ + xh_del_(x, &key); +} + +/* object map */ + +static inline int +xh_ptr_hash(const void *key, void *data) +{ + (void)data; + + return (size_t)*(const void **)key; +} + +static inline int +xh_ptr_equal(const void *key1, const void *key2, void *data) +{ + (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); +} + +static inline xh_entry * +xh_get_ptr(xhash *x, const void *key) +{ + return xh_get_(x, &key); +} + +static inline xh_entry * +xh_put_ptr(xhash *x, const void *key, void *val) +{ + return xh_put_(x, &key, val); +} + +static inline void +xh_del_ptr(xhash *x, const void *key) +{ + xh_del_(x, &key); +} + +/* int map */ + +static inline int +xh_int_hash(const void *key, void *data) +{ + (void)data; + + return *(int *)key; +} + +static inline int +xh_int_equal(const void *key1, const void *key2, void *data) +{ + (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); +} + +static inline xh_entry * +xh_get_int(xhash *x, int key) +{ + return xh_get_(x, &key); +} + +static inline xh_entry * +xh_put_int(xhash *x, int key, void *val) +{ + return xh_put_(x, &key, val); +} + +static inline void +xh_del_int(xhash *x, int key) +{ + xh_del_(x, &key); +} + +/** iteration */ + +static inline void +xh_begin(xh_iter *it, xhash *x) +{ + size_t bidx; + + it->x = x; + + for (bidx = 0; bidx < x->size; ++bidx) { + if (x->buckets[bidx]) + break; + } + it->e = NULL; + it->next = x->buckets[bidx]; + it->bidx = bidx; +} + +static inline int +xh_next(xh_iter *it) +{ + size_t bidx; + + if (! it->next) { + return 0; + } + + it->e = it->next; + if (it->next->next) { + it->next = it->next->next; + return 1; + } + for (bidx = it->bidx + 1; bidx < it->x->size; ++bidx) { + if (it->x->buckets[bidx]) + break; + } + it->next = it->x->buckets[bidx]; + it->bidx = bidx; + return 1; +} + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/xrope.h b/include/picrin/xrope.h new file mode 100644 index 00000000..89842de0 --- /dev/null +++ b/include/picrin/xrope.h @@ -0,0 +1,329 @@ +#ifndef XROPE_H__ +#define XROPE_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include +#include + +/* 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/include/picrin/xvect.h b/include/picrin/xvect.h new file mode 100644 index 00000000..bd72070e --- /dev/null +++ b/include/picrin/xvect.h @@ -0,0 +1,185 @@ +#ifndef XVECT_H__ +#define XVECT_H__ + +/* + * Copyright (c) 2014 by Yuichi Nishiwaki + */ + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include + +typedef struct xvect { + char *data; + size_t size, mask, head, tail, width; +} xvect; + +static inline void xv_init(xvect *, size_t); +static inline void xv_destroy(xvect *); + +static inline size_t xv_size(xvect *); + +static inline void xv_reserve(xvect *, size_t); +static inline void xv_shrink(xvect *, size_t); + +static inline void *xv_get(xvect *, size_t); +static inline void xv_set(xvect *, size_t, void *); + +static inline void xv_push(xvect *, void *); +static inline void *xv_pop(xvect *); + +static inline void *xv_shift(xvect *); +static inline void xv_unshift(xvect *, void *); + +static inline void xv_splice(xvect *, size_t, ptrdiff_t); +static inline void xv_insert(xvect *, size_t, void *); + +static inline void +xv_init(xvect *x, size_t width) +{ + x->data = NULL; + x->width = width; + x->size = 0; + x->mask = -1; + x->head = 0; + x->tail = 0; +} + +static inline void +xv_destroy(xvect *x) +{ + free(x->data); +} + +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) +{ + return x->data + ((x->head + x->size + 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); + xv_set(x, xv_size(x), src); + x->tail = (x->tail + 1) & x->mask; +} + +static inline void * +xv_pop(xvect *x) +{ + x->tail = (x->tail + x->size - 1) & x->mask; + return xv_get(x, xv_size(x)); +} + +static inline void * +xv_shift(xvect *x) +{ + x->head = (x->head + 1) & x->mask; + return xv_get(x, -1); +} + +static inline void +xv_unshift(xvect *x, void *src) +{ + xv_reserve(x, xv_size(x) + 1); + xv_set(x, -1, src); + x->head = (x->head + x->size - 1) & x->mask; +} + +static inline void +xv_splice(xvect *x, size_t i, ptrdiff_t c) +{ + xv_reserve(x, xv_size(x) - c); + xv_rotate(x); + memmove(xv_get(x, i), xv_get(x, i + c), (xv_size(x) - i - c) * x->width); + x->tail -= c; +} + +static inline void +xv_insert(xvect *x, size_t i, void *src) +{ + xv_splice(x, i, -1); + xv_set(x, i, src); +} + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/xfile.c b/xfile.c new file mode 100644 index 00000000..7b2942a2 --- /dev/null +++ b/xfile.c @@ -0,0 +1,445 @@ +#include "xfile.h" + +#include +#include +#include + +#define min(a,b) (((a)>(b))?(b):(a)) +#define max(a,b) (((a)<(b))?(b):(a)) + +#define XF_EOF 1 +#define XF_ERR 2 + +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; +} + +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; +} + +int +xfclose(xFILE *file) +{ + int r; + + r = file->vtable.close(file->vtable.cookie); + if (r == EOF) { + return -1; + } + + free(file); + return 0; +} + +int +xfflush(xFILE *file) +{ + return file->vtable.flush(file->vtable.cookie); +} + +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] = file->ungot; + offset += 1; + file->ungot = -1; + } + while (offset < block) { + n = file->vtable.read(file->vtable.cookie, buf + offset, block - offset); + if (n < 0) { + file->flags |= XF_ERR; + goto exit; + } + if (n == 0) { + file->flags |= XF_EOF; + goto exit; + } + offset += n; + } + memcpy(dst, buf, block); + dst += block; + } + + exit: + return i; +} + +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, block - offset); + if (n < 0) { + file->flags |= XF_ERR; + goto exit; + } + offset += n; + } + dst += block; + } + + exit: + return i; +} + +long +xfseek(xFILE *file, long offset, int whence) +{ + file->ungot = -1; + return file->vtable.seek(file->vtable.cookie, offset, whence); +} + +long +xftell(xFILE *file) +{ + return xfseek(file, 0, SEEK_CUR); +} + +void +xrewind(xFILE *file) +{ + xfseek(file, 0, SEEK_SET); +} + +void +xclearerr(xFILE *file) +{ + file->flags = 0; +} + +int +xfeof(xFILE *file) +{ + return file->flags & XF_EOF; +} + +int +xferror(xFILE *file) +{ + return file->flags & XF_ERR; +} + +int +xfgetc(xFILE *file) +{ + char buf[1]; + + xfread(buf, 1, 1, file); + + if (xfeof(file)) { + return EOF; + } + + return buf[0]; +} + +int +xungetc(int c, xFILE *file) +{ + file->ungot = c; + if (c != EOF) { + file->flags &= ~XF_EOF; + } + return c; +} + +int +xgetchar(void) +{ + return xfgetc(xstdin); +} + +int +xfputc(int c, xFILE *file) +{ + char buf[1]; + + buf[0] = c; + xfwrite(buf, 1, 1, file); + + return buf[0]; +} + +int +xputchar(int c) +{ + return xfputc(c, xstdout); +} + +int +xfputs(const char *str, xFILE *file) +{ + int len; + + len = strlen(str); + xfwrite(str, len, 1, file); + + return 0; +} + +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; +} + +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 sizeof buf; + } +} + +/* + * Derieved xFILE Classes + */ + +static FILE * +unpack(void *cookie) +{ + switch ((long)cookie) { + default: return cookie; + case 0: return stdin; + case 1: return stdout; + case -1: return stderr; + } +} + +static int +file_read(void *cookie, char *ptr, int size) +{ + FILE *file = unpack(cookie); + int r; + + r = fread(ptr, 1, 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 = unpack(cookie); + int r; + + r = fwrite(ptr, 1, size, file); + if (r < size) { + return -1; + } + return r; +} + +static long +file_seek(void *cookie, long pos, int whence) +{ + return fseek(unpack(cookie), pos, whence); +} + +static int +file_flush(void *cookie) +{ + return fflush(unpack(cookie)); +} + +static int +file_close(void *cookie) +{ + return fclose(unpack(cookie)); +} + +xFILE * +xfpopen(FILE *fp) +{ + xFILE *file; + + file = xfunopen(fp, file_read, file_write, file_seek, file_flush, file_close); + if (! file) { + return NULL; + } + + return file; +} + +#define FILE_VTABLE file_read, file_write, file_seek, file_flush, file_close + +static xFILE xfile_stdin = { -1, 0, { (void *)0, FILE_VTABLE } }; +static xFILE xfile_stdout = { -1, 0, { (void *)1, FILE_VTABLE } }; +static xFILE xfile_stderr = { -1, 0, { (void *)-1, FILE_VTABLE } }; + +xFILE *xstdin = &xfile_stdin; +xFILE *xstdout = &xfile_stdout; +xFILE *xstderr = &xfile_stderr; + +struct membuf { + char *buf; + long pos, end, capa; +}; + +static int +mem_read(void *cookie, char *ptr, int size) +{ + struct membuf *mem; + + mem = (struct membuf *)cookie; + + size = min(size, mem->end - mem->pos); + memcpy(ptr, mem->buf + mem->pos, size); + mem->pos += size; + return size; +} + +static int +mem_write(void *cookie, const char *ptr, int size) +{ + struct membuf *mem; + + mem = (struct membuf *)cookie; + + if (mem->pos + size >= mem->capa) { + mem->capa = (mem->pos + size) * 2; + mem->buf = realloc(mem->buf, mem->capa); + } + memcpy(mem->buf + mem->pos, ptr, size); + mem->pos += size; + mem->end = max(mem->pos, mem->end); + return size; +} + +static long +mem_seek(void *cookie, long pos, int whence) +{ + struct membuf *mem; + + mem = (struct 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 int +mem_flush(void *cookie) +{ + (void)cookie; + + return 0; +} + +static int +mem_close(void *cookie) +{ + struct membuf *mem; + + mem = (struct membuf *)cookie; + free(mem->buf); + free(mem); + return 0; +} + +xFILE * +xmopen() +{ + struct membuf *mem; + + mem = (struct membuf *)malloc(sizeof(struct membuf)); + mem->buf = (char *)malloc(BUFSIZ); + mem->pos = 0; + mem->end = 0; + mem->capa = BUFSIZ; + + return xfunopen(mem, mem_read, mem_write, mem_seek, mem_flush, mem_close); +} From da53e6eef30b03474ad3dabf8d85cf41e6852553 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 16:38:40 +0900 Subject: [PATCH 009/232] fix xfile.c's include path --- xfile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xfile.c b/xfile.c index 7b2942a2..60d47a8a 100644 --- a/xfile.c +++ b/xfile.c @@ -1,4 +1,4 @@ -#include "xfile.h" +#include "picrin/xfile.h" #include #include From 112229271150e64f6ff7099f8a8c631f1c834dc8 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 16:44:44 +0900 Subject: [PATCH 010/232] remove default library loader --- init.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/init.c b/init.c index 0d345a01..1dda4964 100644 --- a/init.c +++ b/init.c @@ -63,9 +63,6 @@ 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_contrib(pic_state *); - -void pic_load_piclib(pic_state *); #define DONE pic_gc_arena_restore(pic, ai); @@ -117,8 +114,5 @@ pic_init_core(pic_state *pic) pic_init_record(pic); DONE; pic_init_eval(pic); DONE; pic_init_lib(pic); DONE; - - pic_load_piclib(pic); DONE; - pic_init_contrib(pic); DONE; } } From bd2c5afb02282a19594dad811e887c2de3fd98c4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 16:55:01 +0900 Subject: [PATCH 011/232] remove time.c and system.c --- init.c | 4 -- system.c | 136 ------------------------------------------------------- time.c | 49 -------------------- 3 files changed, 189 deletions(-) delete mode 100644 system.c delete mode 100644 time.c diff --git a/init.c b/init.c index 1dda4964..33c14f55 100644 --- a/init.c +++ b/init.c @@ -43,8 +43,6 @@ 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_time(pic_state *); -void pic_init_system(pic_state *); void pic_init_file(pic_state *); void pic_init_proc(pic_state *); void pic_init_symbol(pic_state *); @@ -94,8 +92,6 @@ pic_init_core(pic_state *pic) pic_init_pair(pic); DONE; pic_init_port(pic); DONE; pic_init_number(pic); DONE; - pic_init_time(pic); DONE; - pic_init_system(pic); DONE; pic_init_file(pic); DONE; pic_init_proc(pic); DONE; pic_init_symbol(pic); DONE; diff --git a/system.c b/system.c deleted file mode 100644 index 20203d27..00000000 --- a/system.c +++ /dev/null @@ -1,136 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#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) -{ - pic_value v = pic_nil_value(); - int i; - - pic_get_args(pic, ""); - - for (i = 0; i < pic->argc; ++i) { - size_t ai = pic_gc_arena_preserve(pic); - - v = pic_cons(pic, pic_obj_value(pic_str_new_cstr(pic, pic->argv[i])), v); - pic_gc_arena_restore(pic, ai); - } - - return pic_reverse(pic, v); -} - -static pic_value -pic_system_exit(pic_state *pic) -{ - pic_value v; - int argc, status = EXIT_SUCCESS; - - argc = pic_get_args(pic, "|o", &v); - if (argc == 1) { - switch (pic_type(v)) { - case PIC_TT_FLOAT: - status = (int)pic_float(v); - break; - case PIC_TT_INT: - status = pic_int(v); - break; - default: - break; - } - } - - pic_close(pic); - - exit(status); -} - -static pic_value -pic_system_emergency_exit(pic_state *pic) -{ - pic_value v; - int argc, status = EXIT_FAILURE; - - argc = pic_get_args(pic, "|o", &v); - if (argc == 1) { - switch (pic_type(v)) { - case PIC_TT_FLOAT: - status = (int)pic_float(v); - break; - case PIC_TT_INT: - status = pic_int(v); - break; - default: - break; - } - } - - _Exit(status); -} - -static pic_value -pic_system_getenv(pic_state *pic) -{ - char *str, *val; - - pic_get_args(pic, "z", &str); - - val = getenv(str); - - if (val == NULL) - return pic_nil_value(); - else - return pic_obj_value(pic_str_new_cstr(pic, val)); -} - -static pic_value -pic_system_getenvs(pic_state *pic) -{ - char **envp; - pic_value data = pic_nil_value(); - size_t ai = pic_gc_arena_preserve(pic); - - pic_get_args(pic, ""); - - if (! pic->envp) { - return pic_nil_value(); - } - - for (envp = pic->envp; *envp; ++envp) { - pic_str *key, *val; - int i; - - for (i = 0; (*envp)[i] != '='; ++i) - ; - - key = pic_str_new(pic, *envp, i); - val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key))); - - /* push */ - data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, data); - } - - return data; -} - -void -pic_init_system(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme process-context)") { - pic_defun(pic, "command-line", pic_system_cmdline); - pic_defun(pic, "exit", pic_system_exit); - pic_defun(pic, "emergency-exit", pic_system_emergency_exit); - pic_defun(pic, "get-environment-variable", pic_system_getenv); - pic_defun(pic, "get-environment-variables", pic_system_getenvs); - } -} diff --git a/time.c b/time.c deleted file mode 100644 index 8e42dc8e..00000000 --- a/time.c +++ /dev/null @@ -1,49 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" - -#define UTC_TAI_DIFF 35 - -static pic_value -pic_current_second(pic_state *pic) -{ - time_t t; - - pic_get_args(pic, ""); - - time(&t); - return pic_float_value((double)t + UTC_TAI_DIFF); -} - -static pic_value -pic_current_jiffy(pic_state *pic) -{ - clock_t c; - - pic_get_args(pic, ""); - - c = clock(); - return pic_int_value(c); -} - -static pic_value -pic_jiffies_per_second(pic_state *pic) -{ - pic_get_args(pic, ""); - - return pic_int_value(CLOCKS_PER_SEC); -} - -void -pic_init_time(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme time)") { - pic_defun(pic, "current-second", pic_current_second); - pic_defun(pic, "current-jiffy", pic_current_jiffy); - pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); - } -} From 6a1b7c372d9fb0f06d983cd5ffff6307c9e2c6ab Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 16:55:51 +0900 Subject: [PATCH 012/232] remove eval.c and load.c --- eval.c | 39 ---------------------- include/picrin.h | 3 -- init.c | 4 --- load.c | 87 ------------------------------------------------ vm.c | 10 ++++++ 5 files changed, 10 insertions(+), 133 deletions(-) delete mode 100644 eval.c delete mode 100644 load.c diff --git a/eval.c b/eval.c deleted file mode 100644 index 5a037c94..00000000 --- a/eval.c +++ /dev/null @@ -1,39 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/macro.h" - -pic_value -pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) -{ - struct pic_proc *proc; - - proc = pic_compile(pic, program, lib); - - return pic_apply(pic, proc, pic_nil_value()); -} - -static pic_value -pic_eval_eval(pic_state *pic) -{ - pic_value program, spec; - struct pic_lib *lib; - - pic_get_args(pic, "oo", &program, &spec); - - lib = pic_find_library(pic, spec); - if (lib == NULL) { - pic_errorf(pic, "no library found: ~s", spec); - } - return pic_eval(pic, program, lib); -} - -void -pic_init_eval(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme eval)") { - pic_defun(pic, "eval", pic_eval_eval); - } -} diff --git a/include/picrin.h b/include/picrin.h index a1893b6f..cbe379ce 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -160,9 +160,6 @@ pic_value pic_read_cstr(pic_state *, const char *); pic_list pic_parse_file(pic_state *, FILE *); /* #f for incomplete input */ pic_list pic_parse_cstr(pic_state *, const char *); -pic_value pic_load(pic_state *, const char *); -pic_value pic_load_cstr(pic_state *, const char *); - pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply0(pic_state *, struct pic_proc *); pic_value pic_apply1(pic_state *, struct pic_proc *, pic_value); diff --git a/init.c b/init.c index 33c14f55..715b6cc1 100644 --- a/init.c +++ b/init.c @@ -54,12 +54,10 @@ 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_load(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 *); #define DONE pic_gc_arena_restore(pic, ai); @@ -103,12 +101,10 @@ pic_init_core(pic_state *pic) pic_init_str(pic); DONE; pic_init_macro(pic); DONE; pic_init_var(pic); DONE; - pic_init_load(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; } } diff --git a/load.c b/load.c deleted file mode 100644 index 440b45e2..00000000 --- a/load.c +++ /dev/null @@ -1,87 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/pair.h" - -pic_value -pic_load_cstr(pic_state *pic, const char *src) -{ - size_t ai; - pic_value v, exprs; - struct pic_proc *proc; - - exprs = pic_parse_cstr(pic, src); - if (pic_undef_p(exprs)) { - pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); - } - - pic_for_each (v, exprs) { - ai = pic_gc_arena_preserve(pic); - - proc = pic_compile(pic, v, pic->lib); - if (proc == NULL) { - pic_error(pic, "load: compilation failure"); - } - - pic_apply(pic, proc, pic_nil_value()); - - pic_gc_arena_restore(pic, ai); - } - - return pic_none_value(); -} - -pic_value -pic_load(pic_state *pic, const char *fn) -{ - FILE *file; - size_t ai; - pic_value v, exprs; - struct pic_proc *proc; - - file = fopen(fn, "r"); - if (file == NULL) { - pic_errorf(pic, "load: could not read file \"%s\"", fn); - } - - exprs = pic_parse_file(pic, file); - if (pic_undef_p(exprs)) { - pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); - } - - pic_for_each (v, exprs) { - ai = pic_gc_arena_preserve(pic); - - proc = pic_compile(pic, v, pic->lib); - if (proc == NULL) { - pic_error(pic, "load: compilation failure"); - } - - pic_apply(pic, proc, pic_nil_value()); - - pic_gc_arena_restore(pic, ai); - } - - return pic_none_value(); -} - -static pic_value -pic_load_load(pic_state *pic) -{ - pic_value envid; - char *fn; - - pic_get_args(pic, "z|o", &fn, &envid); - - return pic_load(pic, fn); -} - -void -pic_init_load(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme load)") { - pic_defun(pic, "load", pic_load_load); - } -} diff --git a/vm.c b/vm.c index 99f12f82..757fe7a3 100644 --- a/vm.c +++ b/vm.c @@ -1055,3 +1055,13 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) return pic_car(pic, args); } } + +pic_value +pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) +{ + struct pic_proc *proc; + + proc = pic_compile(pic, program, lib); + + return pic_apply(pic, proc, pic_nil_value()); +} From 3225a891228f89d36a86fc0558555bf47ba4cec1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 16:57:41 +0900 Subject: [PATCH 013/232] remove features and librarires procedures --- init.c | 34 ---------------------------------- 1 file changed, 34 deletions(-) diff --git a/init.c b/init.c index 715b6cc1..babdf322 100644 --- a/init.c +++ b/init.c @@ -11,34 +11,6 @@ #include "picrin/macro.h" #include "picrin/error.h" -static pic_value -pic_features(pic_state *pic) -{ - pic_value features = pic_nil_value(); - - pic_get_args(pic, ""); - - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features); - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features); - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features); - - return features; -} - -static pic_value -pic_libraries(pic_state *pic) -{ - pic_value libs = pic_nil_value(), lib; - - pic_get_args(pic, ""); - - pic_for_each (lib, pic->libs) { - libs = pic_cons(pic, pic_car(pic, lib), libs); - } - - return libs; -} - void pic_init_bool(pic_state *); void pic_init_pair(pic_state *); void pic_init_port(pic_state *); @@ -79,13 +51,7 @@ pic_init_core(pic_state *pic) pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); } - pic_deflibrary (pic, "(picrin library)") { - pic_defun(pic, "libraries", pic_libraries); - } - pic_deflibrary (pic, "(scheme base)") { - pic_defun(pic, "features", pic_features); - pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; pic_init_port(pic); DONE; From 4cf8f3d7f6b822c29be481f0d1f6f0a856bd847b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 16:59:01 +0900 Subject: [PATCH 014/232] remove file.c --- file.c | 119 --------------------------------------------------------- init.c | 2 - 2 files changed, 121 deletions(-) delete mode 100644 file.c diff --git a/file.c b/file.c deleted file mode 100644 index befac195..00000000 --- a/file.c +++ /dev/null @@ -1,119 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/port.h" -#include "picrin/error.h" - -static noreturn void -file_error(pic_state *pic, const char *msg) -{ - pic_throw(pic, PIC_ERROR_FILE, msg, pic_nil_value()); -} - -static pic_value -generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) -{ - struct pic_port *port; - xFILE *file; - - file = xfopen(fname, mode); - if (! file) { - file_error(pic, "could not open file"); - } - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = flags; - port->status = PIC_PORT_OPEN; - - return pic_obj_value(port); -} - -pic_value -pic_file_open_input_file(pic_state *pic) -{ - static const short flags = PIC_PORT_IN | PIC_PORT_TEXT; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "r", flags); -} - -pic_value -pic_file_open_input_binary_file(pic_state *pic) -{ - static const short flags = PIC_PORT_IN | PIC_PORT_BINARY; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "rb", flags); -} - -pic_value -pic_file_open_output_file(pic_state *pic) -{ - static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "w", flags); -} - -pic_value -pic_file_open_output_binary_file(pic_state *pic) -{ - static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "wb", flags); -} - -pic_value -pic_file_exists_p(pic_state *pic) -{ - char *fname; - FILE *fp; - - pic_get_args(pic, "z", &fname); - - fp = fopen(fname, "r"); - if (fp) { - fclose(fp); - return pic_true_value(); - } else { - return pic_false_value(); - } -} - -pic_value -pic_file_delete(pic_state *pic) -{ - char *fname; - - pic_get_args(pic, "z", &fname); - - if (remove(fname) != 0) { - file_error(pic, "file cannot be deleted"); - } - return pic_none_value(); -} - -void -pic_init_file(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme file)") { - pic_defun(pic, "open-input-file", pic_file_open_input_file); - pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file); - pic_defun(pic, "open-output-file", pic_file_open_output_file); - pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file); - pic_defun(pic, "file-exists?", pic_file_exists_p); - pic_defun(pic, "delete-file", pic_file_delete); - } -} diff --git a/init.c b/init.c index babdf322..01496673 100644 --- a/init.c +++ b/init.c @@ -15,7 +15,6 @@ 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_file(pic_state *); void pic_init_proc(pic_state *); void pic_init_symbol(pic_state *); void pic_init_vector(pic_state *); @@ -56,7 +55,6 @@ pic_init_core(pic_state *pic) pic_init_pair(pic); DONE; pic_init_port(pic); DONE; pic_init_number(pic); DONE; - pic_init_file(pic); DONE; pic_init_proc(pic); DONE; pic_init_symbol(pic); DONE; pic_init_vector(pic); DONE; From e0831c1aa3c963111859278579a42dba997dc75d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 17:10:25 +0900 Subject: [PATCH 015/232] change the interface of call/cc --- cont.c | 34 +++++++++------------------------- include/picrin/cont.h | 3 +++ 2 files changed, 12 insertions(+), 25 deletions(-) diff --git a/cont.c b/cont.c index 30d26568..b31d54f0 100644 --- a/cont.c +++ b/cont.c @@ -7,7 +7,6 @@ #include #include "picrin.h" -#include "picrin/proc.h" #include "picrin/cont.h" #include "picrin/pair.h" #include "picrin/error.h" @@ -252,23 +251,21 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st } noreturn static pic_value -cont_call(pic_state *pic) +pic_cont_continue(pic_state *pic) { struct pic_proc *proc; size_t argc; - pic_value *argv; - struct pic_cont *cont; + pic_value cont, *argv; proc = pic_get_proc(pic); - pic_get_args(pic, "*", &argc, &argv); + pic_get_args(pic, "o*", &cont, &argc, &argv); - cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont")); - cont->results = pic_list_by_array(pic, argc, argv); + pic_assert_type(pic, cont, cont); /* execute guard handlers */ - walk_to_block(pic, pic->blk, cont->blk); + walk_to_block(pic, pic->blk, pic_cont_ptr(cont)->blk); - restore_cont(pic, cont); + restore_cont(pic, pic_cont_ptr(cont)); } pic_value @@ -281,14 +278,7 @@ pic_callcc(pic_state *pic, struct pic_proc *proc) return pic_values_by_list(pic, cont->results); } else { - struct pic_proc *c; - - c = pic_proc_new(pic, cont_call, ""); - - /* save the continuation object in proc */ - pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); - - return pic_apply1(pic, proc, pic_obj_value(c)); + return pic_apply1(pic, proc, pic_obj_value(cont)); } } @@ -302,14 +292,7 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc) return pic_values_by_list(pic, cont->results); } else { - struct pic_proc *c; - - c = pic_proc_new(pic, cont_call, ""); - - /* save the continuation object in proc */ - pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); - - return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c))); + return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(cont))); } } @@ -365,6 +348,7 @@ pic_init_cont(pic_state *pic) { pic_defun(pic, "call-with-current-continuation", pic_cont_callcc); pic_defun(pic, "call/cc", pic_cont_callcc); + pic_defun(pic, "continue", pic_cont_continue); 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); diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 0a0da9f1..6f35de38 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -43,6 +43,9 @@ struct pic_cont { pic_value results; }; +#define pic_cont_p(o) (pic_type(o) == PIC_TT_CONT) +#define pic_cont_ptr(o) ((struct pic_cont *)pic_ptr(o)) + pic_value pic_values0(pic_state *); pic_value pic_values1(pic_state *, pic_value); pic_value pic_values2(pic_state *, pic_value, pic_value); From 5d1e8ede17c55d3f85b766de4e78f548fc6ff30e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 17:12:07 +0900 Subject: [PATCH 016/232] remove call/cc (the alias to call-with-current-continuation) --- cont.c | 1 - 1 file changed, 1 deletion(-) diff --git a/cont.c b/cont.c index b31d54f0..9e8eff57 100644 --- a/cont.c +++ b/cont.c @@ -347,7 +347,6 @@ void pic_init_cont(pic_state *pic) { pic_defun(pic, "call-with-current-continuation", pic_cont_callcc); - pic_defun(pic, "call/cc", pic_cont_callcc); pic_defun(pic, "continue", pic_cont_continue); pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind); pic_defun(pic, "values", pic_cont_values); From 9ee9f7b8a3f063bf518750611d6d5a719777ab89 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 17:14:21 +0900 Subject: [PATCH 017/232] remove macro definition helper procedures --- macro.c | 64 --------------------------------------------------------- 1 file changed, 64 deletions(-) diff --git a/macro.c b/macro.c index e9c9b64b..0ebda4ae 100644 --- a/macro.c +++ b/macro.c @@ -397,63 +397,6 @@ pic_identifier_p(pic_state *pic, pic_value obj) return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj)); } -static pic_value -pic_macro_gensym(pic_state *pic) -{ - static const char skel[] = ".g"; - pic_sym uniq; - - pic_get_args(pic, ""); - - uniq = pic_gensym(pic, pic_intern_cstr(pic, skel)); - return pic_sym_value(uniq); -} - -static pic_value -pic_macro_ungensym(pic_state *pic) -{ - pic_sym sym; - - pic_get_args(pic, "m", &sym); - - return pic_sym_value(pic_ungensym(pic, sym)); -} - -static pic_value -pic_macro_macroexpand(pic_state *pic) -{ - pic_value expr; - - pic_get_args(pic, "o", &expr); - - return pic_macroexpand(pic, expr, pic->lib); -} - -static pic_value -pic_macro_macroexpand_1(pic_state *pic) -{ - struct pic_senv *senv = pic->lib->env; - struct pic_macro *mac; - pic_value expr; - pic_sym sym; - - pic_get_args(pic, "o", &expr); - - if (pic_sym_p(expr)) { - if (pic_interned_p(pic, pic_sym(expr))) { - return pic_values2(pic, macroexpand_symbol(pic, pic_sym(expr), senv), pic_true_value()); - } - } - if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) { - sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv); - if ((mac = find_macro(pic, sym)) != NULL) { - return pic_values2(pic, macroexpand_macro(pic, mac, expr, senv), pic_true_value()); - } - } - - return pic_values2(pic, expr, pic_false_value()); /* no expansion occurred */ -} - static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -484,11 +427,4 @@ pic_init_macro(pic_state *pic) pic_defun(pic, "identifier?", pic_macro_identifier_p); pic_defun(pic, "make-identifier", pic_macro_make_identifier); } - - pic_deflibrary (pic, "(picrin macro)") { - pic_defun(pic, "gensym", pic_macro_gensym); - pic_defun(pic, "ungensym", pic_macro_ungensym); - pic_defun(pic, "macroexpand", pic_macro_macroexpand); - pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1); - } } From 52c377768ea73cb8bfffab80f2dbb9055f3495b6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 17:40:40 +0900 Subject: [PATCH 018/232] downgrade xvect.h due to xvect's unknown bug --- include/picrin/xvect.h | 136 +++++++---------------------------------- 1 file changed, 21 insertions(+), 115 deletions(-) diff --git a/include/picrin/xvect.h b/include/picrin/xvect.h index bd72070e..ec68a2cb 100644 --- a/include/picrin/xvect.h +++ b/include/picrin/xvect.h @@ -2,51 +2,40 @@ #define XVECT_H__ /* - * Copyright (c) 2014 by Yuichi Nishiwaki + * Copyright (c) 2014 by Yuichi Nishiwaki */ #if defined(__cplusplus) extern "C" { #endif -#include #include #include typedef struct xvect { char *data; - size_t size, mask, head, tail, width; + size_t size, capa, width; } xvect; static inline void xv_init(xvect *, size_t); static inline void xv_destroy(xvect *); -static inline size_t xv_size(xvect *); - static inline void xv_reserve(xvect *, size_t); -static inline void xv_shrink(xvect *, size_t); static inline void *xv_get(xvect *, size_t); static inline void xv_set(xvect *, size_t, void *); static inline void xv_push(xvect *, void *); +static inline void *xv_peek(xvect *); static inline void *xv_pop(xvect *); -static inline void *xv_shift(xvect *); -static inline void xv_unshift(xvect *, void *); - -static inline void xv_splice(xvect *, size_t, ptrdiff_t); -static inline void xv_insert(xvect *, size_t, void *); - static inline void xv_init(xvect *x, size_t width) { x->data = NULL; - x->width = width; x->size = 0; - x->mask = -1; - x->head = 0; - x->tail = 0; + x->capa = 0; + x->width = width; } static inline void @@ -55,127 +44,44 @@ xv_destroy(xvect *x) free(x->data); } -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) +xv_reserve(xvect *x, size_t newcapa) { - 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 */ - } + x->data = realloc(x->data, newcapa * x->width); + x->capa = newcapa; } static inline void * xv_get(xvect *x, size_t i) { - return x->data + ((x->head + x->size + i) & x->mask) * x->width; + return x->data + i * x->width; } static inline void xv_set(xvect *x, size_t i, void *src) { - memcpy(xv_get(x, i), src, x->width); + memcpy(x->data + i * x->width, src, x->width); } static inline void xv_push(xvect *x, void *src) { - xv_reserve(x, xv_size(x) + 1); - xv_set(x, xv_size(x), src); - x->tail = (x->tail + 1) & x->mask; + if (x->capa <= x->size + 1) { + xv_reserve(x, x->size * 2 + 1); + } + xv_set(x, x->size++, src); +} + +static inline void * +xv_peek(xvect *x) +{ + return xv_get(x, x->size); } static inline void * xv_pop(xvect *x) { - x->tail = (x->tail + x->size - 1) & x->mask; - return xv_get(x, xv_size(x)); -} - -static inline void * -xv_shift(xvect *x) -{ - x->head = (x->head + 1) & x->mask; - return xv_get(x, -1); -} - -static inline void -xv_unshift(xvect *x, void *src) -{ - xv_reserve(x, xv_size(x) + 1); - xv_set(x, -1, src); - x->head = (x->head + x->size - 1) & x->mask; -} - -static inline void -xv_splice(xvect *x, size_t i, ptrdiff_t c) -{ - xv_reserve(x, xv_size(x) - c); - xv_rotate(x); - memmove(xv_get(x, i), xv_get(x, i + c), (xv_size(x) - i - c) * x->width); - x->tail -= c; -} - -static inline void -xv_insert(xvect *x, size_t i, void *src) -{ - xv_splice(x, i, -1); - xv_set(x, i, src); + return xv_get(x, --x->size); } #if defined(__cplusplus) From a03efeb0d3a143fd5acc1d0a618f788d2295007a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 17:41:01 +0900 Subject: [PATCH 019/232] remove procedures originally introduced for compatibility --- number.c | 3 --- string.c | 1 - 2 files changed, 4 deletions(-) diff --git a/number.c b/number.c index ed6ce95c..05b77046 100644 --- a/number.c +++ b/number.c @@ -897,9 +897,6 @@ pic_init_number(pic_state *pic) pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient); pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder); pic_defun(pic, "truncate/", pic_number_trunc2); - pic_defun(pic, "modulo", pic_number_floor_remainder); - pic_defun(pic, "quotient", pic_number_trunc_quotient); - pic_defun(pic, "remainder", pic_number_trunc_remainder); pic_gc_arena_restore(pic, ai); pic_defun(pic, "gcd", pic_number_gcd); diff --git a/string.c b/string.c index ab679f50..6533b45f 100644 --- a/string.c +++ b/string.c @@ -420,5 +420,4 @@ pic_init_str(pic_state *pic) pic_defun(pic, "string-copy!", pic_str_string_copy_ip); pic_defun(pic, "string-append", pic_str_string_append); pic_defun(pic, "string-fill!", pic_str_string_fill_ip); - pic_defun(pic, "substring", pic_str_string_copy); } From 1656367be2fe272a20a3a3a322ae9c787b18fc1b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 17:41:29 +0900 Subject: [PATCH 020/232] accept '(define (f a b) ...)' style in C level --- macro.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/macro.c b/macro.c index 0ebda4ae..cc56ca3c 100644 --- a/macro.c +++ b/macro.c @@ -163,6 +163,13 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) 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)))); + } + if (pic_length(pic, expr) != 3) { pic_error(pic, "syntax error"); } From b33a2e629cb8b5c38532c94dfdb7f2c807a6509c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 26 Aug 2014 02:47:32 +0900 Subject: [PATCH 021/232] grammer fix for README --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index e7232ff3..4c14ac09 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Benz -Benz is a core module of the Picrin Scheme interpreter. It includes every components necessary to run in a stand-alone environment. +Benz is core module of the Picrin Scheme interpreter. It includes all components necessary to run in a stand-alone environment. ## Authors From 876e40bfa58cfdcc7b9fcb0e486895ce5fc3e8fb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 26 Aug 2014 13:29:36 +0900 Subject: [PATCH 022/232] add pic_intern_str --- include/picrin.h | 1 + symbol.c | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/include/picrin.h b/include/picrin.h index cbe379ce..9b063923 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -146,6 +146,7 @@ void pic_defun(pic_state *, const char *, pic_func_t); 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); diff --git a/symbol.c b/symbol.c index 2add0769..b936f48f 100644 --- a/symbol.c +++ b/symbol.c @@ -37,6 +37,12 @@ pic_intern_cstr(pic_state *pic, const char *str) return pic_intern(pic, str, strlen(str)); } +pic_sym +pic_intern_str(pic_state *pic, pic_str *str) +{ + return pic_intern_cstr(pic, pic_str_cstr(str)); +} + pic_sym pic_gensym(pic_state *pic, pic_sym base) { From a94ef9433d5caa5b1b334bcfc34166613285c9c7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 26 Aug 2014 13:30:08 +0900 Subject: [PATCH 023/232] change interface of format functions --- error.c | 4 ++-- include/picrin/string.h | 10 +++++++--- string.c | 44 ++++++++++++++++++++++++++++++++++++----- write.c | 2 +- 4 files changed, 49 insertions(+), 11 deletions(-) diff --git a/error.c b/error.c index f4d46f5e..71d24c71 100644 --- a/error.c +++ b/error.c @@ -27,7 +27,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...) pic_value err_line; va_start(ap, fmt); - err_line = pic_vformat(pic, fmt, ap); + 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)))); @@ -130,7 +130,7 @@ pic_errorf(pic_state *pic, const char *fmt, ...) const char *msg; va_start(ap, fmt); - err_line = pic_vformat(pic, fmt, ap); + err_line = pic_xvformat(pic, fmt, ap); va_end(ap); msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))); diff --git a/include/picrin/string.h b/include/picrin/string.h index c2564ffe..3df116cf 100644 --- a/include/picrin/string.h +++ b/include/picrin/string.h @@ -31,9 +31,13 @@ int pic_strcmp(pic_str *, pic_str *); const char *pic_str_cstr(pic_str *); -pic_value pic_format(pic_state *, const char *, ...); -pic_value pic_vformat(pic_state *, const char *, va_list); -pic_value pic_vfformat(pic_state *, xFILE *, const char *, va_list); +pic_str *pic_format(pic_state *, const char *, ...); +pic_str *pic_vformat(pic_state *, const char *, va_list); +void pic_vfformat(pic_state *, xFILE *, const char *, va_list); + +pic_value pic_xformat(pic_state *, const char *, ...); +pic_value pic_xvformat(pic_state *, const char *, va_list); +pic_value pic_xvfformat(pic_state *, xFILE *, const char *, va_list); #if defined(__cplusplus) } diff --git a/string.c b/string.c index 6533b45f..92a3c569 100644 --- a/string.c +++ b/string.c @@ -137,7 +137,7 @@ pic_str_cstr(pic_str *str) } pic_value -pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) +pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) { char c; pic_value irrs = pic_nil_value(); @@ -205,14 +205,14 @@ pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) } pic_value -pic_vformat(pic_state *pic, const char *fmt, va_list ap) +pic_xvformat(pic_state *pic, const char *fmt, va_list ap) { struct pic_port *port; pic_value irrs; port = pic_open_output_string(pic); - irrs = pic_vfformat(pic, port->file, fmt, ap); + irrs = pic_xvfformat(pic, port->file, fmt, ap); irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs); pic_close_port(pic, port); @@ -220,18 +220,52 @@ pic_vformat(pic_state *pic, const char *fmt, va_list ap) } pic_value -pic_format(pic_state *pic, const char *fmt, ...) +pic_xformat(pic_state *pic, const char *fmt, ...) { va_list ap; pic_value objs; va_start(ap, fmt); - objs = pic_vformat(pic, fmt, ap); + objs = pic_xvformat(pic, fmt, ap); va_end(ap); return objs; } +void +pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) +{ + pic_xvfformat(pic, file, fmt, ap); +} + +pic_str * +pic_vformat(pic_state *pic, const char *fmt, va_list ap) +{ + struct pic_port *port; + pic_str *str; + + port = pic_open_output_string(pic); + + pic_vfformat(pic, port->file, fmt, ap); + str = pic_get_output_string(pic, port); + + pic_close_port(pic, port); + return str; +} + +pic_str * +pic_format(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_str *str; + + va_start(ap, fmt); + str = pic_vformat(pic, fmt, ap); + va_end(ap); + + return str; +} + static pic_value pic_str_string_p(pic_state *pic) { diff --git a/write.c b/write.c index 70a547b9..1ae61195 100644 --- a/write.c +++ b/write.c @@ -442,7 +442,7 @@ pic_printf(pic_state *pic, const char *fmt, ...) va_start(ap, fmt); - str = pic_str_ptr(pic_car(pic, pic_vformat(pic, fmt, ap))); + str = pic_str_ptr(pic_car(pic, pic_xvformat(pic, fmt, ap))); va_end(ap); From 582cf626ea86d8b24bdb2de227cb0c1f6767a1a9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 26 Aug 2014 13:30:34 +0900 Subject: [PATCH 024/232] refactor import_table --- lib.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib.c b/lib.c index 45351083..41202426 100644 --- a/lib.c +++ b/lib.c @@ -74,6 +74,7 @@ import_table(pic_state *pic, pic_value spec) struct pic_lib *lib; struct pic_dict *imports, *dict; pic_value val, id; + pic_sym sym; xh_iter it; imports = pic_dict_new(pic); @@ -99,7 +100,10 @@ import_table(pic_state *pic, pic_value spec) dict = import_table(pic, pic_cadr(pic, spec)); xh_begin(&it, &dict->hash); while (xh_next(&it)) { - pic_dict_set(pic, imports, pic_intern_cstr(pic, pic_str_cstr(pic_strcat(pic, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(pic_car(pic, pic_cddr(pic, spec))))), pic_str_new_cstr(pic, pic_symbol_name(pic, xh_key(it.e, pic_sym)))))), xh_val(it.e, pic_value)); + id = pic_sym_value(xh_key(it.e, pic_sym)); + val = pic_list_ref(pic, spec, 2); + sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, id)); + pic_dict_set(pic, imports, sym, xh_val(it.e, pic_value)); } return imports; } From 3542ea79acc5d239a296f8badea174ef8e59049c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 26 Aug 2014 13:30:40 +0900 Subject: [PATCH 025/232] report errors when import_table raised an error --- lib.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lib.c b/lib.c index 41202426..defb4b4b 100644 --- a/lib.c +++ b/lib.c @@ -132,7 +132,12 @@ import(pic_state *pic, pic_value spec) struct pic_dict *imports; xh_iter it; - imports = import_table(pic, spec); + pic_try { + imports = import_table(pic, spec); + } + pic_catch { + pic_errorf(pic, "syntax error around import statement: ~s", spec); + } xh_begin(&it, &imports->hash); while (xh_next(&it)) { From 339f55038937ffccbf5af916f696511e8551e01d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 31 Aug 2014 02:39:09 +0900 Subject: [PATCH 026/232] dictionary-ref comes with two values --- dict.c | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/dict.c b/dict.c index 1018834e..4a709421 100644 --- a/dict.c +++ b/dict.c @@ -4,6 +4,7 @@ #include "picrin.h" #include "picrin/dict.h" +#include "picrin/cont.h" struct pic_dict * pic_dict_new(pic_state *pic) @@ -92,7 +93,11 @@ pic_dict_dict_ref(pic_state *pic) pic_get_args(pic, "dm", &dict, &key); - return pic_dict_ref(pic, 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()); + } } static pic_value @@ -109,17 +114,6 @@ pic_dict_dict_set(pic_state *pic) return pic_none_value(); } -static pic_value -pic_dict_dict_has_p(pic_state *pic) -{ - struct pic_dict *dict; - pic_sym key; - - pic_get_args(pic, "dm", &dict, &key); - - return pic_bool_value(pic_dict_has(pic, dict, key)); -} - static pic_value pic_dict_dict_del(pic_state *pic) { @@ -166,7 +160,6 @@ pic_init_dict(pic_state *pic) pic_deflibrary (pic, "(picrin dictionary)") { pic_defun(pic, "make-dictionary", pic_dict_dict); pic_defun(pic, "dictionary?", pic_dict_dict_p); - pic_defun(pic, "dictionary-has?", pic_dict_dict_has_p); pic_defun(pic, "dictionary-ref", pic_dict_dict_ref); pic_defun(pic, "dictionary-set!", pic_dict_dict_set); pic_defun(pic, "dictionary-delete", pic_dict_dict_del); From e4ae3585eb7c0a6bc7940f29122a9fd9e1f90533 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 31 Aug 2014 02:40:17 +0900 Subject: [PATCH 027/232] delete needless include --- init.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/init.c b/init.c index 01496673..e0194f96 100644 --- a/init.c +++ b/init.c @@ -2,8 +2,6 @@ * See Copyright Notice in picrin.h */ -#include - #include "picrin.h" #include "picrin/pair.h" #include "picrin/read.h" From 5c090a48ef25730d95e0b9cd6ab1bf624a1ff937 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 02:20:52 +0900 Subject: [PATCH 028/232] remove unused config flags --- include/picrin/config.h | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/include/picrin/config.h b/include/picrin/config.h index 79b8fc3c..5291a927 100644 --- a/include/picrin/config.h +++ b/include/picrin/config.h @@ -2,18 +2,12 @@ * See Copyright Notice in picrin.h */ -/** contribution libraries */ -/* #define PIC_CONTRIB_INITS */ - /** switch normal VM and direct threaded VM */ /* #define PIC_DIRECT_THREADED_VM 1 */ /** switch internal value representation */ /* #define PIC_NAN_BOXING 1 */ -/** enable readline module */ -/* #define PIC_ENABLE_READLINE 1 */ - /** treat false value as none */ /* #define PIC_NONE_IS_FALSE 1 */ @@ -47,10 +41,6 @@ # error please activate c99 features #endif -#ifndef PIC_CONTRIB_INITS -# define PIC_CONTRIB_INITS -#endif - #ifndef PIC_DIRECT_THREADED_VM # if defined(__GNUC__) || defined(__CLANG__) # define PIC_DIRECT_THREADED_VM 1 @@ -63,14 +53,6 @@ # endif #endif -#ifndef PIC_ENABLE_READLINE -# if PIC_READLINE_FOUND -# define PIC_ENABLE_READLINE 1 -# else -# define PIC_ENABLE_READLINE 0 -# endif -#endif - #ifndef PIC_NONE_IS_FALSE # define PIC_NONE_IS_FALSE 1 #endif From 129c4c1bd9d3f0992212c9058097e7f2163b20ba Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 08:56:59 +0900 Subject: [PATCH 029/232] vm_tear_off should happen in cont. saving, not in restoring --- cont.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/cont.c b/cont.c index 9e8eff57..48d26924 100644 --- a/cont.c +++ b/cont.c @@ -112,9 +112,12 @@ native_stack_length(pic_state *pic, char **pos) static void save_cont(pic_state *pic, struct pic_cont **c) { + void pic_vm_tear_off(pic_state *); struct pic_cont *cont; char *pos; + pic_vm_tear_off(pic); /* tear off */ + cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT); cont->blk = pic->blk; @@ -162,13 +165,10 @@ native_stack_extend(pic_state *pic, struct pic_cont *cont) noreturn static void restore_cont(pic_state *pic, struct pic_cont *cont) { - void pic_vm_tear_off(pic_state *); char v; struct pic_cont *tmp = cont; struct pic_block *blk; - pic_vm_tear_off(pic); /* tear off */ - if (&v < pic->native_stack_start) { if (&v > cont->stk_pos) native_stack_extend(pic, cont); } From a3a8b11d4b47a1ddfda8fe05aefa12c77b24a1cc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 09:01:00 +0900 Subject: [PATCH 030/232] lset/lerf can access to torn-off regions because of call/cc --- vm.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/vm.c b/vm.c index 757fe7a3..6d843d67 100644 --- a/vm.c +++ b/vm.c @@ -668,10 +668,22 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) NEXT; } CASE(OP_LREF) { + pic_callinfo *ci = pic->ci; + + if (ci->env != NULL && ci->env->regs == ci->env->storage) { + PUSH(ci->env->regs[c.u.i - (ci->regs - ci->fp)]); + NEXT; + } PUSH(pic->ci->fp[c.u.i]); NEXT; } CASE(OP_LSET) { + pic_callinfo *ci = pic->ci; + + if (ci->env != NULL && ci->env->regs == ci->env->storage) { + ci->env->regs[c.u.i - (ci->regs - ci->fp)] = POP(); + NEXT; + } pic->ci->fp[c.u.i] = POP(); NEXT; } From fb28cd003e9d9523f77969ed222577ef19d3cb8f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 11:37:52 +0900 Subject: [PATCH 031/232] flatten library hierarchy --- dict.c | 16 +++++++--------- init.c | 4 +--- macro.c | 6 ++---- number.c | 28 +++++++++++++-------------- pair.c | 58 ++++++++++++++++++++++++++------------------------------ port.c | 8 +++----- proc.c | 4 +--- read.c | 4 +--- record.c | 12 +++++------- symbol.c | 12 ++++-------- var.c | 12 +++++------- write.c | 10 ++++------ 12 files changed, 74 insertions(+), 100 deletions(-) diff --git a/dict.c b/dict.c index 4a709421..fa7dff78 100644 --- a/dict.c +++ b/dict.c @@ -157,13 +157,11 @@ pic_dict_dict_for_each(pic_state *pic) void pic_init_dict(pic_state *pic) { - pic_deflibrary (pic, "(picrin dictionary)") { - pic_defun(pic, "make-dictionary", pic_dict_dict); - pic_defun(pic, "dictionary?", pic_dict_dict_p); - pic_defun(pic, "dictionary-ref", pic_dict_dict_ref); - pic_defun(pic, "dictionary-set!", pic_dict_dict_set); - pic_defun(pic, "dictionary-delete", pic_dict_dict_del); - pic_defun(pic, "dictionary-size", pic_dict_dict_size); - pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each); - } + pic_defun(pic, "make-dictionary", pic_dict_dict); + pic_defun(pic, "dictionary?", pic_dict_dict_p); + pic_defun(pic, "dictionary-ref", pic_dict_dict_ref); + pic_defun(pic, "dictionary-set!", pic_dict_dict_set); + pic_defun(pic, "dictionary-delete", pic_dict_dict_del); + pic_defun(pic, "dictionary-size", pic_dict_dict_size); + pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each); } diff --git a/init.c b/init.c index e0194f96..eaf0c005 100644 --- a/init.c +++ b/init.c @@ -38,7 +38,7 @@ pic_init_core(pic_state *pic) pic_init_reader(pic); - pic_deflibrary (pic, "(picrin base core)") { + 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); @@ -46,9 +46,7 @@ pic_init_core(pic_state *pic) 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_deflibrary (pic, "(scheme base)") { pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; pic_init_port(pic); DONE; diff --git a/macro.c b/macro.c index cc56ca3c..761f3399 100644 --- a/macro.c +++ b/macro.c @@ -430,8 +430,6 @@ pic_macro_make_identifier(pic_state *pic) void pic_init_macro(pic_state *pic) { - pic_deflibrary (pic, "(picrin base macro)") { - pic_defun(pic, "identifier?", pic_macro_identifier_p); - pic_defun(pic, "make-identifier", pic_macro_make_identifier); - } + pic_defun(pic, "identifier?", pic_macro_identifier_p); + pic_defun(pic, "make-identifier", pic_macro_make_identifier); } diff --git a/number.c b/number.c index 05b77046..27e9378f 100644 --- a/number.c +++ b/number.c @@ -922,20 +922,20 @@ pic_init_number(pic_state *pic) pic_defun(pic, "string->number", pic_number_string_to_number); pic_gc_arena_restore(pic, ai); - pic_deflibrary (pic, "(scheme inexact)") { - 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_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, "exp", pic_number_exp); - pic_defun(pic, "log", pic_number_log); - pic_defun(pic, "sin", pic_number_sin); - pic_defun(pic, "cos", pic_number_cos); - pic_defun(pic, "tan", pic_number_tan); - pic_defun(pic, "acos", pic_number_acos); - pic_defun(pic, "asin", pic_number_asin); - pic_defun(pic, "atan", pic_number_atan); + pic_defun(pic, "exp", pic_number_exp); + pic_defun(pic, "log", pic_number_log); + pic_defun(pic, "sin", pic_number_sin); + pic_defun(pic, "cos", pic_number_cos); + pic_defun(pic, "tan", pic_number_tan); + pic_defun(pic, "acos", pic_number_acos); + pic_defun(pic, "asin", pic_number_asin); + pic_defun(pic, "atan", pic_number_atan); + pic_gc_arena_restore(pic, ai); - pic_defun(pic, "sqrt", pic_number_sqrt); - } + pic_defun(pic, "sqrt", pic_number_sqrt); } diff --git a/pair.c b/pair.c index 5b62ceaf..3ca55610 100644 --- a/pair.c +++ b/pair.c @@ -732,36 +732,32 @@ pic_pair_assoc(pic_state *pic) void pic_init_pair(pic_state *pic) { - pic_deflibrary (pic, "(picrin base list)") { - 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); - 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, "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); + 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_deflibrary (pic, "(picrin list)") { - pic_defun(pic, "caar", pic_pair_caar); - pic_defun(pic, "cadr", pic_pair_cadr); - pic_defun(pic, "cdar", pic_pair_cdar); - pic_defun(pic, "cddr", pic_pair_cddr); - pic_defun(pic, "list?", pic_pair_list_p); - pic_defun(pic, "make-list", pic_pair_make_list); - pic_defun(pic, "list", pic_pair_list); - pic_defun(pic, "length", pic_pair_length); - pic_defun(pic, "append", pic_pair_append); - pic_defun(pic, "reverse", pic_pair_reverse); - pic_defun(pic, "list-tail", pic_pair_list_tail); - pic_defun(pic, "list-ref", pic_pair_list_ref); - pic_defun(pic, "list-set!", pic_pair_list_set); - pic_defun(pic, "list-copy", pic_pair_list_copy); - pic_defun(pic, "memq", pic_pair_memq); - pic_defun(pic, "memv", pic_pair_memv); - pic_defun(pic, "member", pic_pair_member); - pic_defun(pic, "assq", pic_pair_assq); - pic_defun(pic, "assv", pic_pair_assv); - pic_defun(pic, "assoc", pic_pair_assoc); - } + pic_defun(pic, "caar", pic_pair_caar); + pic_defun(pic, "cadr", pic_pair_cadr); + pic_defun(pic, "cdar", pic_pair_cdar); + pic_defun(pic, "cddr", pic_pair_cddr); + pic_defun(pic, "list?", pic_pair_list_p); + pic_defun(pic, "make-list", pic_pair_make_list); + pic_defun(pic, "list", pic_pair_list); + pic_defun(pic, "length", pic_pair_length); + pic_defun(pic, "append", pic_pair_append); + pic_defun(pic, "reverse", pic_pair_reverse); + pic_defun(pic, "list-tail", pic_pair_list_tail); + pic_defun(pic, "list-ref", pic_pair_list_ref); + pic_defun(pic, "list-set!", pic_pair_list_set); + pic_defun(pic, "list-copy", pic_pair_list_copy); + pic_defun(pic, "memq", pic_pair_memq); + pic_defun(pic, "memv", pic_pair_memv); + pic_defun(pic, "member", pic_pair_member); + pic_defun(pic, "assq", pic_pair_assq); + pic_defun(pic, "assv", pic_pair_assv); + pic_defun(pic, "assoc", pic_pair_assoc); } diff --git a/port.c b/port.c index b9790d06..0a6c6c1b 100644 --- a/port.c +++ b/port.c @@ -696,11 +696,9 @@ pic_init_port(pic_state *pic) STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT); STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT); - pic_deflibrary (pic, "(picrin port)") { - pic_define(pic, "standard-input-port", pic_obj_value(STDIN)); - pic_define(pic, "standard-output-port", pic_obj_value(STDOUT)); - pic_define(pic, "standard-error-port", pic_obj_value(STDERR)); - } + pic_define(pic, "standard-input-port", pic_obj_value(STDIN)); + pic_define(pic, "standard-output-port", pic_obj_value(STDOUT)); + pic_define(pic, "standard-error-port", pic_obj_value(STDERR)); pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDIN), NULL))); pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDOUT), NULL))); diff --git a/proc.c b/proc.c index 889a621d..c06dce80 100644 --- a/proc.c +++ b/proc.c @@ -177,7 +177,5 @@ pic_init_proc(pic_state *pic) pic_defun(pic, "map", pic_proc_map); pic_defun(pic, "for-each", pic_proc_for_each); - pic_deflibrary (pic, "(picrin attribute)") { - pic_defun(pic, "attribute", pic_proc_attribute); - } + pic_defun(pic, "attribute", pic_proc_attribute); } diff --git a/read.c b/read.c index 2eb12829..0a25c61d 100644 --- a/read.c +++ b/read.c @@ -970,7 +970,5 @@ pic_read_read(pic_state *pic) void pic_init_read(pic_state *pic) { - pic_deflibrary (pic, "(scheme read)") { - pic_defun(pic, "read", pic_read_read); - } + pic_defun(pic, "read", pic_read_read); } diff --git a/record.c b/record.c index d62776ca..2137e4f1 100644 --- a/record.c +++ b/record.c @@ -105,11 +105,9 @@ pic_record_record_set(pic_state *pic) void pic_init_record(pic_state *pic) { - pic_deflibrary (pic, "(picrin record)") { - pic_defun(pic, "make-record", pic_record_make_record); - pic_defun(pic, "record?", pic_record_record_p); - pic_defun(pic, "record-type", pic_record_record_type); - pic_defun(pic, "record-ref", pic_record_record_ref); - pic_defun(pic, "record-set!", pic_record_record_set); - } + pic_defun(pic, "make-record", pic_record_make_record); + pic_defun(pic, "record?", pic_record_record_p); + pic_defun(pic, "record-type", pic_record_record_type); + pic_defun(pic, "record-ref", pic_record_record_ref); + pic_defun(pic, "record-set!", pic_record_record_set); } diff --git a/symbol.c b/symbol.c index b936f48f..9a1d7d8d 100644 --- a/symbol.c +++ b/symbol.c @@ -155,13 +155,9 @@ pic_symbol_string_to_symbol(pic_state *pic) void pic_init_symbol(pic_state *pic) { - pic_deflibrary (pic, "(picrin base symbol)") { - pic_defun(pic, "symbol?", pic_symbol_symbol_p); - pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); - pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); - } + pic_defun(pic, "symbol?", pic_symbol_symbol_p); + pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); + pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); - pic_deflibrary (pic, "(picrin symbol)") { - pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p); - } + pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p); } diff --git a/var.c b/var.c index a5836797..71f605e8 100644 --- a/var.c +++ b/var.c @@ -124,11 +124,9 @@ pic_var_parameter_pop(pic_state *pic) void pic_init_var(pic_state *pic) { - pic_deflibrary (pic, "(picrin parameter)") { - pic_defun(pic, "make-parameter", pic_var_make_parameter); - pic_defun(pic, "parameter-ref", pic_var_parameter_ref); - pic_defun(pic, "parameter-set!", pic_var_parameter_set); - pic_defun(pic, "parameter-push!", pic_var_parameter_push); - pic_defun(pic, "parameter-pop!", pic_var_parameter_pop); - } + pic_defun(pic, "make-parameter", pic_var_make_parameter); + pic_defun(pic, "parameter-ref", pic_var_parameter_ref); + pic_defun(pic, "parameter-set!", pic_var_parameter_set); + pic_defun(pic, "parameter-push!", pic_var_parameter_push); + pic_defun(pic, "parameter-pop!", pic_var_parameter_pop); } diff --git a/write.c b/write.c index 1ae61195..d552721f 100644 --- a/write.c +++ b/write.c @@ -497,10 +497,8 @@ pic_write_display(pic_state *pic) void pic_init_write(pic_state *pic) { - pic_deflibrary (pic, "(scheme write)") { - pic_defun(pic, "write", pic_write_write); - pic_defun(pic, "write-simple", pic_write_write_simple); - pic_defun(pic, "write-shared", pic_write_write_shared); - pic_defun(pic, "display", pic_write_display); - } + pic_defun(pic, "write", pic_write_write); + pic_defun(pic, "write-simple", pic_write_write_simple); + pic_defun(pic, "write-shared", pic_write_write_shared); + pic_defun(pic, "display", pic_write_display); } From a227498f5bdd7e45a3ea9bf2684e6592b8af7b60 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 13:01:17 +0900 Subject: [PATCH 032/232] hold standard library references in pic_state --- include/picrin.h | 3 +++ init.c | 3 --- state.c | 12 ++++++++---- 3 files changed, 11 insertions(+), 7 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 9b063923..083cfcda 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -85,6 +85,9 @@ typedef struct { pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT; pic_sym rDEFINE_LIBRARY, rIN_LIBRARY; + struct pic_lib *PICRIN_BASE; + struct pic_lib *PICRIN_USER; + xhash syms; /* name to symbol */ xhash sym_names; /* symbol to name */ int sym_cnt; diff --git a/init.c b/init.c index eaf0c005..62a19090 100644 --- a/init.c +++ b/init.c @@ -4,7 +4,6 @@ #include "picrin.h" #include "picrin/pair.h" -#include "picrin/read.h" #include "picrin/lib.h" #include "picrin/macro.h" #include "picrin/error.h" @@ -36,8 +35,6 @@ pic_init_core(pic_state *pic) { size_t ai = pic_gc_arena_preserve(pic); - pic_init_reader(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); diff --git a/state.c b/state.c index d9427f3d..ccf53a80 100644 --- a/state.c +++ b/state.c @@ -140,11 +140,15 @@ pic_open(int argc, char *argv[], char **envp) pic->blk->depth = 0; pic->blk->in = pic->blk->out = NULL; - pic_init_core(pic); + /* init readers */ + pic_init_reader(pic); - /* set library */ - pic_make_library(pic, pic_read_cstr(pic, "(picrin user)")); - pic_in_library(pic, pic_read_cstr(pic, "(picrin user)")); + /* 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_init_core(pic); return pic; } From a4c82f10d207b8d5a328b195494bd01636ed60ec Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 13:01:56 +0900 Subject: [PATCH 033/232] (scheme base) is no longer the default library of benz. refer to (picrin base) instead. --- codegen.c | 40 ++++++++++++++++++---------------------- include/picrin.h | 4 ++-- port.c | 4 ++-- vm.c | 8 ++++---- 4 files changed, 26 insertions(+), 30 deletions(-) diff --git a/codegen.c b/codegen.c index c1264dfb..55d7a50c 100644 --- a/codegen.c +++ b/codegen.c @@ -51,8 +51,8 @@ static void pop_scope(analyze_state *); #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_error(pic, "internal error! native VM procedure not found"); \ + 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) @@ -62,32 +62,28 @@ new_analyze_state(pic_state *pic) { analyze_state *state; xh_iter it; - struct pic_lib *stdlib, *listlib; state = pic_alloc(pic, sizeof(analyze_state)); state->pic = pic; state->scope = NULL; - stdlib = pic_find_library(pic, pic_read_cstr(pic, "(scheme base)")); - listlib = pic_find_library(pic, pic_read_cstr(pic, "(picrin base list)")); - /* native VM procedures */ - register_renamed_symbol(pic, state, rCONS, listlib, "cons"); - register_renamed_symbol(pic, state, rCAR, listlib, "car"); - register_renamed_symbol(pic, state, rCDR, listlib, "cdr"); - register_renamed_symbol(pic, state, rNILP, listlib, "null?"); - register_renamed_symbol(pic, state, rADD, stdlib, "+"); - register_renamed_symbol(pic, state, rSUB, stdlib, "-"); - register_renamed_symbol(pic, state, rMUL, stdlib, "*"); - register_renamed_symbol(pic, state, rDIV, stdlib, "/"); - register_renamed_symbol(pic, state, rEQ, stdlib, "="); - register_renamed_symbol(pic, state, rLT, stdlib, "<"); - register_renamed_symbol(pic, state, rLE, stdlib, "<="); - register_renamed_symbol(pic, state, rGT, stdlib, ">"); - register_renamed_symbol(pic, state, rGE, stdlib, ">="); - register_renamed_symbol(pic, state, rNOT, stdlib, "not"); - register_renamed_symbol(pic, state, rVALUES, stdlib, "values"); - register_renamed_symbol(pic, state, rCALL_WITH_VALUES, stdlib, "call-with-values"); + 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, 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"); diff --git a/include/picrin.h b/include/picrin.h index 083cfcda..9ba312ef 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -137,8 +137,8 @@ pic_state *pic_open(int argc, char *argv[], char **envp); void pic_close(pic_state *); void pic_define(pic_state *, const char *, pic_value); /* automatic export */ -pic_value pic_ref(pic_state *, const char *); -void pic_set(pic_state *, const char *, pic_value); +pic_value pic_ref(pic_state *, struct pic_lib *, const char *); +void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); diff --git a/port.c b/port.c index 0a6c6c1b..b8a15154 100644 --- a/port.c +++ b/port.c @@ -28,7 +28,7 @@ pic_stdin(pic_state *pic) { struct pic_proc *proc; - proc = pic_proc_ptr(pic_ref(pic, "current-input-port")); + proc = pic_proc_ptr(pic_ref(pic, pic->PICRIN_BASE, "current-input-port")); return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); } @@ -38,7 +38,7 @@ pic_stdout(pic_state *pic) { struct pic_proc *proc; - proc = pic_proc_ptr(pic_ref(pic, "current-output-port")); + proc = pic_proc_ptr(pic_ref(pic, pic->PICRIN_BASE, "current-output-port")); return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); } diff --git a/vm.c b/vm.c index 6d843d67..d25a2656 100644 --- a/vm.c +++ b/vm.c @@ -426,14 +426,14 @@ pic_define(pic_state *pic, const char *name, pic_value val) } pic_value -pic_ref(pic_state *pic, const char *name) +pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) { pic_sym sym, rename; sym = pic_intern_cstr(pic, name); - if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { - pic_errorf(pic, "symbol \"%s\" not defined", name); + if (! pic_find_rename(pic, lib->env, sym, &rename)) { + pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } return xh_val(xh_get_int(&pic->globals, rename), pic_value); @@ -444,7 +444,7 @@ pic_funcall(pic_state *pic, const char *name, pic_list args) { pic_value proc; - proc = pic_ref(pic, name); + proc = pic_ref(pic, pic->lib, name); pic_assert_type(pic, proc, proc); From 1e8ab8bf0f67d202979feae754cf1ad084cacecb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 13:07:38 +0900 Subject: [PATCH 034/232] s/make_library/open_library/g --- include/picrin.h | 4 ++-- lib.c | 4 ++-- state.c | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 9ba312ef..a8c912f1 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -177,7 +177,7 @@ 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_make_library(pic_state *, pic_value); +struct pic_lib *pic_open_library(pic_state *, pic_value); struct pic_lib *pic_find_library(pic_state *, pic_value); #define pic_deflibrary(pic, spec) \ @@ -185,7 +185,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value); #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_make_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib) + 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) void pic_import(pic_state *, pic_value); void pic_export(pic_state *, pic_sym); diff --git a/lib.c b/lib.c index defb4b4b..898b0b6b 100644 --- a/lib.c +++ b/lib.c @@ -11,7 +11,7 @@ #include "picrin/string.h" struct pic_lib * -pic_make_library(pic_state *pic, pic_value name) +pic_open_library(pic_state *pic, pic_value name) { struct pic_lib *lib; struct pic_senv *senv; @@ -239,7 +239,7 @@ pic_lib_define_library(pic_state *pic) pic_get_args(pic, "o*", &spec, &argc, &argv); - pic_make_library(pic, spec); + pic_open_library(pic, spec); pic_try { pic_in_library(pic, spec); diff --git a/state.c b/state.c index ccf53a80..4810af25 100644 --- a/state.c +++ b/state.c @@ -144,8 +144,8 @@ pic_open(int argc, char *argv[], char **envp) pic_init_reader(pic); /* 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->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; pic_init_core(pic); From 03716567c97e5809491ab3e3e4ab9dba326347db Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 13:23:32 +0900 Subject: [PATCH 035/232] delete pic_parse family --- include/picrin.h | 2 -- read.c | 41 ----------------------------------------- 2 files changed, 43 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index a8c912f1..381b1a44 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -161,8 +161,6 @@ char *pic_strndup(pic_state *, const char *, size_t); pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read_cstr(pic_state *, const char *); -pic_list pic_parse_file(pic_state *, FILE *); /* #f for incomplete input */ -pic_list pic_parse_cstr(pic_state *, const char *); pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply0(pic_state *, struct pic_proc *); diff --git a/read.c b/read.c index 0a25c61d..d52f1416 100644 --- a/read.c +++ b/read.c @@ -916,47 +916,6 @@ pic_read_cstr(pic_state *pic, const char *str) return pic_read(pic, port); } -static pic_value -pic_parse(pic_state *pic, struct pic_port *port) -{ - pic_value val, acc; - - pic_try { - acc = pic_nil_value(); - while (! pic_eof_p(val = pic_read(pic, port))) { - pic_push(pic, val, acc); - } - } - pic_catch { - return pic_undef_value(); - } - - return pic_reverse(pic, acc); -} - -pic_list -pic_parse_file(pic_state *pic, FILE *file) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xfpopen(file); - port->flags = PIC_PORT_OUT | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; - - return pic_parse(pic, port); -} - -pic_list -pic_parse_cstr(pic_state *pic, const char *str) -{ - struct pic_port *port; - - port = pic_open_input_string(pic, str); - - return pic_parse(pic, port); -} - static pic_value pic_read_read(pic_state *pic) { From 0f55478a19d4989a2503014898261cc46ce4d849 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 13:43:54 +0900 Subject: [PATCH 036/232] pluggable stdios --- gc.c | 11 +++++++++++ include/picrin.h | 4 +++- port.c | 20 +++++--------------- state.c | 14 +++++++++++++- 4 files changed, 32 insertions(+), 17 deletions(-) diff --git a/gc.c b/gc.c index 9a947837..c71a2161 100644 --- a/gc.c +++ b/gc.c @@ -625,6 +625,17 @@ gc_mark_phase(pic_state *pic) /* library table */ gc_mark(pic, pic->libs); + + /* standard I/O ports */ + if (pic->xSTDIN) { + gc_mark_object(pic, (struct pic_object *)pic->xSTDIN); + } + if (pic->xSTDOUT) { + gc_mark_object(pic, (struct pic_object *)pic->xSTDOUT); + } + if (pic->xSTDERR) { + gc_mark_object(pic, (struct pic_object *)pic->xSTDERR); + } } static void diff --git a/include/picrin.h b/include/picrin.h index 381b1a44..c370015e 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -108,6 +108,8 @@ typedef struct { struct pic_object **arena; size_t arena_size, arena_idx; + struct pic_port *xSTDIN, *xSTDOUT, *xSTDERR; + char *native_stack_start; } pic_state; @@ -133,7 +135,7 @@ 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, xFILE *stdio[3]); void pic_close(pic_state *); void pic_define(pic_state *, const char *, pic_value); /* automatic export */ diff --git a/port.c b/port.c index b8a15154..db1a6e96 100644 --- a/port.c +++ b/port.c @@ -43,8 +43,8 @@ pic_stdout(pic_state *pic) return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); } -static struct pic_port * -port_new_stdport(pic_state *pic, xFILE *file, short dir) +struct pic_port * +pic_port_make_stdport(pic_state *pic, xFILE *file, short dir) { struct pic_port *port; @@ -690,19 +690,9 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { - struct pic_port *STDIN, *STDOUT, *STDERR; - - STDIN = port_new_stdport(pic, xstdin, PIC_PORT_IN); - STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT); - STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT); - - pic_define(pic, "standard-input-port", pic_obj_value(STDIN)); - pic_define(pic, "standard-output-port", pic_obj_value(STDOUT)); - pic_define(pic, "standard-error-port", pic_obj_value(STDERR)); - - pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDIN), NULL))); - pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDOUT), NULL))); - pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDERR), NULL))); + pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(pic->xSTDIN), NULL))); + pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(pic->xSTDOUT), NULL))); + pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(pic->xSTDERR), NULL))); pic_defun(pic, "input-port?", pic_port_input_port_p); pic_defun(pic, "output-port?", pic_port_output_port_p); diff --git a/state.c b/state.c index 4810af25..28ee47e1 100644 --- a/state.c +++ b/state.c @@ -10,13 +10,15 @@ #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 *); pic_state * -pic_open(int argc, char *argv[], char **envp) +pic_open(int argc, char *argv[], char **envp, xFILE *stdio[3]) { + struct pic_port *pic_port_make_stdport(pic_state *, xFILE *, short); char t; pic_state *pic; @@ -72,6 +74,11 @@ pic_open(int argc, char *argv[], char **envp) pic->try_jmp_idx = 0; pic->try_jmp_size = PIC_RESCUE_SIZE; + /* 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; @@ -148,6 +155,11 @@ pic_open(int argc, char *argv[], char **envp) pic->PICRIN_USER = pic_open_library(pic, pic_read_cstr(pic, "(picrin user)")); pic->lib = pic->PICRIN_USER; + /* standard I/O */ + pic->xSTDIN = pic_port_make_stdport(pic, stdio[0], PIC_PORT_IN); + pic->xSTDOUT = pic_port_make_stdport(pic, stdio[1], PIC_PORT_OUT); + pic->xSTDERR = pic_port_make_stdport(pic, stdio[2], PIC_PORT_OUT); + pic_init_core(pic); return pic; From 2a347847ae8f2bda056be69e179c9621369a8db5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 13:48:40 +0900 Subject: [PATCH 037/232] drop dependency on stdio.h --- include/picrin.h | 1 - 1 file changed, 1 deletion(-) diff --git a/include/picrin.h b/include/picrin.h index c370015e..0be5663a 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -31,7 +31,6 @@ extern "C" { #include #include #include -#include #include #include #include From 14e7fd4e98ca4619edb5eb7e48b882d94e5e50d2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 4 Sep 2014 18:43:12 +0900 Subject: [PATCH 038/232] =?UTF-8?q?implement=20identifier=3D=3F?= --- gc.c | 2 -- macro.c | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/gc.c b/gc.c index c71a2161..9520e40a 100644 --- a/gc.c +++ b/gc.c @@ -2,8 +2,6 @@ * See Copyright Notice in picrin.h */ -#include - #include "picrin.h" #include "picrin/gc.h" #include "picrin/pair.h" diff --git a/macro.c b/macro.c index 761f3399..22d9f331 100644 --- a/macro.c +++ b/macro.c @@ -404,6 +404,24 @@ pic_identifier_p(pic_state *pic, pic_value obj) return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj)); } +bool +pic_identifier_eq_p(pic_state *pic, struct pic_senv *env1, pic_sym sym1, struct pic_senv *env2, pic_sym sym2) +{ + pic_sym a, b; + + a = make_identifier(pic, sym1, env1); + if (a != make_identifier(pic, sym1, env1)) { + a = sym1; + } + + b = make_identifier(pic, sym2, env2); + if (b != make_identifier(pic, sym2, env2)) { + b = sym2; + } + + return pic_eq_p(pic_sym_value(a), pic_sym_value(b)); +} + static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -427,9 +445,24 @@ pic_macro_make_identifier(pic_state *pic) return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj))); } +static pic_value +pic_macro_identifier_eq_p(pic_state *pic) +{ + 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); + + return pic_bool_value(pic_identifier_eq_p(pic, pic_senv_ptr(env1), sym1, pic_senv_ptr(env2), sym2)); +} + void pic_init_macro(pic_state *pic) { pic_defun(pic, "identifier?", pic_macro_identifier_p); + pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); pic_defun(pic, "make-identifier", pic_macro_make_identifier); } From b4d1abe54f2ba321e2417bbb9556e136add3852d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 4 Sep 2014 18:43:12 +0900 Subject: [PATCH 039/232] remove unused port operaotrs --- port.c | 38 -------------------------------------- 1 file changed, 38 deletions(-) diff --git a/port.c b/port.c index db1a6e96..f53832f5 100644 --- a/port.c +++ b/port.c @@ -183,40 +183,6 @@ pic_port_port_p(pic_state *pic) return pic_bool_value(pic_port_p(v)); } -static pic_value -pic_port_input_port_open_p(pic_state *pic) -{ - pic_value v; - struct pic_port *port; - - pic_get_args(pic, "o", &v); - - if (! pic_port_p(v)) - return pic_false_value(); - port = pic_port_ptr(v); - if ((port->flags & PIC_PORT_IN) == 0) - return pic_false_value(); - - return pic_bool_value(port->status == PIC_PORT_OPEN); -} - -static pic_value -pic_port_output_port_open_p(pic_state *pic) -{ - pic_value v; - struct pic_port *port; - - pic_get_args(pic, "o", &v); - - if (! pic_port_p(v)) - return pic_false_value(); - port = pic_port_ptr(v); - if ((port->flags & PIC_PORT_OUT) == 0) - return pic_false_value(); - - return pic_bool_value(port->status == PIC_PORT_OPEN); -} - static pic_value pic_port_eof_object_p(pic_state *pic) { @@ -699,11 +665,7 @@ pic_init_port(pic_state *pic) pic_defun(pic, "textual-port?", pic_port_textual_port_p); pic_defun(pic, "binary-port?", pic_port_binary_port_p); pic_defun(pic, "port?", pic_port_port_p); - pic_defun(pic, "input-port-open?", pic_port_input_port_open_p); - pic_defun(pic, "output-port-open?", pic_port_output_port_open_p); pic_defun(pic, "close-port", pic_port_close_port); - pic_defun(pic, "close-input-port", pic_port_close_port); - pic_defun(pic, "close-output-port", pic_port_close_port); /* string I/O */ pic_defun(pic, "open-input-string", pic_port_open_input_string); From e56f2dce2815ec2273b986075b41a8deb10e7716 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 5 Sep 2014 03:37:52 +0900 Subject: [PATCH 040/232] immutable string --- include/picrin/string.h | 3 -- string.c | 98 +---------------------------------------- 2 files changed, 2 insertions(+), 99 deletions(-) diff --git a/include/picrin/string.h b/include/picrin/string.h index 3df116cf..9cb7d3eb 100644 --- a/include/picrin/string.h +++ b/include/picrin/string.h @@ -19,12 +19,9 @@ struct pic_string { pic_str *pic_str_new(pic_state *, const char * /* nullable */, size_t); pic_str *pic_str_new_cstr(pic_state *, const char *); -pic_str *pic_str_new_fill(pic_state *, size_t, char); size_t pic_strlen(pic_str *); char pic_str_ref(pic_state *, pic_str *, size_t); -void pic_str_set(pic_state *, pic_str *, size_t, char); - 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 *); diff --git a/string.c b/string.c index 92a3c569..7afa7a26 100644 --- a/string.c +++ b/string.c @@ -34,25 +34,6 @@ pic_str_new_cstr(pic_state *pic, const char *cstr) return pic_str_new(pic, cstr, strlen(cstr)); } -pic_str * -pic_str_new_fill(pic_state *pic, size_t len, char fill) -{ - size_t i; - char *cstr; - pic_str *str; - - cstr = (char *)pic_alloc(pic, len + 1); - cstr[len] = '\0'; - for (i = 0; i < len; ++i) { - cstr[i] = fill; - } - - str = pic_str_new(pic, cstr, len); - - pic_free(pic, cstr); - return str; -} - size_t pic_strlen(pic_str *str) { @@ -276,17 +257,6 @@ pic_str_string_p(pic_state *pic) return pic_bool_value(pic_str_p(v)); } -static pic_value -pic_str_make_string(pic_state *pic) -{ - int len; - char c = ' '; - - pic_get_args(pic, "i|c", &len, &c); - - return pic_obj_value(pic_str_new_fill(pic, len, c)); -} - static pic_value pic_str_string_length(pic_state *pic) { @@ -308,19 +278,6 @@ pic_str_string_ref(pic_state *pic) return pic_char_value(pic_str_ref(pic, str, k)); } -static pic_value -pic_str_string_set(pic_state *pic) -{ - pic_str *str; - char c; - int k; - - pic_get_args(pic, "sic", &str, &k, &c); - - pic_str_set(pic, str, k, c); - return pic_none_value(); -} - #define DEFINE_STRING_CMP(name, op) \ static pic_value \ pic_str_string_##name(pic_state *pic) \ @@ -370,30 +327,6 @@ pic_str_string_copy(pic_state *pic) return pic_obj_value(pic_substr(pic, str, start, end)); } -static pic_value -pic_str_string_copy_ip(pic_state *pic) -{ - pic_str *to, *from; - int n, at, start, end; - - n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end); - - switch (n) { - case 3: - start = 0; - case 4: - end = pic_strlen(from); - } - if (to == from) { - from = pic_substr(pic, from, 0, end); - } - - while (start < end) { - pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++)); - } - return pic_none_value(); -} - static pic_value pic_str_string_append(pic_state *pic) { @@ -413,45 +346,18 @@ pic_str_string_append(pic_state *pic) return pic_obj_value(str); } -static pic_value -pic_str_string_fill_ip(pic_state *pic) -{ - pic_str *str; - char c; - int n, start, end; - - n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end); - - switch (n) { - case 2: - start = 0; - case 3: - end = pic_strlen(str); - } - - while (start < end) { - pic_str_set(pic, str, start++, c); - } - return pic_none_value(); -} - void pic_init_str(pic_state *pic) { pic_defun(pic, "string?", pic_str_string_p); - pic_defun(pic, "make-string", pic_str_make_string); pic_defun(pic, "string-length", pic_str_string_length); pic_defun(pic, "string-ref", pic_str_string_ref); - pic_defun(pic, "string-set!", pic_str_string_set); + pic_defun(pic, "string-copy", pic_str_string_copy); + pic_defun(pic, "string-append", pic_str_string_append); pic_defun(pic, "string=?", pic_str_string_eq); pic_defun(pic, "string?", pic_str_string_gt); pic_defun(pic, "string<=?", pic_str_string_le); pic_defun(pic, "string>=?", pic_str_string_ge); - - pic_defun(pic, "string-copy", pic_str_string_copy); - pic_defun(pic, "string-copy!", pic_str_string_copy_ip); - pic_defun(pic, "string-append", pic_str_string_append); - pic_defun(pic, "string-fill!", pic_str_string_fill_ip); } From a0945a323f9ff944f8307e5dd3bf3968f1d2b762 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 5 Sep 2014 03:45:24 +0900 Subject: [PATCH 041/232] remove unused math functions --- number.c | 310 ++----------------------------------------------------- 1 file changed, 6 insertions(+), 304 deletions(-) diff --git a/number.c b/number.c index 27e9378f..60ae5892 100644 --- a/number.c +++ b/number.c @@ -10,24 +10,6 @@ #include "picrin/string.h" #include "picrin/cont.h" -static int -gcd(int a, int b) -{ - if (a > b) - return gcd(b, a); - if (a < 0) - return gcd(-a, b); - if (a > 0) - return gcd(b % a, a); - return b; -} - -static double -lcm(int a, int b) -{ - return fabs((double)a * b) / gcd(a, b); -} - /** * Returns the length of string representing val. * radix is between 2 and 36 (inclusive). @@ -212,112 +194,6 @@ DEFINE_ARITH_CMP(>, gt) DEFINE_ARITH_CMP(<=, le) DEFINE_ARITH_CMP(>=, ge) -static pic_value -pic_number_zero_p(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_bool_value(f == 0); -} - -static pic_value -pic_number_positive_p(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_bool_value(f > 0); -} - -static pic_value -pic_number_negative_p(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_bool_value(f < 0); -} - -static pic_value -pic_number_odd_p(pic_state *pic) -{ - int i; - - pic_get_args(pic, "i", &i); - - return pic_bool_value(i % 2 != 0); -} - -static pic_value -pic_number_even_p(pic_state *pic) -{ - int i; - - pic_get_args(pic, "i", &i); - - return pic_bool_value(i % 2 == 0); -} - -static pic_value -pic_number_max(pic_state *pic) -{ - size_t argc; - pic_value *argv; - size_t i; - double f; - bool e = true; - - pic_get_args(pic, "*", &argc, &argv); - - f = -INFINITY; - for (i = 0; i < argc; ++i) { - if (pic_int_p(argv[i])) { - f = fmax(f, pic_int(argv[i])); - } - else if (pic_float_p(argv[i])) { - e = false; - f = fmax(f, pic_float(argv[i])); - } - else { - pic_error(pic, "max: number required"); - } - } - - return e ? pic_int_value(f) : pic_float_value(f); -} - -static pic_value -pic_number_min(pic_state *pic) -{ - size_t argc; - pic_value *argv; - size_t i; - double f; - bool e = true; - - pic_get_args(pic, "*", &argc, &argv); - - f = INFINITY; - for (i = 0; i < argc; ++i) { - if (pic_int_p(argv[i])) { - f = fmin(f, pic_int(argv[i])); - } - else if (pic_float_p(argv[i])) { - e = false; - f = fmin(f, pic_float(argv[i])); - } - else { - pic_error(pic, "min: number required"); - } - } - - return e ? pic_int_value(f) : pic_float_value(f); -} - #define DEFINE_ARITH_OP(op, name, unit) \ static pic_value \ pic_number_##name(pic_state *pic) \ @@ -402,39 +278,6 @@ pic_number_abs(pic_state *pic) } } -static pic_value -pic_number_floor_quotient(pic_state *pic) -{ - int i,j; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - if (e1 && e2) { - return pic_int_value((int)floor((double)i/j)); - } - else { - return pic_float_value(floor((double)i/j)); - } -} - -static pic_value -pic_number_floor_remainder(pic_state *pic) -{ - int i,j,q; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - q = (int)floor((double)i/j); - if (e1 && e2) { - return pic_int_value(i - j * q); - } - else { - return pic_float_value(i - j * q); - } -} - static pic_value pic_number_floor2(pic_state *pic) { @@ -455,39 +298,6 @@ pic_number_floor2(pic_state *pic) } } -static pic_value -pic_number_trunc_quotient(pic_state *pic) -{ - int i,j; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - if (e1 && e2) { - return pic_int_value((int)trunc((double)i/j)); - } - else { - return pic_float_value(trunc((double)i/j)); - } -} - -static pic_value -pic_number_trunc_remainder(pic_state *pic) -{ - int i,j,q; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - q = (int)trunc((double)i/j); - if (e1 && e2) { - return pic_int_value(i - j * q); - } - else { - return pic_float_value(i - j * q); - } -} - static pic_value pic_number_trunc2(pic_state *pic) { @@ -508,58 +318,6 @@ pic_number_trunc2(pic_state *pic) } } -static pic_value -pic_number_gcd(pic_state *pic) -{ - size_t argc; - pic_value *args; - int r; - bool e = true; - - pic_get_args(pic, "*", &argc, &args); - - r = 0; - while (argc-- > 0) { - if (pic_int_p(args[argc])) { - r = gcd(r, pic_int(args[argc])); - } - else if (pic_float_p(args[argc])) { - e = false; - r = gcd(r, pic_float(args[argc])); - } - else { - pic_error(pic, "gcd: number required"); - } - } - return e ? pic_int_value(r) : pic_float_value(r); -} - -static pic_value -pic_number_lcm(pic_state *pic) -{ - size_t argc; - pic_value *args; - double r; - bool e = true; - - pic_get_args(pic, "*", &argc, &args); - - r = 1; - while (argc-- > 0) { - if (pic_int_p(args[argc])) { - r = lcm(r, pic_int(args[argc])); - } - else if (pic_float_p(args[argc])) { - e = false; - r = lcm(r, pic_float(args[argc])); - } - else { - pic_error(pic, "lcm: number required"); - } - } - return e && pic_valid_int(r) ? pic_int_value(r) : pic_float_value(r); -} - static pic_value pic_number_floor(pic_state *pic) { @@ -714,37 +472,6 @@ pic_number_atan(pic_state *pic) } } -static pic_value -pic_number_exact_integer_sqrt(pic_state *pic) -{ - int k, n, m; - - pic_get_args(pic, "i", &k); - - n = sqrt(k); - m = k - n * n; - - return pic_values2(pic, pic_int_value(n), pic_int_value(m)); -} - -static pic_value -pic_number_square(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - long long i = (long long)f; - - if (i * i <= INT_MAX) { - return pic_int_value(i * i); - } - } - return pic_float_value(f * f); -} - static pic_value pic_number_sqrt(pic_state *pic) { @@ -863,7 +590,6 @@ pic_init_number(pic_state *pic) pic_defun(pic, "exact?", pic_number_exact_p); pic_defun(pic, "inexact?", pic_number_inexact_p); - pic_defun(pic, "exact-integer?", pic_number_exact_p); pic_gc_arena_restore(pic, ai); pic_defun(pic, "=", pic_number_eq); @@ -873,60 +599,34 @@ pic_init_number(pic_state *pic) pic_defun(pic, ">=", pic_number_ge); pic_gc_arena_restore(pic, ai); - pic_defun(pic, "zero?", pic_number_zero_p); - pic_defun(pic, "positive?", pic_number_positive_p); - pic_defun(pic, "negative?", pic_number_negative_p); - pic_defun(pic, "odd?", pic_number_odd_p); - pic_defun(pic, "even?", pic_number_even_p); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "min", pic_number_min); - pic_defun(pic, "max", pic_number_max); - 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_gc_arena_restore(pic, ai); - pic_defun(pic, "abs", pic_number_abs); - pic_defun(pic, "floor-quotient", pic_number_floor_quotient); - pic_defun(pic, "floor-remainder", pic_number_floor_remainder); pic_defun(pic, "floor/", pic_number_floor2); - pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient); - pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder); pic_defun(pic, "truncate/", pic_number_trunc2); pic_gc_arena_restore(pic, ai); - pic_defun(pic, "gcd", pic_number_gcd); - pic_defun(pic, "lcm", pic_number_lcm); - pic_gc_arena_restore(pic, ai); - 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, "exact-integer-sqrt", pic_number_exact_integer_sqrt); - pic_defun(pic, "square", pic_number_square); - pic_defun(pic, "expt", pic_number_expt); - 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); - 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); - 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); @@ -937,5 +637,7 @@ pic_init_number(pic_state *pic) pic_defun(pic, "atan", pic_number_atan); pic_gc_arena_restore(pic, ai); - pic_defun(pic, "sqrt", pic_number_sqrt); + 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); } From 3a4de8895e3295de056a3eafd0d0588ec743b074 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 5 Sep 2014 14:08:13 +0900 Subject: [PATCH 042/232] [bugfix] continue should set cont->results --- cont.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cont.c b/cont.c index 48d26924..23e5de3d 100644 --- a/cont.c +++ b/cont.c @@ -262,6 +262,8 @@ pic_cont_continue(pic_state *pic) pic_assert_type(pic, cont, cont); + pic_cont_ptr(cont)->results = pic_list_by_array(pic, argc, argv); + /* execute guard handlers */ walk_to_block(pic, pic->blk, pic_cont_ptr(cont)->blk); From b8b5743589ccbed555805d768d5c840aad350499 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 5 Sep 2014 14:15:46 +0900 Subject: [PATCH 043/232] continuation object is applicable --- cont.c | 42 +++++++++++++++++++++++------------------- include/picrin/cont.h | 1 + vm.c | 8 ++++++++ 3 files changed, 32 insertions(+), 19 deletions(-) diff --git a/cont.c b/cont.c index 23e5de3d..76760caf 100644 --- a/cont.c +++ b/cont.c @@ -250,25 +250,6 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st return val; } -noreturn static pic_value -pic_cont_continue(pic_state *pic) -{ - struct pic_proc *proc; - size_t argc; - pic_value cont, *argv; - - proc = pic_get_proc(pic); - pic_get_args(pic, "o*", &cont, &argc, &argv); - - pic_assert_type(pic, cont, cont); - - pic_cont_ptr(cont)->results = pic_list_by_array(pic, argc, argv); - - /* execute guard handlers */ - walk_to_block(pic, pic->blk, pic_cont_ptr(cont)->blk); - - restore_cont(pic, pic_cont_ptr(cont)); -} pic_value pic_callcc(pic_state *pic, struct pic_proc *proc) @@ -298,6 +279,16 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc) } } +noreturn void +pic_continue(pic_state *pic, struct pic_cont *cont, size_t argc, pic_value *argv) +{ + cont->results = pic_list_by_array(pic, argc, argv); + + walk_to_block(pic, pic->blk, cont->blk); + + restore_cont(pic, cont); +} + static pic_value pic_cont_callcc(pic_state *pic) { @@ -308,6 +299,19 @@ pic_cont_callcc(pic_state *pic) return pic_callcc_trampoline(pic, cb); } +noreturn static pic_value +pic_cont_continue(pic_state *pic) +{ + size_t argc; + pic_value cont, *argv; + + pic_get_args(pic, "o*", &cont, &argc, &argv); + + pic_assert_type(pic, cont, cont); + + pic_continue(pic, pic_cont_ptr(cont), argc, argv); +} + static pic_value pic_cont_dynamic_wind(pic_state *pic) { diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 6f35de38..ac5213eb 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -57,6 +57,7 @@ pic_value pic_values_by_list(pic_state *, pic_value); size_t pic_receive(pic_state *, size_t, pic_value *); pic_value pic_callcc(pic_state *, struct pic_proc *); +noreturn void pic_continue(pic_state *, struct pic_cont *, size_t, pic_value *); #if defined(__cplusplus) } diff --git a/vm.c b/vm.c index d25a2656..46034214 100644 --- a/vm.c +++ b/vm.c @@ -21,6 +21,7 @@ #include "picrin/error.h" #include "picrin/dict.h" #include "picrin/record.h" +#include "picrin/cont.h" #define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)]) @@ -752,6 +753,13 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) PUSH(pic_var_ref(pic, pic_var_ptr(x))); NEXT; } + if (pic_cont_p(x)) { + if (c.u.i >= 1) { + pic_errorf(pic, "invalid call-sequence for cont object"); + } + pic_continue(pic, pic_cont_ptr(x), c.u.i - 1, pic->sp - c.u.i + 1); + UNREACHABLE(); + } pic_errorf(pic, "invalid application: ~s", x); } proc = pic_proc_ptr(x); From 349d012b2673a97bc8cdd927e8992b62a3620db6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 18:46:47 +0900 Subject: [PATCH 044/232] Revert "remove file.c" This reverts commit 4cf8f3d7f6b822c29be481f0d1f6f0a856bd847b. --- file.c | 119 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ init.c | 2 + 2 files changed, 121 insertions(+) create mode 100644 file.c diff --git a/file.c b/file.c new file mode 100644 index 00000000..befac195 --- /dev/null +++ b/file.c @@ -0,0 +1,119 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/port.h" +#include "picrin/error.h" + +static noreturn void +file_error(pic_state *pic, const char *msg) +{ + pic_throw(pic, PIC_ERROR_FILE, msg, pic_nil_value()); +} + +static pic_value +generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) +{ + struct pic_port *port; + xFILE *file; + + file = xfopen(fname, mode); + if (! file) { + file_error(pic, "could not open file"); + } + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = flags; + port->status = PIC_PORT_OPEN; + + return pic_obj_value(port); +} + +pic_value +pic_file_open_input_file(pic_state *pic) +{ + static const short flags = PIC_PORT_IN | PIC_PORT_TEXT; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "r", flags); +} + +pic_value +pic_file_open_input_binary_file(pic_state *pic) +{ + static const short flags = PIC_PORT_IN | PIC_PORT_BINARY; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "rb", flags); +} + +pic_value +pic_file_open_output_file(pic_state *pic) +{ + static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "w", flags); +} + +pic_value +pic_file_open_output_binary_file(pic_state *pic) +{ + static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "wb", flags); +} + +pic_value +pic_file_exists_p(pic_state *pic) +{ + char *fname; + FILE *fp; + + pic_get_args(pic, "z", &fname); + + fp = fopen(fname, "r"); + if (fp) { + fclose(fp); + return pic_true_value(); + } else { + return pic_false_value(); + } +} + +pic_value +pic_file_delete(pic_state *pic) +{ + char *fname; + + pic_get_args(pic, "z", &fname); + + if (remove(fname) != 0) { + file_error(pic, "file cannot be deleted"); + } + return pic_none_value(); +} + +void +pic_init_file(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme file)") { + pic_defun(pic, "open-input-file", pic_file_open_input_file); + pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file); + pic_defun(pic, "open-output-file", pic_file_open_output_file); + pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file); + pic_defun(pic, "file-exists?", pic_file_exists_p); + pic_defun(pic, "delete-file", pic_file_delete); + } +} diff --git a/init.c b/init.c index 62a19090..731e9408 100644 --- a/init.c +++ b/init.c @@ -12,6 +12,7 @@ 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_file(pic_state *); void pic_init_proc(pic_state *); void pic_init_symbol(pic_state *); void pic_init_vector(pic_state *); @@ -48,6 +49,7 @@ pic_init_core(pic_state *pic) pic_init_pair(pic); DONE; pic_init_port(pic); DONE; pic_init_number(pic); DONE; + pic_init_file(pic); DONE; pic_init_proc(pic); DONE; pic_init_symbol(pic); DONE; pic_init_vector(pic); DONE; From 6cb34f063d9ac3fb68f0837c2a3f55ba91f58394 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 18:47:20 +0900 Subject: [PATCH 045/232] Revert "remove eval.c and load.c" This reverts commit 6a1b7c372d9fb0f06d983cd5ffff6307c9e2c6ab. --- eval.c | 39 ++++++++++++++++++++++ include/picrin.h | 3 ++ init.c | 4 +++ load.c | 87 ++++++++++++++++++++++++++++++++++++++++++++++++ vm.c | 10 ------ 5 files changed, 133 insertions(+), 10 deletions(-) create mode 100644 eval.c create mode 100644 load.c diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..5a037c94 --- /dev/null +++ b/eval.c @@ -0,0 +1,39 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/macro.h" + +pic_value +pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) +{ + struct pic_proc *proc; + + proc = pic_compile(pic, program, lib); + + return pic_apply(pic, proc, pic_nil_value()); +} + +static pic_value +pic_eval_eval(pic_state *pic) +{ + pic_value program, spec; + struct pic_lib *lib; + + pic_get_args(pic, "oo", &program, &spec); + + lib = pic_find_library(pic, spec); + if (lib == NULL) { + pic_errorf(pic, "no library found: ~s", spec); + } + return pic_eval(pic, program, lib); +} + +void +pic_init_eval(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme eval)") { + pic_defun(pic, "eval", pic_eval_eval); + } +} diff --git a/include/picrin.h b/include/picrin.h index 0be5663a..3d22718d 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -163,6 +163,9 @@ char *pic_strndup(pic_state *, const char *, size_t); pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read_cstr(pic_state *, const char *); +pic_value pic_load(pic_state *, const char *); +pic_value pic_load_cstr(pic_state *, const char *); + pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply0(pic_state *, struct pic_proc *); pic_value pic_apply1(pic_state *, struct pic_proc *, pic_value); diff --git a/init.c b/init.c index 731e9408..73dd8caf 100644 --- a/init.c +++ b/init.c @@ -23,10 +23,12 @@ 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_load(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 *); #define DONE pic_gc_arena_restore(pic, ai); @@ -60,10 +62,12 @@ pic_init_core(pic_state *pic) pic_init_str(pic); DONE; pic_init_macro(pic); DONE; pic_init_var(pic); DONE; + pic_init_load(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; } } diff --git a/load.c b/load.c new file mode 100644 index 00000000..440b45e2 --- /dev/null +++ b/load.c @@ -0,0 +1,87 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" + +pic_value +pic_load_cstr(pic_state *pic, const char *src) +{ + size_t ai; + pic_value v, exprs; + struct pic_proc *proc; + + exprs = pic_parse_cstr(pic, src); + if (pic_undef_p(exprs)) { + pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); + } + + pic_for_each (v, exprs) { + ai = pic_gc_arena_preserve(pic); + + proc = pic_compile(pic, v, pic->lib); + if (proc == NULL) { + pic_error(pic, "load: compilation failure"); + } + + pic_apply(pic, proc, pic_nil_value()); + + pic_gc_arena_restore(pic, ai); + } + + return pic_none_value(); +} + +pic_value +pic_load(pic_state *pic, const char *fn) +{ + FILE *file; + size_t ai; + pic_value v, exprs; + struct pic_proc *proc; + + file = fopen(fn, "r"); + if (file == NULL) { + pic_errorf(pic, "load: could not read file \"%s\"", fn); + } + + exprs = pic_parse_file(pic, file); + if (pic_undef_p(exprs)) { + pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); + } + + pic_for_each (v, exprs) { + ai = pic_gc_arena_preserve(pic); + + proc = pic_compile(pic, v, pic->lib); + if (proc == NULL) { + pic_error(pic, "load: compilation failure"); + } + + pic_apply(pic, proc, pic_nil_value()); + + pic_gc_arena_restore(pic, ai); + } + + return pic_none_value(); +} + +static pic_value +pic_load_load(pic_state *pic) +{ + pic_value envid; + char *fn; + + pic_get_args(pic, "z|o", &fn, &envid); + + return pic_load(pic, fn); +} + +void +pic_init_load(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme load)") { + pic_defun(pic, "load", pic_load_load); + } +} diff --git a/vm.c b/vm.c index 46034214..0d1eb93f 100644 --- a/vm.c +++ b/vm.c @@ -1075,13 +1075,3 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) return pic_car(pic, args); } } - -pic_value -pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) -{ - struct pic_proc *proc; - - proc = pic_compile(pic, program, lib); - - return pic_apply(pic, proc, pic_nil_value()); -} From ed9b14630bacea5febbd78ffc00d03a3ad4e8bac Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 18:50:15 +0900 Subject: [PATCH 046/232] refactor load --- include/picrin.h | 4 +-- load.c | 84 ++++++++++++++++++++++-------------------------- 2 files changed, 40 insertions(+), 48 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 3d22718d..a142f3c0 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -163,8 +163,8 @@ char *pic_strndup(pic_state *, const char *, size_t); pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read_cstr(pic_state *, const char *); -pic_value pic_load(pic_state *, const char *); -pic_value pic_load_cstr(pic_state *, const char *); +void pic_load(pic_state *, const char *); +void pic_load_cstr(pic_state *, const char *); pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply0(pic_state *, struct pic_proc *); diff --git a/load.c b/load.c index 440b45e2..6823764b 100644 --- a/load.c +++ b/load.c @@ -4,67 +4,57 @@ #include "picrin.h" #include "picrin/pair.h" +#include "picrin/port.h" +#include "picrin/error.h" -pic_value -pic_load_cstr(pic_state *pic, const char *src) +static void +pic_load_port(pic_state *pic, struct pic_port *port) { - size_t ai; - pic_value v, exprs; - struct pic_proc *proc; + pic_value form; - exprs = pic_parse_cstr(pic, src); - if (pic_undef_p(exprs)) { - pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); - } + pic_try { + size_t ai = pic_gc_arena_preserve(pic); - pic_for_each (v, exprs) { - ai = pic_gc_arena_preserve(pic); + while (! pic_eof_p(form = pic_read(pic, port))) { + pic_eval(pic, form, pic->lib); - proc = pic_compile(pic, v, pic->lib); - if (proc == NULL) { - pic_error(pic, "load: compilation failure"); + pic_gc_arena_restore(pic, ai); } - - pic_apply(pic, proc, pic_nil_value()); - - pic_gc_arena_restore(pic, ai); } - - return pic_none_value(); + pic_catch { + pic_errorf(pic, "load error: %s", pic_errmsg(pic)); + } } -pic_value -pic_load(pic_state *pic, const char *fn) +void +pic_load_cstr(pic_state *pic, const char *src) { - FILE *file; - size_t ai; - pic_value v, exprs; - struct pic_proc *proc; + struct pic_port *port = pic_open_input_string(pic, src); - file = fopen(fn, "r"); + pic_load_port(pic, port); + + pic_close_port(pic, port); +} + +void +pic_load(pic_state *pic, const char *filename) +{ + struct pic_port *port; + xFILE *file; + + file = xfopen(filename, "r"); if (file == NULL) { - pic_errorf(pic, "load: could not read file \"%s\"", fn); + pic_errorf(pic, "could not open file: %s", filename); } - exprs = pic_parse_file(pic, file); - if (pic_undef_p(exprs)) { - pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); - } + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = PIC_PORT_IN | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; - pic_for_each (v, exprs) { - ai = pic_gc_arena_preserve(pic); + pic_load_port(pic, port); - proc = pic_compile(pic, v, pic->lib); - if (proc == NULL) { - pic_error(pic, "load: compilation failure"); - } - - pic_apply(pic, proc, pic_nil_value()); - - pic_gc_arena_restore(pic, ai); - } - - return pic_none_value(); + pic_close_port(pic, port); } static pic_value @@ -75,7 +65,9 @@ pic_load_load(pic_state *pic) pic_get_args(pic, "z|o", &fn, &envid); - return pic_load(pic, fn); + pic_load(pic, fn); + + return pic_none_value(); } void From 062cfda6df3725532f300dfd52d04032ccd3a6fc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 18:50:35 +0900 Subject: [PATCH 047/232] Revert "remove time.c and system.c" This reverts commit bd2c5afb02282a19594dad811e887c2de3fd98c4. --- init.c | 4 ++ system.c | 136 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ time.c | 49 ++++++++++++++++++++ 3 files changed, 189 insertions(+) create mode 100644 system.c create mode 100644 time.c diff --git a/init.c b/init.c index 73dd8caf..5ff2231e 100644 --- a/init.c +++ b/init.c @@ -12,6 +12,8 @@ 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_time(pic_state *); +void pic_init_system(pic_state *); void pic_init_file(pic_state *); void pic_init_proc(pic_state *); void pic_init_symbol(pic_state *); @@ -51,6 +53,8 @@ pic_init_core(pic_state *pic) pic_init_pair(pic); DONE; pic_init_port(pic); DONE; pic_init_number(pic); DONE; + pic_init_time(pic); DONE; + pic_init_system(pic); DONE; pic_init_file(pic); DONE; pic_init_proc(pic); DONE; pic_init_symbol(pic); DONE; diff --git a/system.c b/system.c new file mode 100644 index 00000000..20203d27 --- /dev/null +++ b/system.c @@ -0,0 +1,136 @@ +/** + * See Copyright Notice in picrin.h + */ + +#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) +{ + pic_value v = pic_nil_value(); + int i; + + pic_get_args(pic, ""); + + for (i = 0; i < pic->argc; ++i) { + size_t ai = pic_gc_arena_preserve(pic); + + v = pic_cons(pic, pic_obj_value(pic_str_new_cstr(pic, pic->argv[i])), v); + pic_gc_arena_restore(pic, ai); + } + + return pic_reverse(pic, v); +} + +static pic_value +pic_system_exit(pic_state *pic) +{ + pic_value v; + int argc, status = EXIT_SUCCESS; + + argc = pic_get_args(pic, "|o", &v); + if (argc == 1) { + switch (pic_type(v)) { + case PIC_TT_FLOAT: + status = (int)pic_float(v); + break; + case PIC_TT_INT: + status = pic_int(v); + break; + default: + break; + } + } + + pic_close(pic); + + exit(status); +} + +static pic_value +pic_system_emergency_exit(pic_state *pic) +{ + pic_value v; + int argc, status = EXIT_FAILURE; + + argc = pic_get_args(pic, "|o", &v); + if (argc == 1) { + switch (pic_type(v)) { + case PIC_TT_FLOAT: + status = (int)pic_float(v); + break; + case PIC_TT_INT: + status = pic_int(v); + break; + default: + break; + } + } + + _Exit(status); +} + +static pic_value +pic_system_getenv(pic_state *pic) +{ + char *str, *val; + + pic_get_args(pic, "z", &str); + + val = getenv(str); + + if (val == NULL) + return pic_nil_value(); + else + return pic_obj_value(pic_str_new_cstr(pic, val)); +} + +static pic_value +pic_system_getenvs(pic_state *pic) +{ + char **envp; + pic_value data = pic_nil_value(); + size_t ai = pic_gc_arena_preserve(pic); + + pic_get_args(pic, ""); + + if (! pic->envp) { + return pic_nil_value(); + } + + for (envp = pic->envp; *envp; ++envp) { + pic_str *key, *val; + int i; + + for (i = 0; (*envp)[i] != '='; ++i) + ; + + key = pic_str_new(pic, *envp, i); + val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key))); + + /* push */ + data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, data); + } + + return data; +} + +void +pic_init_system(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme process-context)") { + pic_defun(pic, "command-line", pic_system_cmdline); + pic_defun(pic, "exit", pic_system_exit); + pic_defun(pic, "emergency-exit", pic_system_emergency_exit); + pic_defun(pic, "get-environment-variable", pic_system_getenv); + pic_defun(pic, "get-environment-variables", pic_system_getenvs); + } +} diff --git a/time.c b/time.c new file mode 100644 index 00000000..8e42dc8e --- /dev/null +++ b/time.c @@ -0,0 +1,49 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" + +#define UTC_TAI_DIFF 35 + +static pic_value +pic_current_second(pic_state *pic) +{ + time_t t; + + pic_get_args(pic, ""); + + time(&t); + return pic_float_value((double)t + UTC_TAI_DIFF); +} + +static pic_value +pic_current_jiffy(pic_state *pic) +{ + clock_t c; + + pic_get_args(pic, ""); + + c = clock(); + return pic_int_value(c); +} + +static pic_value +pic_jiffies_per_second(pic_state *pic) +{ + pic_get_args(pic, ""); + + return pic_int_value(CLOCKS_PER_SEC); +} + +void +pic_init_time(pic_state *pic) +{ + pic_deflibrary (pic, "(scheme time)") { + pic_defun(pic, "current-second", pic_current_second); + pic_defun(pic, "current-jiffy", pic_current_jiffy); + pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); + } +} From 4483f8224aefc982a336dfff76611c1fee77e6c4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 19:38:19 +0900 Subject: [PATCH 048/232] flatten the library hierarchy (again) --- eval.c | 4 +--- file.c | 14 ++++++-------- load.c | 4 +--- system.c | 12 +++++------- time.c | 8 +++----- 5 files changed, 16 insertions(+), 26 deletions(-) diff --git a/eval.c b/eval.c index 5a037c94..d8712760 100644 --- a/eval.c +++ b/eval.c @@ -33,7 +33,5 @@ pic_eval_eval(pic_state *pic) void pic_init_eval(pic_state *pic) { - pic_deflibrary (pic, "(scheme eval)") { - pic_defun(pic, "eval", pic_eval_eval); - } + pic_defun(pic, "eval", pic_eval_eval); } diff --git a/file.c b/file.c index befac195..22dd76e9 100644 --- a/file.c +++ b/file.c @@ -108,12 +108,10 @@ pic_file_delete(pic_state *pic) void pic_init_file(pic_state *pic) { - pic_deflibrary (pic, "(scheme file)") { - pic_defun(pic, "open-input-file", pic_file_open_input_file); - pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file); - pic_defun(pic, "open-output-file", pic_file_open_output_file); - pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file); - pic_defun(pic, "file-exists?", pic_file_exists_p); - pic_defun(pic, "delete-file", pic_file_delete); - } + pic_defun(pic, "open-input-file", pic_file_open_input_file); + pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file); + pic_defun(pic, "open-output-file", pic_file_open_output_file); + pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file); + pic_defun(pic, "file-exists?", pic_file_exists_p); + pic_defun(pic, "delete-file", pic_file_delete); } diff --git a/load.c b/load.c index 6823764b..83deb212 100644 --- a/load.c +++ b/load.c @@ -73,7 +73,5 @@ pic_load_load(pic_state *pic) void pic_init_load(pic_state *pic) { - pic_deflibrary (pic, "(scheme load)") { - pic_defun(pic, "load", pic_load_load); - } + pic_defun(pic, "load", pic_load_load); } diff --git a/system.c b/system.c index 20203d27..e9096a2b 100644 --- a/system.c +++ b/system.c @@ -126,11 +126,9 @@ pic_system_getenvs(pic_state *pic) void pic_init_system(pic_state *pic) { - pic_deflibrary (pic, "(scheme process-context)") { - pic_defun(pic, "command-line", pic_system_cmdline); - pic_defun(pic, "exit", pic_system_exit); - pic_defun(pic, "emergency-exit", pic_system_emergency_exit); - pic_defun(pic, "get-environment-variable", pic_system_getenv); - pic_defun(pic, "get-environment-variables", pic_system_getenvs); - } + pic_defun(pic, "command-line", pic_system_cmdline); + pic_defun(pic, "exit", pic_system_exit); + pic_defun(pic, "emergency-exit", pic_system_emergency_exit); + pic_defun(pic, "get-environment-variable", pic_system_getenv); + pic_defun(pic, "get-environment-variables", pic_system_getenvs); } diff --git a/time.c b/time.c index 8e42dc8e..43d770b3 100644 --- a/time.c +++ b/time.c @@ -41,9 +41,7 @@ pic_jiffies_per_second(pic_state *pic) void pic_init_time(pic_state *pic) { - pic_deflibrary (pic, "(scheme time)") { - pic_defun(pic, "current-second", pic_current_second); - pic_defun(pic, "current-jiffy", pic_current_jiffy); - pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); - } + pic_defun(pic, "current-second", pic_current_second); + pic_defun(pic, "current-jiffy", pic_current_jiffy); + pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); } From f7e0797f7cc91999baff80c08829bede1bce6bad Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 19:38:33 +0900 Subject: [PATCH 049/232] add the alias of call/cc --- cont.c | 1 + 1 file changed, 1 insertion(+) diff --git a/cont.c b/cont.c index 76760caf..6f4f1008 100644 --- a/cont.c +++ b/cont.c @@ -353,6 +353,7 @@ void pic_init_cont(pic_state *pic) { pic_defun(pic, "call-with-current-continuation", pic_cont_callcc); + pic_defun(pic, "call/cc", pic_cont_callcc); pic_defun(pic, "continue", pic_cont_continue); pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind); pic_defun(pic, "values", pic_cont_values); From a2848f3eafdbe3a4579dd4c8054ab7e3b62e6812 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 19:46:40 +0900 Subject: [PATCH 050/232] [bugfix] rename procedures --- file.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/file.c b/file.c index 22dd76e9..cfc266b5 100644 --- a/file.c +++ b/file.c @@ -43,7 +43,7 @@ pic_file_open_input_file(pic_state *pic) } pic_value -pic_file_open_input_binary_file(pic_state *pic) +pic_file_open_binary_input_file(pic_state *pic) { static const short flags = PIC_PORT_IN | PIC_PORT_BINARY; char *fname; @@ -65,7 +65,7 @@ pic_file_open_output_file(pic_state *pic) } pic_value -pic_file_open_output_binary_file(pic_state *pic) +pic_file_open_binary_output_file(pic_state *pic) { static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; char *fname; @@ -109,9 +109,9 @@ void pic_init_file(pic_state *pic) { pic_defun(pic, "open-input-file", pic_file_open_input_file); - pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file); + pic_defun(pic, "open-binary-input-file", pic_file_open_binary_input_file); pic_defun(pic, "open-output-file", pic_file_open_output_file); - pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file); + pic_defun(pic, "open-binary-output-file", pic_file_open_binary_output_file); pic_defun(pic, "file-exists?", pic_file_exists_p); pic_defun(pic, "delete-file", pic_file_delete); } From 839405e75200919ba62ba727e040872cc4234681 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 20:40:48 +0900 Subject: [PATCH 051/232] Revert "continuation object is applicable" This reverts commit b8b5743589ccbed555805d768d5c840aad350499. --- cont.c | 42 +++++++++++++++++++----------------------- include/picrin/cont.h | 1 - vm.c | 8 -------- 3 files changed, 19 insertions(+), 32 deletions(-) diff --git a/cont.c b/cont.c index 6f4f1008..c6408f5d 100644 --- a/cont.c +++ b/cont.c @@ -250,6 +250,25 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st return val; } +noreturn static pic_value +pic_cont_continue(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc; + pic_value cont, *argv; + + proc = pic_get_proc(pic); + pic_get_args(pic, "o*", &cont, &argc, &argv); + + pic_assert_type(pic, cont, cont); + + pic_cont_ptr(cont)->results = pic_list_by_array(pic, argc, argv); + + /* execute guard handlers */ + walk_to_block(pic, pic->blk, pic_cont_ptr(cont)->blk); + + restore_cont(pic, pic_cont_ptr(cont)); +} pic_value pic_callcc(pic_state *pic, struct pic_proc *proc) @@ -279,16 +298,6 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc) } } -noreturn void -pic_continue(pic_state *pic, struct pic_cont *cont, size_t argc, pic_value *argv) -{ - cont->results = pic_list_by_array(pic, argc, argv); - - walk_to_block(pic, pic->blk, cont->blk); - - restore_cont(pic, cont); -} - static pic_value pic_cont_callcc(pic_state *pic) { @@ -299,19 +308,6 @@ pic_cont_callcc(pic_state *pic) return pic_callcc_trampoline(pic, cb); } -noreturn static pic_value -pic_cont_continue(pic_state *pic) -{ - size_t argc; - pic_value cont, *argv; - - pic_get_args(pic, "o*", &cont, &argc, &argv); - - pic_assert_type(pic, cont, cont); - - pic_continue(pic, pic_cont_ptr(cont), argc, argv); -} - static pic_value pic_cont_dynamic_wind(pic_state *pic) { diff --git a/include/picrin/cont.h b/include/picrin/cont.h index ac5213eb..6f35de38 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -57,7 +57,6 @@ pic_value pic_values_by_list(pic_state *, pic_value); size_t pic_receive(pic_state *, size_t, pic_value *); pic_value pic_callcc(pic_state *, struct pic_proc *); -noreturn void pic_continue(pic_state *, struct pic_cont *, size_t, pic_value *); #if defined(__cplusplus) } diff --git a/vm.c b/vm.c index 0d1eb93f..044c5eb2 100644 --- a/vm.c +++ b/vm.c @@ -21,7 +21,6 @@ #include "picrin/error.h" #include "picrin/dict.h" #include "picrin/record.h" -#include "picrin/cont.h" #define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)]) @@ -753,13 +752,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) PUSH(pic_var_ref(pic, pic_var_ptr(x))); NEXT; } - if (pic_cont_p(x)) { - if (c.u.i >= 1) { - pic_errorf(pic, "invalid call-sequence for cont object"); - } - pic_continue(pic, pic_cont_ptr(x), c.u.i - 1, pic->sp - c.u.i + 1); - UNREACHABLE(); - } pic_errorf(pic, "invalid application: ~s", x); } proc = pic_proc_ptr(x); From c0adc87f12edc8f98f248f08f10fb35568d2d03a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 20:40:58 +0900 Subject: [PATCH 052/232] Revert "[bugfix] continue should set cont->results" This reverts commit 3a4de8895e3295de056a3eafd0d0588ec743b074. --- cont.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/cont.c b/cont.c index c6408f5d..ac7b56a4 100644 --- a/cont.c +++ b/cont.c @@ -262,8 +262,6 @@ pic_cont_continue(pic_state *pic) pic_assert_type(pic, cont, cont); - pic_cont_ptr(cont)->results = pic_list_by_array(pic, argc, argv); - /* execute guard handlers */ walk_to_block(pic, pic->blk, pic_cont_ptr(cont)->blk); From 8c174cd505aa4fc3b7937819506423b39b405216 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 20:41:31 +0900 Subject: [PATCH 053/232] Revert "change the interface of call/cc" This reverts commit e0831c1aa3c963111859278579a42dba997dc75d. --- cont.c | 34 +++++++++++++++++++++++++--------- include/picrin/cont.h | 3 --- 2 files changed, 25 insertions(+), 12 deletions(-) diff --git a/cont.c b/cont.c index ac7b56a4..6839c586 100644 --- a/cont.c +++ b/cont.c @@ -7,6 +7,7 @@ #include #include "picrin.h" +#include "picrin/proc.h" #include "picrin/cont.h" #include "picrin/pair.h" #include "picrin/error.h" @@ -251,21 +252,23 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st } noreturn static pic_value -pic_cont_continue(pic_state *pic) +cont_call(pic_state *pic) { struct pic_proc *proc; size_t argc; - pic_value cont, *argv; + pic_value *argv; + struct pic_cont *cont; proc = pic_get_proc(pic); - pic_get_args(pic, "o*", &cont, &argc, &argv); + pic_get_args(pic, "*", &argc, &argv); - pic_assert_type(pic, cont, cont); + cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont")); + cont->results = pic_list_by_array(pic, argc, argv); /* execute guard handlers */ - walk_to_block(pic, pic->blk, pic_cont_ptr(cont)->blk); + walk_to_block(pic, pic->blk, cont->blk); - restore_cont(pic, pic_cont_ptr(cont)); + restore_cont(pic, cont); } pic_value @@ -278,7 +281,14 @@ pic_callcc(pic_state *pic, struct pic_proc *proc) return pic_values_by_list(pic, cont->results); } else { - return pic_apply1(pic, proc, pic_obj_value(cont)); + struct pic_proc *c; + + c = pic_proc_new(pic, cont_call, ""); + + /* save the continuation object in proc */ + pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); + + return pic_apply1(pic, proc, pic_obj_value(c)); } } @@ -292,7 +302,14 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc) return pic_values_by_list(pic, cont->results); } else { - return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(cont))); + struct pic_proc *c; + + c = pic_proc_new(pic, cont_call, ""); + + /* save the continuation object in proc */ + pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); + + return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c))); } } @@ -348,7 +365,6 @@ pic_init_cont(pic_state *pic) { pic_defun(pic, "call-with-current-continuation", pic_cont_callcc); pic_defun(pic, "call/cc", pic_cont_callcc); - pic_defun(pic, "continue", pic_cont_continue); 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); diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 6f35de38..0a0da9f1 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -43,9 +43,6 @@ struct pic_cont { pic_value results; }; -#define pic_cont_p(o) (pic_type(o) == PIC_TT_CONT) -#define pic_cont_ptr(o) ((struct pic_cont *)pic_ptr(o)) - pic_value pic_values0(pic_state *); pic_value pic_values1(pic_state *, pic_value); pic_value pic_values2(pic_state *, pic_value, pic_value); From dd80aff03ab36fea0633e0e449c71fd489bc738a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 20:47:29 +0900 Subject: [PATCH 054/232] remove dicitonary-for-each --- dict.c | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/dict.c b/dict.c index fa7dff78..8adfc3b5 100644 --- a/dict.c +++ b/dict.c @@ -137,23 +137,6 @@ pic_dict_dict_size(pic_state *pic) return pic_int_value(pic_dict_size(pic, dict)); } -static pic_value -pic_dict_dict_for_each(pic_state *pic) -{ - struct pic_proc *proc; - struct pic_dict *dict; - xh_iter it; - - pic_get_args(pic, "ld", &proc, &dict); - - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { - pic_apply2(pic, proc, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); - } - - return pic_none_value(); -} - void pic_init_dict(pic_state *pic) { @@ -163,5 +146,4 @@ pic_init_dict(pic_state *pic) pic_defun(pic, "dictionary-set!", pic_dict_dict_set); pic_defun(pic, "dictionary-delete", pic_dict_dict_del); pic_defun(pic, "dictionary-size", pic_dict_dict_size); - pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each); } From 4fd4e15cc196a89e5ed5133896d7b8b9f4b2c10a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 23:31:04 +0900 Subject: [PATCH 055/232] load basic syntaxes at boot time --- boot.c | 739 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ init.c | 4 + 2 files changed, 743 insertions(+) create mode 100644 boot.c diff --git a/boot.c b/boot.c new file mode 100644 index 00000000..2a0c0691 --- /dev/null +++ b/boot.c @@ -0,0 +1,739 @@ +#if 0 + +use strict; + +open IN, "./boot.c"; +my @data = ; +close IN; + +open STDOUT, ">", "./boot.c"; + +foreach (@data) { + print; + last if $_ eq "#---END---\n"; +} + +print "\n#endif\n\n"; + +my $src = <<'EOL'; + +(define-library (picrin base) + + (define (memoize f) + "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 (er-macro-transformer f) + (lambda (expr use-env 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)))) + + (f expr rename compare))) + + (define-syntax syntax-error + (er-macro-transformer + (lambda (expr rename compare) + (apply error (cdr expr))))) + + (define-syntax define-auxiliary-syntax + (er-macro-transformer + (lambda (expr r c) + (list (r 'define-syntax) (cadr expr) + (list (r 'lambda) '_ + (list (r 'error) "invalid use of auxiliary syntax")))))) + + (define-auxiliary-syntax else) + (define-auxiliary-syntax =>) + (define-auxiliary-syntax _) + (define-auxiliary-syntax ...) + (define-auxiliary-syntax unquote) + (define-auxiliary-syntax unquote-splicing) + + (define-syntax let + (er-macro-transformer + (lambda (expr r compare) + (if (symbol? (cadr expr)) + (begin + (define name (car (cdr expr))) + (define bindings (car (cdr (cdr expr)))) + (define body (cdr (cdr (cdr expr)))) + (list (r 'let) '() + (list (r 'define) name + (cons (r 'lambda) (cons (map car bindings) body))) + (cons name (map cadr bindings)))) + (begin + (set! bindings (cadr expr)) + (set! body (cddr expr)) + (cons (cons (r 'lambda) (cons (map car bindings) body)) + (map cadr bindings))))))) + + (define-syntax cond + (er-macro-transformer + (lambda (expr r compare) + (let ((clauses (cdr expr))) + (if (null? clauses) + #f + (begin + (define clause (car clauses)) + (if (compare (r 'else) (car clause)) + (cons (r 'begin) (cdr clause)) + (if (if (>= (length clause) 2) + (compare (r '=>) (list-ref clause 1)) + #f) + (list (r 'let) (list (list (r 'x) (car clause))) + (list (r 'if) (r 'x) + (list (list-ref clause 2) (r 'x)) + (cons (r 'cond) (cdr clauses)))) + (list (r 'if) (car clause) + (cons (r 'begin) (cdr clause)) + (cons (r 'cond) (cdr clauses))))))))))) + + (define-syntax and + (er-macro-transformer + (lambda (expr r compare) + (let ((exprs (cdr expr))) + (cond + ((null? exprs) + #t) + ((= (length exprs) 1) + (car exprs)) + (else + (list (r 'let) (list (list (r 'it) (car exprs))) + (list (r 'if) (r 'it) + (cons (r 'and) (cdr exprs)) + (r 'it))))))))) + + (define-syntax or + (er-macro-transformer + (lambda (expr r compare) + (let ((exprs (cdr expr))) + (cond + ((null? exprs) + #t) + ((= (length exprs) 1) + (car exprs)) + (else + (list (r 'let) (list (list (r 'it) (car exprs))) + (list (r 'if) (r 'it) + (r 'it) + (cons (r 'or) (cdr exprs)))))))))) + + (define-syntax quasiquote + (er-macro-transformer + (lambda (form rename compare) + + (define (quasiquote? form) + (and (pair? form) (compare (car form) (rename 'quasiquote)))) + + (define (unquote? form) + (and (pair? form) (compare (car form) (rename 'unquote)))) + + (define (unquote-splicing? form) + (and (pair? form) (pair? (car form)) + (compare (car (car form)) (rename 'unquote-splicing)))) + + (define (qq depth expr) + (cond + ;; unquote + ((unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (rename 'list) + (list (rename 'quote) (rename 'unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; unquote-splicing + ((unquote-splicing? expr) + (if (= depth 1) + (list (rename 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (rename 'cons) + (list (rename 'list) + (list (rename 'quote) (rename 'unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; quasiquote + ((quasiquote? expr) + (list (rename 'list) + (list (rename 'quote) (rename 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (rename 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (rename 'list->vector) (qq depth (vector->list expr)))) + ;; simple datum + (else + (list (rename 'quote) expr)))) + + (let ((x (cadr form))) + (qq 1 x))))) + + (define-syntax let* + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (cadr form)) + (body (cddr form))) + (if (null? bindings) + `(,(r 'let) () ,@body) + `(,(r 'let) ((,(caar bindings) + ,@(cdar bindings))) + (,(r 'let*) (,@(cdr bindings)) + ,@body))))))) + + (define-syntax letrec* + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (cadr form)) + (body (cddr form))) + (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) + (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings))) + `(,(r 'let) (,@vars) + ,@initials + ,@body)))))) + + (define-syntax letrec + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'letrec*) ,@(cdr form))))) + + (define-syntax let*-values + (er-macro-transformer + (lambda (form r c) + (let ((formals (cadr form))) + (if (null? formals) + `(,(r 'let) () ,@(cddr form)) + `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals)) + (,(r 'lambda) (,@(caar formals)) + (,(r 'let*-values) (,@(cdr formals)) + ,@(cddr form))))))))) + + (define-syntax let-values + (er-macro-transformer + (lambda (form r c) + `(,(r 'let*-values) ,@(cdr form))))) + + (define-syntax define-values + (er-macro-transformer + (lambda (form r compare) + (let ((formal (cadr form)) + (exprs (cddr form))) + `(,(r 'begin) + ,@(let loop ((formal formal)) + (if (not (pair? formal)) + (if (symbol? formal) + `((,(r 'define) ,formal #f)) + '()) + `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal))))) + (,(r 'call-with-values) (,(r 'lambda) () ,@exprs) + (,(r 'lambda) ,(r 'args) + ,@(let loop ((formal formal) (args (r 'args))) + (if (not (pair? formal)) + (if (symbol? formal) + `((,(r 'set!) ,formal ,args)) + '()) + `((,(r 'set!) ,(car formal) (,(r 'car) ,args)) + ,@(loop (cdr formal) `(,(r 'cdr) ,args)))))))))))) + + (define-syntax do + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (car (cdr form))) + (finish (car (cdr (cdr form)))) + (body (cdr (cdr (cdr form))))) + `(,(r 'let) ,(r 'loop) ,(map (lambda (x) + (list (car x) (cadr x))) + bindings) + (,(r 'if) ,(car finish) + (,(r 'begin) ,@(cdr finish)) + (,(r 'begin) ,@body + (,(r 'loop) ,@(map (lambda (x) + (if (null? (cddr x)) + (car x) + (car (cddr x)))) + bindings))))))))) + + (define-syntax when + (er-macro-transformer + (lambda (expr rename compare) + (let ((test (cadr expr)) + (body (cddr expr))) + `(,(rename 'if) ,test + (,(rename 'begin) ,@body) + #f))))) + + (define-syntax unless + (er-macro-transformer + (lambda (expr rename compare) + (let ((test (cadr expr)) + (body (cddr expr))) + `(,(rename 'if) ,test + #f + (,(rename 'begin) ,@body)))))) + + (define-syntax case + (er-macro-transformer + (lambda (expr r compare) + (let ((key (cadr expr)) + (clauses (cddr expr))) + `(,(r 'let) ((,(r 'key) ,key)) + ,(let loop ((clauses clauses)) + (if (null? clauses) + #f + (begin + (define clause (car clauses)) + `(,(r 'if) ,(if (compare (r 'else) (car clause)) + '#t + `(,(r 'or) + ,@(map (lambda (x) + `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) + (car clause)))) + ,(if (compare (r '=>) (list-ref clause 1)) + `(,(list-ref clause 2) ,(r 'key)) + `(,(r 'begin) ,@(cdr clause))) + ,(loop (cdr clauses))))))))))) + + (define-syntax letrec-syntax + (er-macro-transformer + (lambda (form r c) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(r 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body))))) + + (define-syntax let-syntax + (er-macro-transformer + (lambda (form r c) + `(,(r 'letrec-syntax) ,@(cdr form))))) + + (define-syntax include + (letrec ((read-file + (lambda (filename) + (let ((port (open-input-file filename))) + (dynamic-wind + (lambda () #f) + (lambda () + (let loop ((expr (read port)) (exprs '())) + (if (eof-object? expr) + (reverse exprs) + (loop (read port) (cons expr exprs))))) + (lambda () + (close-port port))))))) + (er-macro-transformer + (lambda (form rename compare) + (let ((filenames (cdr form))) + (let ((exprs (apply append (map read-file filenames)))) + `(,(rename 'begin) ,@exprs))))))) + + (export let let* letrec letrec* + let-values let*-values define-values + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + let-syntax letrec-syntax + include + _ ... syntax-error)) + +EOL + +print <)\n" +" (define-auxiliary-syntax _)\n" +" (define-auxiliary-syntax ...)\n" +" (define-auxiliary-syntax unquote)\n" +" (define-auxiliary-syntax unquote-splicing)\n" +"\n" +" (define-syntax let\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (if (symbol? (cadr expr))\n" +" (begin\n" +" (define name (car (cdr expr)))\n" +" (define bindings (car (cdr (cdr expr))))\n" +" (define body (cdr (cdr (cdr expr))))\n" +" (list (r 'let) '()\n" +" (list (r 'define) name\n" +" (cons (r 'lambda) (cons (map car bindings) body)))\n" +" (cons name (map cadr bindings))))\n" +" (begin\n" +" (set! bindings (cadr expr))\n" +" (set! body (cddr expr))\n" +" (cons (cons (r 'lambda) (cons (map car bindings) body))\n" +" (map cadr bindings)))))))\n" +"\n" +" (define-syntax cond\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((clauses (cdr expr)))\n" +" (if (null? clauses)\n" +" #f\n" +" (begin\n" +" (define clause (car clauses))\n" +" (if (compare (r 'else) (car clause))\n" +" (cons (r 'begin) (cdr clause))\n" +" (if (if (>= (length clause) 2)\n" +" (compare (r '=>) (list-ref clause 1))\n" +" #f)\n" +" (list (r 'let) (list (list (r 'x) (car clause)))\n" +" (list (r 'if) (r 'x)\n" +" (list (list-ref clause 2) (r 'x))\n" +" (cons (r 'cond) (cdr clauses))))\n" +" (list (r 'if) (car clause)\n" +" (cons (r 'begin) (cdr clause))\n" +" (cons (r 'cond) (cdr clauses)))))))))))\n" +"\n" +" (define-syntax and\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((exprs (cdr expr)))\n" +" (cond\n" +" ((null? exprs)\n" +" #t)\n" +" ((= (length exprs) 1)\n" +" (car exprs))\n" +" (else\n" +" (list (r 'let) (list (list (r 'it) (car exprs)))\n" +" (list (r 'if) (r 'it)\n" +" (cons (r 'and) (cdr exprs))\n" +" (r 'it)))))))))\n" +"\n" +" (define-syntax or\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((exprs (cdr expr)))\n" +" (cond\n" +" ((null? exprs)\n" +" #t)\n" +" ((= (length exprs) 1)\n" +" (car exprs))\n" +" (else\n" +" (list (r 'let) (list (list (r 'it) (car exprs)))\n" +" (list (r 'if) (r 'it)\n" +" (r 'it)\n" +" (cons (r 'or) (cdr exprs))))))))))\n" +"\n" +" (define-syntax quasiquote\n" +" (er-macro-transformer\n" +" (lambda (form rename compare)\n" +"\n" +" (define (quasiquote? form)\n" +" (and (pair? form) (compare (car form) (rename 'quasiquote))))\n" +"\n" +" (define (unquote? form)\n" +" (and (pair? form) (compare (car form) (rename 'unquote))))\n" +"\n" +" (define (unquote-splicing? form)\n" +" (and (pair? form) (pair? (car form))\n" +" (compare (car (car form)) (rename 'unquote-splicing))))\n" +"\n" +" (define (qq depth expr)\n" +" (cond\n" +" ;; unquote\n" +" ((unquote? expr)\n" +" (if (= depth 1)\n" +" (car (cdr expr))\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'unquote))\n" +" (qq (- depth 1) (car (cdr expr))))))\n" +" ;; unquote-splicing\n" +" ((unquote-splicing? expr)\n" +" (if (= depth 1)\n" +" (list (rename 'append)\n" +" (car (cdr (car expr)))\n" +" (qq depth (cdr expr)))\n" +" (list (rename 'cons)\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'unquote-splicing))\n" +" (qq (- depth 1) (car (cdr (car expr)))))\n" +" (qq depth (cdr expr)))))\n" +" ;; quasiquote\n" +" ((quasiquote? expr)\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'quasiquote))\n" +" (qq (+ depth 1) (car (cdr expr)))))\n" +" ;; list\n" +" ((pair? expr)\n" +" (list (rename 'cons)\n" +" (qq depth (car expr))\n" +" (qq depth (cdr expr))))\n" +" ;; vector\n" +" ((vector? expr)\n" +" (list (rename 'list->vector) (qq depth (vector->list expr))))\n" +" ;; simple datum\n" +" (else\n" +" (list (rename 'quote) expr))))\n" +"\n" +" (let ((x (cadr form)))\n" +" (qq 1 x)))))\n" +"\n" +" (define-syntax let*\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (cadr form))\n" +" (body (cddr form)))\n" +" (if (null? bindings)\n" +" `(,(r 'let) () ,@body)\n" +" `(,(r 'let) ((,(caar bindings)\n" +" ,@(cdar bindings)))\n" +" (,(r 'let*) (,@(cdr bindings))\n" +" ,@body)))))))\n" +"\n" +" (define-syntax letrec*\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (cadr form))\n" +" (body (cddr form)))\n" +" (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n" +" (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n" +" `(,(r 'let) (,@vars)\n" +" ,@initials\n" +" ,@body))))))\n" +"\n" +" (define-syntax letrec\n" +" (er-macro-transformer\n" +" (lambda (form rename compare)\n" +" `(,(rename 'letrec*) ,@(cdr form)))))\n" +"\n" +" (define-syntax let*-values\n" +" (er-macro-transformer\n" +" (lambda (form r c)\n" +" (let ((formals (cadr form)))\n" +" (if (null? formals)\n" +" `(,(r 'let) () ,@(cddr form))\n" +" `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n" +" (,(r 'lambda) (,@(caar formals))\n" +" (,(r 'let*-values) (,@(cdr formals))\n" +" ,@(cddr form)))))))))\n" +"\n" +" (define-syntax let-values\n" +" (er-macro-transformer\n" +" (lambda (form r c)\n" +" `(,(r 'let*-values) ,@(cdr form)))))\n" +"\n" +" (define-syntax define-values\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((formal (cadr form))\n" +" (exprs (cddr form)))\n" +" `(,(r 'begin)\n" +" ,@(let loop ((formal formal))\n" +" (if (not (pair? formal))\n" +" (if (symbol? formal)\n" +" `((,(r 'define) ,formal #f))\n" +" '())\n" +" `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal)))))\n" +" (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n" +" (,(r 'lambda) ,(r 'args)\n" +" ,@(let loop ((formal formal) (args (r 'args)))\n" +" (if (not (pair? formal))\n" +" (if (symbol? formal)\n" +" `((,(r 'set!) ,formal ,args))\n" +" '())\n" +" `((,(r 'set!) ,(car formal) (,(r 'car) ,args))\n" +" ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))\n" +"\n" +" (define-syntax do\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (car (cdr form)))\n" +" (finish (car (cdr (cdr form))))\n" +" (body (cdr (cdr (cdr form)))))\n" +" `(,(r 'let) ,(r 'loop) ,(map (lambda (x)\n" +" (list (car x) (cadr x)))\n" +" bindings)\n" +" (,(r 'if) ,(car finish)\n" +" (,(r 'begin) ,@(cdr finish))\n" +" (,(r 'begin) ,@body\n" +" (,(r 'loop) ,@(map (lambda (x)\n" +" (if (null? (cddr x))\n" +" (car x)\n" +" (car (cddr x))))\n" +" bindings)))))))))\n" +"\n" +" (define-syntax when\n" +" (er-macro-transformer\n" +" (lambda (expr rename compare)\n" +" (let ((test (cadr expr))\n" +" (body (cddr expr)))\n" +" `(,(rename 'if) ,test\n" +" (,(rename 'begin) ,@body)\n" +" #f)))))\n" +"\n" +" (define-syntax unless\n" +" (er-macro-transformer\n" +" (lambda (expr rename compare)\n" +" (let ((test (cadr expr))\n" +" (body (cddr expr)))\n" +" `(,(rename 'if) ,test\n" +" #f\n" +" (,(rename 'begin) ,@body))))))\n" +"\n" +" (define-syntax case\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((key (cadr expr))\n" +" (clauses (cddr expr)))\n" +" `(,(r 'let) ((,(r 'key) ,key))\n" +" ,(let loop ((clauses clauses))\n" +" (if (null? clauses)\n" +" #f\n" +" (begin\n" +" (define clause (car clauses))\n" +" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n" +" '#t\n" +" `(,(r 'or)\n" +" ,@(map (lambda (x)\n" +" `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n" +" (car clause))))\n" +" ,(if (compare (r '=>) (list-ref clause 1))\n" +" `(,(list-ref clause 2) ,(r 'key))\n" +" `(,(r 'begin) ,@(cdr clause)))\n" +" ,(loop (cdr clauses)))))))))))\n" +"\n" +" (define-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" +" (define-syntax include\n" +" (letrec ((read-file\n" +" (lambda (filename)\n" +" (let ((port (open-input-file filename)))\n" +" (dynamic-wind\n" +" (lambda () #f)\n" +" (lambda ()\n" +" (let loop ((expr (read port)) (exprs '()))\n" +" (if (eof-object? expr)\n" +" (reverse exprs)\n" +" (loop (read port) (cons expr exprs)))))\n" +" (lambda ()\n" +" (close-port port)))))))\n" +" (er-macro-transformer\n" +" (lambda (form rename compare)\n" +" (let ((filenames (cdr form)))\n" +" (let ((exprs (apply append (map read-file filenames))))\n" +" `(,(rename 'begin) ,@exprs)))))))\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" +" let-syntax letrec-syntax\n" +" include\n" +" _ ... syntax-error))\n" +; + +#if 0 +=cut +#endif diff --git a/init.c b/init.c index 5ff2231e..a5e70d71 100644 --- a/init.c +++ b/init.c @@ -35,6 +35,8 @@ void pic_init_lib(pic_state *); #define DONE pic_gc_arena_restore(pic, ai); +extern const char pic_boot[]; + void pic_init_core(pic_state *pic) { @@ -73,5 +75,7 @@ pic_init_core(pic_state *pic) pic_init_record(pic); DONE; pic_init_eval(pic); DONE; pic_init_lib(pic); DONE; + + pic_load_cstr(pic, pic_boot); } } From 2d80522230358a4f3f2a1cd1af56da16d0f612d0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 9 Sep 2014 00:08:15 +0900 Subject: [PATCH 056/232] revert pic_open API --- include/picrin.h | 2 +- state.c | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index a142f3c0..fff10cbb 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -134,7 +134,7 @@ 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, xFILE *stdio[3]); +pic_state *pic_open(int argc, char *argv[], char **envp); void pic_close(pic_state *); void pic_define(pic_state *, const char *, pic_value); /* automatic export */ diff --git a/state.c b/state.c index 28ee47e1..0b2b5123 100644 --- a/state.c +++ b/state.c @@ -16,7 +16,7 @@ void pic_init_core(pic_state *); pic_state * -pic_open(int argc, char *argv[], char **envp, xFILE *stdio[3]) +pic_open(int argc, char *argv[], char **envp) { struct pic_port *pic_port_make_stdport(pic_state *, xFILE *, short); char t; @@ -156,9 +156,9 @@ pic_open(int argc, char *argv[], char **envp, xFILE *stdio[3]) pic->lib = pic->PICRIN_USER; /* standard I/O */ - pic->xSTDIN = pic_port_make_stdport(pic, stdio[0], PIC_PORT_IN); - pic->xSTDOUT = pic_port_make_stdport(pic, stdio[1], PIC_PORT_OUT); - pic->xSTDERR = pic_port_make_stdport(pic, stdio[2], PIC_PORT_OUT); + pic->xSTDIN = pic_port_make_stdport(pic, xstdin, PIC_PORT_IN); + pic->xSTDOUT = pic_port_make_stdport(pic, xstdout, PIC_PORT_OUT); + pic->xSTDERR = pic_port_make_stdport(pic, xstderr, PIC_PORT_OUT); pic_init_core(pic); From c3acc4cb44bcf3baf9c50bb4667ad20c77660c3f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 9 Sep 2014 00:51:49 +0900 Subject: [PATCH 057/232] remove aux syntax for syntax-rules --- boot.c | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/boot.c b/boot.c index 2a0c0691..7bb9ca1a 100644 --- a/boot.c +++ b/boot.c @@ -63,8 +63,6 @@ my $src = <<'EOL'; (define-auxiliary-syntax else) (define-auxiliary-syntax =>) - (define-auxiliary-syntax _) - (define-auxiliary-syntax ...) (define-auxiliary-syntax unquote) (define-auxiliary-syntax unquote-splicing) @@ -358,7 +356,7 @@ my $src = <<'EOL'; do when unless let-syntax letrec-syntax include - _ ... syntax-error)) + syntax-error)) EOL @@ -436,8 +434,6 @@ const char pic_boot[] = "\n" " (define-auxiliary-syntax else)\n" " (define-auxiliary-syntax =>)\n" -" (define-auxiliary-syntax _)\n" -" (define-auxiliary-syntax ...)\n" " (define-auxiliary-syntax unquote)\n" " (define-auxiliary-syntax unquote-splicing)\n" "\n" @@ -731,7 +727,7 @@ const char pic_boot[] = " do when unless\n" " let-syntax letrec-syntax\n" " include\n" -" _ ... syntax-error))\n" +" syntax-error))\n" ; #if 0 From ce1d5c06532d97110bd2719c9e05b716f3797592 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 9 Sep 2014 01:12:52 +0900 Subject: [PATCH 058/232] Revert "immutable string" This reverts commit e56f2dce2815ec2273b986075b41a8deb10e7716. --- include/picrin/string.h | 3 ++ string.c | 98 ++++++++++++++++++++++++++++++++++++++++- 2 files changed, 99 insertions(+), 2 deletions(-) diff --git a/include/picrin/string.h b/include/picrin/string.h index 9cb7d3eb..3df116cf 100644 --- a/include/picrin/string.h +++ b/include/picrin/string.h @@ -19,9 +19,12 @@ struct pic_string { pic_str *pic_str_new(pic_state *, const char * /* nullable */, size_t); pic_str *pic_str_new_cstr(pic_state *, const char *); +pic_str *pic_str_new_fill(pic_state *, size_t, char); size_t pic_strlen(pic_str *); char pic_str_ref(pic_state *, pic_str *, size_t); +void pic_str_set(pic_state *, pic_str *, size_t, char); + 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 *); diff --git a/string.c b/string.c index 7afa7a26..92a3c569 100644 --- a/string.c +++ b/string.c @@ -34,6 +34,25 @@ pic_str_new_cstr(pic_state *pic, const char *cstr) return pic_str_new(pic, cstr, strlen(cstr)); } +pic_str * +pic_str_new_fill(pic_state *pic, size_t len, char fill) +{ + size_t i; + char *cstr; + pic_str *str; + + cstr = (char *)pic_alloc(pic, len + 1); + cstr[len] = '\0'; + for (i = 0; i < len; ++i) { + cstr[i] = fill; + } + + str = pic_str_new(pic, cstr, len); + + pic_free(pic, cstr); + return str; +} + size_t pic_strlen(pic_str *str) { @@ -257,6 +276,17 @@ pic_str_string_p(pic_state *pic) return pic_bool_value(pic_str_p(v)); } +static pic_value +pic_str_make_string(pic_state *pic) +{ + int len; + char c = ' '; + + pic_get_args(pic, "i|c", &len, &c); + + return pic_obj_value(pic_str_new_fill(pic, len, c)); +} + static pic_value pic_str_string_length(pic_state *pic) { @@ -278,6 +308,19 @@ pic_str_string_ref(pic_state *pic) return pic_char_value(pic_str_ref(pic, str, k)); } +static pic_value +pic_str_string_set(pic_state *pic) +{ + pic_str *str; + char c; + int k; + + pic_get_args(pic, "sic", &str, &k, &c); + + pic_str_set(pic, str, k, c); + return pic_none_value(); +} + #define DEFINE_STRING_CMP(name, op) \ static pic_value \ pic_str_string_##name(pic_state *pic) \ @@ -327,6 +370,30 @@ pic_str_string_copy(pic_state *pic) return pic_obj_value(pic_substr(pic, str, start, end)); } +static pic_value +pic_str_string_copy_ip(pic_state *pic) +{ + pic_str *to, *from; + int n, at, start, end; + + n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end); + + switch (n) { + case 3: + start = 0; + case 4: + end = pic_strlen(from); + } + if (to == from) { + from = pic_substr(pic, from, 0, end); + } + + while (start < end) { + pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++)); + } + return pic_none_value(); +} + static pic_value pic_str_string_append(pic_state *pic) { @@ -346,18 +413,45 @@ pic_str_string_append(pic_state *pic) return pic_obj_value(str); } +static pic_value +pic_str_string_fill_ip(pic_state *pic) +{ + pic_str *str; + char c; + int n, start, end; + + n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end); + + switch (n) { + case 2: + start = 0; + case 3: + end = pic_strlen(str); + } + + while (start < end) { + pic_str_set(pic, str, start++, c); + } + return pic_none_value(); +} + void pic_init_str(pic_state *pic) { pic_defun(pic, "string?", pic_str_string_p); + pic_defun(pic, "make-string", pic_str_make_string); pic_defun(pic, "string-length", pic_str_string_length); pic_defun(pic, "string-ref", pic_str_string_ref); - pic_defun(pic, "string-copy", pic_str_string_copy); - pic_defun(pic, "string-append", pic_str_string_append); + pic_defun(pic, "string-set!", pic_str_string_set); pic_defun(pic, "string=?", pic_str_string_eq); pic_defun(pic, "string?", pic_str_string_gt); pic_defun(pic, "string<=?", pic_str_string_le); pic_defun(pic, "string>=?", pic_str_string_ge); + + pic_defun(pic, "string-copy", pic_str_string_copy); + pic_defun(pic, "string-copy!", pic_str_string_copy_ip); + pic_defun(pic, "string-append", pic_str_string_append); + pic_defun(pic, "string-fill!", pic_str_string_fill_ip); } From 5331d6f23c7df61e75c00879cd270ea1c4d7df85 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 9 Sep 2014 01:23:58 +0900 Subject: [PATCH 059/232] refactor string.c --- string.c | 65 +++++++++++++++++--------------------------------------- 1 file changed, 19 insertions(+), 46 deletions(-) diff --git a/string.c b/string.c index 92a3c569..67f9b401 100644 --- a/string.c +++ b/string.c @@ -38,19 +38,14 @@ pic_str * pic_str_new_fill(pic_state *pic, size_t len, char fill) { size_t i; - char *cstr; - pic_str *str; + char buf[len + 1]; - cstr = (char *)pic_alloc(pic, len + 1); - cstr[len] = '\0'; for (i = 0; i < len; ++i) { - cstr[i] = fill; + buf[i] = fill; } + buf[i] = '\0'; - str = pic_str_new(pic, cstr, len); - - pic_free(pic, cstr); - return str; + return pic_str_new(pic, buf, len); } size_t @@ -71,45 +66,24 @@ pic_str_ref(pic_state *pic, pic_str *str, size_t i) return (char)c; } -static xrope * -xr_put(xrope *rope, size_t i, char c) -{ - xrope *x, *y, *z; - char buf[2]; - - if (xr_len(rope) <= i) { - return NULL; - } - - buf[0] = c; - buf[1] = '\0'; - - x = xr_sub(rope, 0, i); - y = xr_new_copy(buf, 1); - z = xr_cat(x, y); - XROPE_DECREF(x); - XROPE_DECREF(y); - - x = z; - y = xr_sub(rope, i + 1, xr_len(rope)); - z = xr_cat(z, y); - XROPE_DECREF(x); - XROPE_DECREF(y); - - return z; -} - void pic_str_set(pic_state *pic, pic_str *str, size_t i, char c) { - xrope *x; + pic_str *x, *y, *z, *tmp; - x = xr_put(str->rope, i, c); - if (x == NULL) { + if (pic_strlen(str) <= i) { pic_errorf(pic, "index out of range %d", i); } + + x = pic_substr(pic, str, 0, i); + y = pic_str_new_fill(pic, 1, c); + z = pic_substr(pic, str, i + 1, pic_strlen(str)); + + tmp = pic_strcat(pic, x, pic_strcat(pic, y, z)); + + XROPE_INCREF(tmp->rope); XROPE_DECREF(str->rope); - str->rope = x; + str->rope = tmp->rope; } pic_str * @@ -443,15 +417,14 @@ pic_init_str(pic_state *pic) pic_defun(pic, "string-length", pic_str_string_length); pic_defun(pic, "string-ref", pic_str_string_ref); pic_defun(pic, "string-set!", pic_str_string_set); + pic_defun(pic, "string-copy", pic_str_string_copy); + pic_defun(pic, "string-copy!", pic_str_string_copy_ip); + pic_defun(pic, "string-append", pic_str_string_append); + pic_defun(pic, "string-fill!", pic_str_string_fill_ip); pic_defun(pic, "string=?", pic_str_string_eq); pic_defun(pic, "string?", pic_str_string_gt); pic_defun(pic, "string<=?", pic_str_string_le); pic_defun(pic, "string>=?", pic_str_string_ge); - - pic_defun(pic, "string-copy", pic_str_string_copy); - pic_defun(pic, "string-copy!", pic_str_string_copy_ip); - pic_defun(pic, "string-append", pic_str_string_append); - pic_defun(pic, "string-fill!", pic_str_string_fill_ip); } From 92749325a9ac2a37efde9dd8914b2306c1f80276 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 9 Sep 2014 01:38:52 +0900 Subject: [PATCH 060/232] fix a bug in the definitino of define-values --- boot.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/boot.c b/boot.c index 7bb9ca1a..00b1671e 100644 --- a/boot.c +++ b/boot.c @@ -244,7 +244,7 @@ my $src = <<'EOL'; (if (symbol? formal) `((,(r 'define) ,formal #f)) '()) - `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal))))) + `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal))))) (,(r 'call-with-values) (,(r 'lambda) () ,@exprs) (,(r 'lambda) ,(r 'args) ,@(let loop ((formal formal) (args (r 'args))) @@ -615,7 +615,7 @@ const char pic_boot[] = " (if (symbol? formal)\n" " `((,(r 'define) ,formal #f))\n" " '())\n" -" `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal)))))\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" From 813ce064f3eb5ab56b80b0560c2c06138084ccf3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 9 Sep 2014 02:12:51 +0900 Subject: [PATCH 061/232] add port-open? --- port.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/port.c b/port.c index f53832f5..1b217873 100644 --- a/port.c +++ b/port.c @@ -206,6 +206,16 @@ pic_port_eof_object(pic_state *pic) return pic_eof_object(); } +static pic_value +pic_port_port_open_p(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, "p", &port); + + return pic_bool_value(port->status == PIC_PORT_OPEN); +} + static pic_value pic_port_close_port(pic_state *pic) { @@ -665,6 +675,8 @@ pic_init_port(pic_state *pic) pic_defun(pic, "textual-port?", pic_port_textual_port_p); pic_defun(pic, "binary-port?", pic_port_binary_port_p); pic_defun(pic, "port?", pic_port_port_p); + + pic_defun(pic, "port-open?", pic_port_port_open_p); pic_defun(pic, "close-port", pic_port_close_port); /* string I/O */ From a0687e29e00c5e0389c7ed65415edca5e2a0dd75 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 9 Sep 2014 14:46:56 +0900 Subject: [PATCH 062/232] update xfile --- include/picrin/xfile.h | 522 ++++++++++++++++++++++++++++++++++++++--- xfile.c | 445 ----------------------------------- 2 files changed, 492 insertions(+), 475 deletions(-) delete mode 100644 xfile.c diff --git a/include/picrin/xfile.h b/include/picrin/xfile.h index 86fcb458..9d814bdc 100644 --- a/include/picrin/xfile.h +++ b/include/picrin/xfile.h @@ -8,6 +8,8 @@ extern "C" { #include #include #include +#include +#include typedef struct { int ungot; @@ -24,52 +26,512 @@ typedef struct { } xFILE; /* generic file constructor */ -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 *)); +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 *)); /* resource aquisition */ -xFILE *xfopen(const char *, const char *); -xFILE *xfpopen(FILE *); -xFILE *xmopen(); -int xfclose(xFILE *); +static inline xFILE *xfpopen(FILE *); +static inline xFILE *xmopen(); +static inline xFILE *xfopen(const char *, const char *); +static inline int xfclose(xFILE *); /* buffer management */ -int xfflush(xFILE *); +static inline int xfflush(xFILE *); /* direct IO with buffering */ -size_t xfread(void *, size_t, size_t, xFILE *); -size_t xfwrite(const void *, size_t, size_t, xFILE *); +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 */ -long xfseek(xFILE *, long offset, int whence); -long xftell(xFILE *); -void xrewind(xFILE *); +static inline long xfseek(xFILE *, long offset, int whence); +static inline long xftell(xFILE *); +static inline void xrewind(xFILE *); /* stream status */ -void xclearerr(xFILE *); -int xfeof(xFILE *); -int xferror(xFILE *); +static inline void xclearerr(xFILE *); +static inline int xfeof(xFILE *); +static inline int xferror(xFILE *); /* character IO */ -int xfgetc(xFILE *); -char *xfgets(char *, int, xFILE *); -int xfputc(int, xFILE *); -int xfputs(const char *, xFILE *); -char xgetc(xFILE *); -int xgetchar(void); -int xputc(int, xFILE *); -int xputchar(int); -int xputs(char *); -int xungetc(int, xFILE *); +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 char xgetc(xFILE *); +static inline int xgetchar(void); +static inline int xputc(int, xFILE *); +static inline int xputchar(int); +static inline int xputs(char *); +static inline int xungetc(int, xFILE *); /* formatted I/O */ -int xprintf(const char *, ...); -int xfprintf(xFILE *, const char *, ...); -int xvfprintf(xFILE *, const char *, va_list); +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 */ -extern xFILE *xstdin; -extern xFILE *xstdout; -extern xFILE *xstderr; +#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 FILE * +xf_unpack(void *cookie) +{ + switch ((long)cookie) { + default: return cookie; + case 0: return stdin; + case 1: return stdout; + case -1: return stderr; + } +} + +static inline int +xf_file_read(void *cookie, char *ptr, int size) +{ + FILE *file = xf_unpack(cookie); + int r; + + r = fread(ptr, 1, 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 = xf_unpack(cookie); + int r; + + r = fwrite(ptr, 1, size, file); + if (r < size) { + return -1; + } + return r; +} + +static inline long +xf_file_seek(void *cookie, long pos, int whence) +{ + return fseek(xf_unpack(cookie), pos, whence); +} + +static inline int +xf_file_flush(void *cookie) +{ + return fflush(xf_unpack(cookie)); +} + +static inline int +xf_file_close(void *cookie) +{ + return fclose(xf_unpack(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 xfile_stdin = { -1, 0, { (void *)0, XF_FILE_VTABLE } }; + + return &xfile_stdin; +} + +static inline xFILE * +xstdout__() +{ + static xFILE xfile_stdout = { -1, 0, { (void *)1, XF_FILE_VTABLE } }; + + return &xfile_stdout; +} + +static inline xFILE * +xstderr__() +{ + static xFILE xfile_stderr = { -1, 0, { (void *)-1, XF_FILE_VTABLE } }; + + return &xfile_stderr; +} + +struct xf_membuf { + char *buf; + long pos, end, capa; +}; + +static inline int +xf_mem_read(void *cookie, char *ptr, int size) +{ + struct xf_membuf *mem; + + mem = (struct xf_membuf *)cookie; + + if (size > mem->end - mem->pos) + size = 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, 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] = file->ungot; + offset += 1; + file->ungot = -1; + } + while (offset < block) { + n = file->vtable.read(file->vtable.cookie, buf + offset, block - offset); + if (n < 0) { + file->flags |= XF_ERR; + goto exit; + } + if (n == 0) { + file->flags |= XF_EOF; + goto exit; + } + offset += 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, block - offset); + if (n < 0) { + file->flags |= XF_ERR; + goto exit; + } + offset += 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)) { + return EOF; + } + + return buf[0]; +} + +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] = c; + xfwrite(buf, 1, 1, file); + + return buf[0]; +} + +static inline int +xputchar(int c) +{ + return xfputc(c, xstdout); +} + +static inline int +xfputs(const char *str, xFILE *file) +{ + int len; + + len = strlen(str); + xfwrite(str, len, 1, file); + + return 0; +} + +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 sizeof buf; + } +} #if defined(__cplusplus) } diff --git a/xfile.c b/xfile.c deleted file mode 100644 index 60d47a8a..00000000 --- a/xfile.c +++ /dev/null @@ -1,445 +0,0 @@ -#include "picrin/xfile.h" - -#include -#include -#include - -#define min(a,b) (((a)>(b))?(b):(a)) -#define max(a,b) (((a)<(b))?(b):(a)) - -#define XF_EOF 1 -#define XF_ERR 2 - -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; -} - -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; -} - -int -xfclose(xFILE *file) -{ - int r; - - r = file->vtable.close(file->vtable.cookie); - if (r == EOF) { - return -1; - } - - free(file); - return 0; -} - -int -xfflush(xFILE *file) -{ - return file->vtable.flush(file->vtable.cookie); -} - -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] = file->ungot; - offset += 1; - file->ungot = -1; - } - while (offset < block) { - n = file->vtable.read(file->vtable.cookie, buf + offset, block - offset); - if (n < 0) { - file->flags |= XF_ERR; - goto exit; - } - if (n == 0) { - file->flags |= XF_EOF; - goto exit; - } - offset += n; - } - memcpy(dst, buf, block); - dst += block; - } - - exit: - return i; -} - -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, block - offset); - if (n < 0) { - file->flags |= XF_ERR; - goto exit; - } - offset += n; - } - dst += block; - } - - exit: - return i; -} - -long -xfseek(xFILE *file, long offset, int whence) -{ - file->ungot = -1; - return file->vtable.seek(file->vtable.cookie, offset, whence); -} - -long -xftell(xFILE *file) -{ - return xfseek(file, 0, SEEK_CUR); -} - -void -xrewind(xFILE *file) -{ - xfseek(file, 0, SEEK_SET); -} - -void -xclearerr(xFILE *file) -{ - file->flags = 0; -} - -int -xfeof(xFILE *file) -{ - return file->flags & XF_EOF; -} - -int -xferror(xFILE *file) -{ - return file->flags & XF_ERR; -} - -int -xfgetc(xFILE *file) -{ - char buf[1]; - - xfread(buf, 1, 1, file); - - if (xfeof(file)) { - return EOF; - } - - return buf[0]; -} - -int -xungetc(int c, xFILE *file) -{ - file->ungot = c; - if (c != EOF) { - file->flags &= ~XF_EOF; - } - return c; -} - -int -xgetchar(void) -{ - return xfgetc(xstdin); -} - -int -xfputc(int c, xFILE *file) -{ - char buf[1]; - - buf[0] = c; - xfwrite(buf, 1, 1, file); - - return buf[0]; -} - -int -xputchar(int c) -{ - return xfputc(c, xstdout); -} - -int -xfputs(const char *str, xFILE *file) -{ - int len; - - len = strlen(str); - xfwrite(str, len, 1, file); - - return 0; -} - -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; -} - -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 sizeof buf; - } -} - -/* - * Derieved xFILE Classes - */ - -static FILE * -unpack(void *cookie) -{ - switch ((long)cookie) { - default: return cookie; - case 0: return stdin; - case 1: return stdout; - case -1: return stderr; - } -} - -static int -file_read(void *cookie, char *ptr, int size) -{ - FILE *file = unpack(cookie); - int r; - - r = fread(ptr, 1, 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 = unpack(cookie); - int r; - - r = fwrite(ptr, 1, size, file); - if (r < size) { - return -1; - } - return r; -} - -static long -file_seek(void *cookie, long pos, int whence) -{ - return fseek(unpack(cookie), pos, whence); -} - -static int -file_flush(void *cookie) -{ - return fflush(unpack(cookie)); -} - -static int -file_close(void *cookie) -{ - return fclose(unpack(cookie)); -} - -xFILE * -xfpopen(FILE *fp) -{ - xFILE *file; - - file = xfunopen(fp, file_read, file_write, file_seek, file_flush, file_close); - if (! file) { - return NULL; - } - - return file; -} - -#define FILE_VTABLE file_read, file_write, file_seek, file_flush, file_close - -static xFILE xfile_stdin = { -1, 0, { (void *)0, FILE_VTABLE } }; -static xFILE xfile_stdout = { -1, 0, { (void *)1, FILE_VTABLE } }; -static xFILE xfile_stderr = { -1, 0, { (void *)-1, FILE_VTABLE } }; - -xFILE *xstdin = &xfile_stdin; -xFILE *xstdout = &xfile_stdout; -xFILE *xstderr = &xfile_stderr; - -struct membuf { - char *buf; - long pos, end, capa; -}; - -static int -mem_read(void *cookie, char *ptr, int size) -{ - struct membuf *mem; - - mem = (struct membuf *)cookie; - - size = min(size, mem->end - mem->pos); - memcpy(ptr, mem->buf + mem->pos, size); - mem->pos += size; - return size; -} - -static int -mem_write(void *cookie, const char *ptr, int size) -{ - struct membuf *mem; - - mem = (struct membuf *)cookie; - - if (mem->pos + size >= mem->capa) { - mem->capa = (mem->pos + size) * 2; - mem->buf = realloc(mem->buf, mem->capa); - } - memcpy(mem->buf + mem->pos, ptr, size); - mem->pos += size; - mem->end = max(mem->pos, mem->end); - return size; -} - -static long -mem_seek(void *cookie, long pos, int whence) -{ - struct membuf *mem; - - mem = (struct 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 int -mem_flush(void *cookie) -{ - (void)cookie; - - return 0; -} - -static int -mem_close(void *cookie) -{ - struct membuf *mem; - - mem = (struct membuf *)cookie; - free(mem->buf); - free(mem); - return 0; -} - -xFILE * -xmopen() -{ - struct membuf *mem; - - mem = (struct membuf *)malloc(sizeof(struct membuf)); - mem->buf = (char *)malloc(BUFSIZ); - mem->pos = 0; - mem->end = 0; - mem->capa = BUFSIZ; - - return xfunopen(mem, mem_read, mem_write, mem_seek, mem_flush, mem_close); -} From d0abe2d193b3d1bfb11a1bee6a915e664a9cb25a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 01:41:10 +0900 Subject: [PATCH 063/232] add pic->feature --- gc.c | 2 ++ include/picrin.h | 5 ++++- init.c | 9 +++++++++ state.c | 4 ++++ 4 files changed, 19 insertions(+), 1 deletion(-) diff --git a/gc.c b/gc.c index 9520e40a..f52d2fd7 100644 --- a/gc.c +++ b/gc.c @@ -618,6 +618,8 @@ gc_mark_phase(pic_state *pic) } } + gc_mark(pic, pic->features); + /* readers */ gc_mark_trie(pic, pic->reader->trie); diff --git a/include/picrin.h b/include/picrin.h index fff10cbb..ac03feb6 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -87,6 +87,8 @@ typedef struct { struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_USER; + pic_value features; + xhash syms; /* name to symbol */ xhash sym_names; /* symbol to name */ int sym_cnt; @@ -137,10 +139,11 @@ void pic_gc_arena_restore(pic_state *, size_t); pic_state *pic_open(int argc, char *argv[], char **envp); void pic_close(pic_state *); +void pic_add_feature(pic_state *, const char *); + void pic_define(pic_state *, const char *, pic_value); /* automatic export */ pic_value pic_ref(pic_state *, struct pic_lib *, const char *); void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); - pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); struct pic_proc *pic_get_proc(pic_state *); diff --git a/init.c b/init.c index a5e70d71..77e16524 100644 --- a/init.c +++ b/init.c @@ -8,6 +8,12 @@ #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 *); @@ -42,6 +48,9 @@ pic_init_core(pic_state *pic) { size_t ai = pic_gc_arena_preserve(pic); + pic_add_feature(pic, "picrin"); + pic_add_feature(pic, "ieee-float"); + 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); diff --git a/state.c b/state.c index 0b2b5123..07d85892 100644 --- a/state.c +++ b/state.c @@ -57,6 +57,9 @@ pic_open(int argc, char *argv[], char **envp) /* macros */ xh_init_int(&pic->macros, sizeof(struct pic_macro *)); + /* features */ + pic->features = pic_nil_value(); + /* libraries */ pic->libs = pic_nil_value(); pic->lib = NULL; @@ -184,6 +187,7 @@ pic_close(pic_state *pic) pic->arena_idx = 0; pic->err = NULL; xh_clear(&pic->macros); + pic->features = pic_nil_value(); pic->libs = pic_nil_value(); /* free all heap objects */ From 57fb1fc2fe2e084c9694ddedcfab65d2624014d9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 01:48:20 +0900 Subject: [PATCH 064/232] initial import of cond-expand from @KeenS's patch --- include/picrin.h | 2 + lib.c | 105 +++++++++++++++++++++++++++++++++++++++++++++++ macro.c | 1 + state.c | 2 + 4 files changed, 110 insertions(+) diff --git a/include/picrin.h b/include/picrin.h index ac03feb6..f752d2cf 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -76,6 +76,7 @@ typedef struct { pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; pic_sym sDEFINE_SYNTAX, sIMPORT, sEXPORT; pic_sym sDEFINE_LIBRARY, sIN_LIBRARY; + pic_sym sCOND_EXPAND; pic_sym sCONS, sCAR, sCDR, sNILP; pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; @@ -83,6 +84,7 @@ typedef struct { pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT; pic_sym rDEFINE_LIBRARY, rIN_LIBRARY; + pic_sym rCOND_EXPAND; struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_USER; diff --git a/lib.c b/lib.c index 898b0b6b..2b2459bb 100644 --- a/lib.c +++ b/lib.c @@ -9,6 +9,7 @@ #include "picrin/error.h" #include "picrin/dict.h" #include "picrin/string.h" +#include "picrin/proc.h" struct pic_lib * pic_open_library(pic_state *pic, pic_value name) @@ -200,6 +201,109 @@ pic_export(pic_state *pic, pic_sym sym) export(pic, pic_sym_value(sym)); } +bool pic_condexpand_clause(pic_state *, pic_value); + +bool +pic_condexpand_feature(pic_state *pic, pic_value name) +{ + pic_value feature; + + pic_for_each(feature, pic->features){ + if(pic_eq_p(feature, name)) + return true; + } + return false; +} + +bool +pic_condexpand_library(pic_state *pic, pic_value name) +{ + pic_debug(pic, name); + + if(pic_find_library(pic, name)) + return true; + else + return false; +} + +bool +pic_condexpand_and(pic_state *pic, pic_value clauses) +{ + pic_value clause; + + pic_for_each(clause, clauses){ + if(!pic_condexpand_clause(pic, clause)) + return false; + } + return true; +} + +bool +pic_condexpand_or(pic_state *pic, pic_value clauses) +{ + pic_value clause; + + pic_for_each(clause, clauses){ + if(pic_condexpand_clause(pic, clause)) + return true; + } + return false; +} + +bool +pic_condexpand_not(pic_state *pic, pic_value clause) +{ + return ! pic_condexpand_clause(pic, clause); +} + +bool +pic_condexpand_clause(pic_state *pic, pic_value clause) +{ + const pic_sym sELSE = pic_intern_cstr(pic, "else"); + const pic_sym sLIBRARY = pic_intern_cstr(pic, "library"); + const pic_sym sOR = pic_intern_cstr(pic, "or"); + const pic_sym sAND = pic_intern_cstr(pic, "and"); + const pic_sym sNOT = pic_intern_cstr(pic, "not"); + + if (pic_eq_p(clause, pic_sym_value(sELSE))) + return true; + else if (pic_sym_p(clause)) + return pic_condexpand_feature(pic, clause); + else if (!pic_pair_p(clause)) + pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause); + else { + pic_value car = pic_car(pic, clause); + pic_value cdr = pic_cdr(pic, clause); + if(pic_eq_p(car, pic_sym_value(sLIBRARY))) + return pic_condexpand_library(pic, pic_car(pic, cdr)); + else if(pic_eq_p(car, pic_sym_value(sAND))) + return pic_condexpand_and(pic, cdr); + else if(pic_eq_p(car, pic_sym_value(sOR))) + return pic_condexpand_or(pic, cdr); + else if(pic_eq_p(car, pic_sym_value(sNOT))) + return pic_condexpand_not(pic, pic_car(pic, cdr)); + else + pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause); + UNREACHABLE(); + return false; + } +} + +static pic_value +pic_lib_condexpand(pic_state *pic) +{ + pic_value *clauses; + size_t argc, i; + + pic_get_args(pic, "*", &argc, &clauses); + + for (i = 0; i < argc; i++) + if(pic_condexpand_clause(pic, pic_car(pic, clauses[i]))) + return pic_cons(pic, pic_sym_value(pic->rBEGIN), pic_cdr(pic, clauses[i])); + + return pic_none_value(); +} + static pic_value pic_lib_import(pic_state *pic) { @@ -275,6 +379,7 @@ pic_init_lib(pic_state *pic) { 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); diff --git a/macro.c b/macro.c index 22d9f331..993cf537 100644 --- a/macro.c +++ b/macro.c @@ -372,6 +372,7 @@ pic_null_syntactic_environment(pic_state *pic) 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); return senv; } diff --git a/state.c b/state.c index 07d85892..d0c05e4e 100644 --- a/state.c +++ b/state.c @@ -109,6 +109,7 @@ pic_open(int argc, char *argv[], char **envp) register_core_symbol(pic, sEXPORT, "export"); register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); register_core_symbol(pic, sIN_LIBRARY, "in-library"); + register_core_symbol(pic, sCOND_EXPAND, "cond-expand"); register_core_symbol(pic, sCONS, "cons"); register_core_symbol(pic, sCAR, "car"); register_core_symbol(pic, sCDR, "cdr"); @@ -142,6 +143,7 @@ pic_open(int argc, char *argv[], char **envp) register_renamed_symbol(pic, rEXPORT, "export"); register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); register_renamed_symbol(pic, rIN_LIBRARY, "in-library"); + register_renamed_symbol(pic, rCOND_EXPAND, "cond-expand"); pic_gc_arena_restore(pic, ai); /* root block */ From 90d6a3572c9e6eedb364661bfa838568b4a99cca Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 02:08:58 +0900 Subject: [PATCH 065/232] diet cond-expand --- lib.c | 122 +++++++++++++++++++++------------------------------------- 1 file changed, 44 insertions(+), 78 deletions(-) diff --git a/lib.c b/lib.c index 2b2459bb..f52626a4 100644 --- a/lib.c +++ b/lib.c @@ -201,92 +201,56 @@ pic_export(pic_state *pic, pic_sym sym) export(pic, pic_sym_value(sym)); } -bool pic_condexpand_clause(pic_state *, pic_value); - -bool -pic_condexpand_feature(pic_state *pic, pic_value name) -{ - pic_value feature; - - pic_for_each(feature, pic->features){ - if(pic_eq_p(feature, name)) - return true; - } - return false; -} - -bool -pic_condexpand_library(pic_state *pic, pic_value name) -{ - pic_debug(pic, name); - - if(pic_find_library(pic, name)) - return true; - else - return false; -} - -bool -pic_condexpand_and(pic_state *pic, pic_value clauses) -{ - pic_value clause; - - pic_for_each(clause, clauses){ - if(!pic_condexpand_clause(pic, clause)) - return false; - } - return true; -} - -bool -pic_condexpand_or(pic_state *pic, pic_value clauses) -{ - pic_value clause; - - pic_for_each(clause, clauses){ - if(pic_condexpand_clause(pic, clause)) - return true; - } - return false; -} - -bool -pic_condexpand_not(pic_state *pic, pic_value clause) -{ - return ! pic_condexpand_clause(pic, clause); -} - -bool -pic_condexpand_clause(pic_state *pic, pic_value clause) +static bool +condexpand(pic_state *pic, pic_value clause) { const pic_sym sELSE = pic_intern_cstr(pic, "else"); const pic_sym sLIBRARY = pic_intern_cstr(pic, "library"); const pic_sym sOR = pic_intern_cstr(pic, "or"); const pic_sym sAND = pic_intern_cstr(pic, "and"); const pic_sym sNOT = pic_intern_cstr(pic, "not"); + pic_sym tag; + pic_value c, feature; - if (pic_eq_p(clause, pic_sym_value(sELSE))) + if (pic_eq_p(clause, pic_sym_value(sELSE))) { return true; - else if (pic_sym_p(clause)) - return pic_condexpand_feature(pic, clause); - else if (!pic_pair_p(clause)) - pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause); - else { - pic_value car = pic_car(pic, clause); - pic_value cdr = pic_cdr(pic, clause); - if(pic_eq_p(car, pic_sym_value(sLIBRARY))) - return pic_condexpand_library(pic, pic_car(pic, cdr)); - else if(pic_eq_p(car, pic_sym_value(sAND))) - return pic_condexpand_and(pic, cdr); - else if(pic_eq_p(car, pic_sym_value(sOR))) - return pic_condexpand_or(pic, cdr); - else if(pic_eq_p(car, pic_sym_value(sNOT))) - return pic_condexpand_not(pic, pic_car(pic, cdr)); - else - pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause); - UNREACHABLE(); + } + if (pic_sym_p(clause)) { + pic_for_each (feature, pic->features) { + if(pic_eq_p(feature, clause)) + return true; + } return false; } + + 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)); + } + + if (tag == sLIBRARY) { + return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL; + } + if (tag == sNOT) { + return ! condexpand(pic, pic_list_ref(pic, clause, 1)); + } + if (tag == sAND) { + pic_for_each (c, pic_cdr(pic, clause)) { + if (! condexpand(pic, c)) + return false; + } + return true; + } + if (tag == sOR) { + pic_for_each (c, pic_cdr(pic, clause)) { + if (condexpand(pic, c)) + return true; + } + return false; + } + + pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause); } static pic_value @@ -297,9 +261,11 @@ pic_lib_condexpand(pic_state *pic) pic_get_args(pic, "*", &argc, &clauses); - for (i = 0; i < argc; i++) - if(pic_condexpand_clause(pic, pic_car(pic, clauses[i]))) + 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_none_value(); } From e6a2af0bf617e69abd2c434a32979ab13578bb7e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 02:51:48 +0900 Subject: [PATCH 066/232] remove vec_extend_ip. close #9 --- include/picrin/vector.h | 1 - vector.c | 13 ------------- 2 files changed, 14 deletions(-) diff --git a/include/picrin/vector.h b/include/picrin/vector.h index 80a4cb73..facac432 100644 --- a/include/picrin/vector.h +++ b/include/picrin/vector.h @@ -20,7 +20,6 @@ struct pic_vector { struct pic_vector *pic_vec_new(pic_state *, size_t); struct pic_vector *pic_vec_new_from_list(pic_state *, pic_value); -void pic_vec_extend_ip(pic_state *, struct pic_vector *, size_t); #if defined(__cplusplus) } diff --git a/vector.c b/vector.c index d57214e7..87dff916 100644 --- a/vector.c +++ b/vector.c @@ -37,19 +37,6 @@ pic_vec_new_from_list(pic_state *pic, pic_value data) return vec; } -void -pic_vec_extend_ip(pic_state *pic, struct pic_vector *vec, size_t size) -{ - size_t len, i; - - len = vec->len; - vec->len = size; - vec->data = (pic_value *)pic_realloc(pic, vec->data, sizeof(pic_value) * size); - for (i = len; i < size; ++i) { - vec->data[i] = pic_none_value(); - } -} - static pic_value pic_vec_vector_p(pic_state *pic) { From 654bc2c2d65092205bfbaeb8e949f476b9fab8e6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 13:27:38 +0900 Subject: [PATCH 067/232] add local variables list --- boot.c | 34 +++++++++++++++++++++------------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/boot.c b/boot.c index 00b1671e..07756ced 100644 --- a/boot.c +++ b/boot.c @@ -2,19 +2,6 @@ use strict; -open IN, "./boot.c"; -my @data = ; -close IN; - -open STDOUT, ">", "./boot.c"; - -foreach (@data) { - print; - last if $_ eq "#---END---\n"; -} - -print "\n#endif\n\n"; - my $src = <<'EOL'; (define-library (picrin base) @@ -360,6 +347,19 @@ my $src = <<'EOL'; EOL +open IN, "./boot.c"; +my @data = ; +close IN; + +open STDOUT, ">", "./boot.c"; + +foreach (@data) { + print; + last if $_ eq "#---END---\n"; +} + +print "\n#endif\n\n"; + print < Date: Wed, 10 Sep 2014 14:42:36 +0900 Subject: [PATCH 068/232] support macroexpansion of inter-referential definitions --- gc.c | 1 + include/picrin/macro.h | 1 + macro.c | 39 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 40 insertions(+), 1 deletion(-) diff --git a/gc.c b/gc.c index f52d2fd7..4150be8d 100644 --- a/gc.c +++ b/gc.c @@ -453,6 +453,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) if (senv->up) { gc_mark_object(pic, (struct pic_object *)senv->up); } + gc_mark(pic, senv->defer); break; } case PIC_TT_LIB: { diff --git a/include/picrin/macro.h b/include/picrin/macro.h index d655a735..6224a537 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -12,6 +12,7 @@ extern "C" { struct pic_senv { PIC_OBJECT_HEADER xhash map; + pic_value defer; struct pic_senv *up; }; diff --git a/macro.c b/macro.c index 993cf537..d34482d3 100644 --- a/macro.c +++ b/macro.c @@ -91,6 +91,7 @@ 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_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) @@ -123,6 +124,35 @@ macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv) return x; } +static pic_value +macroexpand_defer(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_value skel = pic_list1(pic, pic_none_value()); /* (#) */ + + pic_push(pic, pic_cons(pic, expr, skel), senv->defer); + + return skel; +} + +static void +macroexpand_deferred(pic_state *pic, struct pic_senv *senv) +{ + pic_value defer, val, src, dst; + + pic_for_each (defer, pic_reverse(pic, senv->defer)) { + src = pic_car(pic, defer); + dst = pic_cdr(pic, defer); + + val = macroexpand_lambda(pic, src, senv); + + /* copy */ + pic_pair_ptr(dst)->car = pic_car(pic, val); + pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); + } + + senv->defer = pic_nil_value(); +} + static pic_value macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) { @@ -154,6 +184,8 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) formal = macroexpand_list(pic, pic_cadr(pic, expr), in); body = macroexpand_list(pic, pic_cddr(pic, expr), in); + macroexpand_deferred(pic, in); + return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); } @@ -280,7 +312,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) return macroexpand_defsyntax(pic, expr, senv); } else if (tag == pic->rLAMBDA) { - return macroexpand_lambda(pic, expr, senv); + return macroexpand_defer(pic, expr, senv); } else if (tag == pic->rDEFINE) { return macroexpand_define(pic, expr, senv); @@ -326,6 +358,8 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) struct pic_lib *prev; pic_value v; + assert(pic_eq_p(lib->env->defer, pic_nil_value())); + #if DEBUG puts("before expand:"); pic_debug(pic, expr); @@ -338,6 +372,8 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) v = macroexpand(pic, expr, lib->env); + macroexpand_deferred(pic, lib->env); + pic->lib = prev; #if DEBUG @@ -356,6 +392,7 @@ pic_senv_new(pic_state *pic, struct pic_senv *up) 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)); return senv; From 248ca959259b7e156eee8b8ea4bf98a1b119b588 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 15:15:06 +0900 Subject: [PATCH 069/232] support inter-referential definitions [complete] --- codegen.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 46 insertions(+), 2 deletions(-) diff --git a/codegen.c b/codegen.c index 55d7a50c..f2c8527c 100644 --- a/codegen.c +++ b/codegen.c @@ -23,6 +23,7 @@ typedef struct analyze_scope { int depth; bool varg; xvect args, locals, captures; /* rest args variable is counted as a local */ + pic_value defer; struct analyze_scope *up; } analyze_scope; @@ -159,6 +160,7 @@ push_scope(analyze_state *state, pic_value formals) scope->args = args; scope->locals = locals; scope->captures = captures; + scope->defer = pic_nil_value(); state->scope = scope; @@ -258,6 +260,7 @@ define_var(analyze_state *state, pic_sym sym) } static pic_value analyze_node(analyze_state *, pic_value, bool); +static pic_value analyze_procedure(analyze_state *, pic_value, pic_value, pic_value); static pic_value analyze(analyze_state *state, pic_value obj, bool tailpos) @@ -281,6 +284,7 @@ analyze(analyze_state *state, pic_value obj, bool tailpos) pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, res); + pic_gc_protect(pic, state->scope->defer); return res; } @@ -327,6 +331,42 @@ analyze_var(analyze_state *state, pic_sym sym) } } +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_value skel; + + skel = pic_list2(pic, pic_sym_value(state->sGREF), pic_sym_value(sNOWHERE)); + + pic_push(pic, pic_list4(pic, name, formal, body, skel), state->scope->defer); + + return skel; +} + +static void +analyze_deferred(analyze_state *state) +{ + pic_state *pic = state->pic; + pic_value defer, val, name, formal, body, dst; + + pic_for_each (defer, pic_reverse(pic, state->scope->defer)) { + name = pic_list_ref(pic, defer, 0); + formal = pic_list_ref(pic, defer, 1); + body = pic_list_ref(pic, defer, 2); + dst = pic_list_ref(pic, defer, 3); + + val = analyze_procedure(state, name, formal, body); + + /* copy */ + pic_pair_ptr(dst)->car = pic_car(pic, val); + pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); + } + + state->scope->defer = pic_nil_value(); +} + static pic_value analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_value body_exprs) { @@ -353,6 +393,8 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v /* 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); + analyze_deferred(state); + locals = pic_nil_value(); for (i = scope->locals.size; i > 0; --i) { var = xv_get(&scope->locals, i - 1); @@ -387,7 +429,7 @@ analyze_lambda(analyze_state *state, pic_value obj) formals = pic_list_ref(pic, obj, 1); body_exprs = pic_list_tail(pic, obj, 2); - return analyze_procedure(state, pic_false_value(), formals, body_exprs); + return analyze_defer(state, pic_false_value(), formals, body_exprs); } static pic_value @@ -425,7 +467,7 @@ analyze_define(analyze_state *state, pic_value obj) 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_procedure(state, pic_sym_value(sym), formals, body_exprs); + val = analyze_defer(state, pic_sym_value(sym), formals, body_exprs); } else { if (pic_length(pic, obj) != 3) { pic_error(pic, "syntax error"); @@ -806,6 +848,8 @@ pic_analyze(pic_state *pic, pic_value obj) obj = analyze(state, obj, true); + analyze_deferred(state); + destroy_analyze_state(state); return obj; } From a193af3bef2412ee5e11d5f296b097ea6641b476 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 15:20:36 +0900 Subject: [PATCH 070/232] deal with exceptions inside macroexpansion --- macro.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/macro.c b/macro.c index d34482d3..ec627215 100644 --- a/macro.c +++ b/macro.c @@ -358,8 +358,6 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) struct pic_lib *prev; pic_value v; - assert(pic_eq_p(lib->env->defer, pic_nil_value())); - #if DEBUG puts("before expand:"); pic_debug(pic, expr); @@ -370,6 +368,8 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) prev = pic->lib; pic->lib = lib; + lib->env->defer = pic_nil_value(); /* the last expansion could fail and leave defer field old */ + v = macroexpand(pic, expr, lib->env); macroexpand_deferred(pic, lib->env); From ac638daa2b4987f199e06a41bc11f23864bd6b97 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 17:18:14 +0900 Subject: [PATCH 071/232] char comparators --- char.c | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/char.c b/char.c index 6ec81c92..0dca9f52 100644 --- a/char.c +++ b/char.c @@ -34,10 +34,49 @@ pic_char_integer_to_char(pic_state *pic) return pic_char_value(i); } +#define DEFINE_CHAR_CMP(op, name) \ + static pic_value \ + pic_char_##name##_p(pic_state *pic) \ + { \ + size_t argc; \ + pic_value *argv; \ + size_t i; \ + char c, d; \ + \ + pic_get_args(pic, "cc*", &c, &d, &argc, &argv); \ + \ + if (! (c op d)) \ + return pic_false_value(); \ + \ + for (i = 0; i < argc; ++i) { \ + c = d; \ + if (pic_char_p(argv[i])) \ + d = pic_char(argv[i]); \ + else \ + pic_error(pic, #op ": char required"); \ + \ + if (! (c op d)) \ + return pic_false_value(); \ + } \ + \ + return pic_true_value(); \ + } + +DEFINE_CHAR_CMP(==, eq) +DEFINE_CHAR_CMP(<, lt) +DEFINE_CHAR_CMP(>, gt) +DEFINE_CHAR_CMP(<=, le) +DEFINE_CHAR_CMP(>=, ge) + void pic_init_char(pic_state *pic) { pic_defun(pic, "char?", pic_char_char_p); pic_defun(pic, "char->integer", pic_char_char_to_integer); pic_defun(pic, "integer->char", pic_char_integer_to_char); + pic_defun(pic, "char=?", pic_char_eq_p); + pic_defun(pic, "char?", pic_char_gt_p); + pic_defun(pic, "char<=?", pic_char_le_p); + pic_defun(pic, "char>=?", pic_char_ge_p); } From e376f2614de8f6e72d8264db010a129c5d737d4a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 17:42:55 +0900 Subject: [PATCH 072/232] add call-with-port --- port.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/port.c b/port.c index 1b217873..ae7c66b2 100644 --- a/port.c +++ b/port.c @@ -113,6 +113,22 @@ pic_close_port(pic_state *pic, struct pic_port *port) port->status = PIC_PORT_CLOSE; } +static pic_value +pic_port_call_with_port(pic_state *pic) +{ + struct pic_port *port; + struct pic_proc *proc; + pic_value value; + + pic_get_args(pic, "pl", &port, &proc); + + value = pic_apply1(pic, proc, pic_obj_value(port)); + + pic_close_port(pic, port); + + return value; +} + static pic_value pic_port_input_port_p(pic_state *pic) { @@ -670,6 +686,8 @@ pic_init_port(pic_state *pic) pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(pic->xSTDOUT), NULL))); pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(pic->xSTDERR), NULL))); + pic_defun(pic, "call-with-port", pic_port_call_with_port); + pic_defun(pic, "input-port?", pic_port_input_port_p); pic_defun(pic, "output-port?", pic_port_output_port_p); pic_defun(pic, "textual-port?", pic_port_textual_port_p); From 8f93ddd87b1f2b705c204f51ba1365a6b7a7f547 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 18:36:53 +0900 Subject: [PATCH 073/232] add many many 'features' --- init.c | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 56 insertions(+), 4 deletions(-) diff --git a/init.c b/init.c index 77e16524..a086f3ec 100644 --- a/init.c +++ b/init.c @@ -39,17 +39,69 @@ void pic_init_record(pic_state *); void pic_init_eval(pic_state *); void pic_init_lib(pic_state *); -#define DONE pic_gc_arena_restore(pic, ai); - 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"); +#elif __gnu_linux__ + pic_add_feature(pic, "gnu-linux"); +#elif __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_add_feature(pic, "picrin"); - pic_add_feature(pic, "ieee-float"); + pic_init_features(pic); pic_deflibrary (pic, "(picrin base)") { pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); From c6b46ae2acba046f2c1c3f26e862134de0df846a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 20:09:32 +0900 Subject: [PATCH 074/232] string conversion functions --- string.c | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/string.c b/string.c index 67f9b401..cc225935 100644 --- a/string.c +++ b/string.c @@ -409,6 +409,50 @@ pic_str_string_fill_ip(pic_state *pic) return pic_none_value(); } +static pic_value +pic_str_list_to_string(pic_state *pic) +{ + pic_str *str; + pic_value list, e; + int i = 0; + + pic_get_args(pic, "o", &list); + + str = pic_str_new_fill(pic, pic_length(pic, list), ' '); + + pic_for_each (e, list) { + pic_assert_type(pic, e, char); + + pic_str_set(pic, str, i++, pic_char(e)); + } + + return pic_obj_value(str); +} + +static pic_value +pic_str_string_to_list(pic_state *pic) +{ + pic_str *str; + pic_value list; + int n, start, end, i; + + n = pic_get_args(pic, "s|ii", &str, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = pic_strlen(str); + } + + list = pic_nil_value(); + + for (i = start; i < end; ++i) { + pic_push(pic, pic_char_value(pic_str_ref(pic, str, i)), list); + } + return pic_reverse(pic, list); +} + void pic_init_str(pic_state *pic) { @@ -421,6 +465,8 @@ pic_init_str(pic_state *pic) pic_defun(pic, "string-copy!", pic_str_string_copy_ip); pic_defun(pic, "string-append", pic_str_string_append); pic_defun(pic, "string-fill!", pic_str_string_fill_ip); + pic_defun(pic, "list->string", pic_str_list_to_string); + pic_defun(pic, "string->list", pic_str_string_to_list); pic_defun(pic, "string=?", pic_str_string_eq); pic_defun(pic, "string Date: Fri, 12 Sep 2014 13:50:23 +0900 Subject: [PATCH 075/232] more efficient impelementation of nan boxing --- codegen.c | 23 ++++++---- include/picrin/value.h | 95 +++++++++++++++++++++++++++--------------- 2 files changed, 77 insertions(+), 41 deletions(-) diff --git a/codegen.c b/codegen.c index f2c8527c..1fa4167b 100644 --- a/codegen.c +++ b/codegen.c @@ -117,21 +117,24 @@ destroy_analyze_state(analyze_state *state) static bool analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) { - pic_value v, sym; + pic_value v, t; + pic_sym sym; for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { - sym = pic_car(pic, v); - if (! pic_sym_p(sym)) { + t = pic_car(pic, v); + if (! pic_sym_p(t)) { return false; } - xv_push(args, &pic_sym(sym)); + sym = pic_sym(t); + xv_push(args, &sym); } if (pic_nil_p(v)) { *varg = false; } else if (pic_sym_p(v)) { *varg = true; - xv_push(locals, &pic_sym(v)); + sym = pic_sym(v); + xv_push(locals, &sym); } else { return false; @@ -972,6 +975,7 @@ 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; assert(pic_sym_p(name) || pic_false_p(name)); @@ -987,13 +991,16 @@ push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_v xv_init(&cxt->captures, sizeof(pic_sym)); pic_for_each (var, args) { - xv_push(&cxt->args, &pic_sym(var)); + sym = pic_sym(var); + xv_push(&cxt->args, &sym); } pic_for_each (var, locals) { - xv_push(&cxt->locals, &pic_sym(var)); + sym = pic_sym(var); + xv_push(&cxt->locals, &sym); } pic_for_each (var, captures) { - xv_push(&cxt->captures, &pic_sym(var)); + sym = pic_sym(var); + xv_push(&cxt->captures, &sym); } cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); diff --git a/include/picrin/value.h b/include/picrin/value.h index 6137c2eb..b7490fda 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -44,32 +44,29 @@ enum pic_vtype { * char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC ................ */ -typedef struct { - union { - void *data; - double f; - struct { - union { - int i; - pic_sym sym; - char c; - }; - uint32_t type_; - }; - } u; -} pic_value; +typedef uint64_t pic_value; -#define pic_ptr(v) ((void *)((uint64_t)0xffffffffffff & (uint64_t)(v).u.data)) -#define pic_init_value(v,vtype) (((v).u.type_ = (((uint32_t)0xfff00000)|((uint32_t)((vtype)<<16)))), (v).u.i = 0) +#define pic_ptr(v) ((void *)(0xfffffffffffful & (v))) +#define pic_init_value(v,vtype) (v = (0xfff0000000000000ul | ((uint64_t)(vtype) << 48))) static inline enum pic_vtype pic_vtype(pic_value v) { - return 0xfff00000 >= v.u.type_ - ? PIC_VTYPE_FLOAT - : (v.u.type_ & 0xf0000)>>16; + return 0xfff0 >= (v >> 48) ? PIC_VTYPE_FLOAT : ((v >> 48) & 0xf); } +static inline double +pic_float(pic_value v) +{ + union { double f; uint64_t i; } u; + u.i = v; + return u.f; +} + +#define pic_int(v) ((v) & 0xfffffffful) +#define pic_sym(v) ((v) & 0xfffffffful) +#define pic_char(v) ((v) & 0xfffffffful) + #else typedef struct { @@ -87,6 +84,11 @@ 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) +#define pic_int(v) ((v).u.i) +#define pic_sym(v) ((v).u.sym) +#define pic_char(v) ((v).u.c) + #endif enum pic_tt { @@ -142,11 +144,6 @@ typedef struct pic_string pic_str; typedef struct pic_vector pic_vec; typedef struct pic_blob pic_blob; -#define pic_float(v) ((v).u.f) -#define pic_int(v) ((v).u.i) -#define pic_sym(v) ((v).u.sym) -#define pic_char(v) ((v).u.c) - #define pic_obj_p(v) (pic_vtype(v) == PIC_VTYPE_HEAP) #define pic_obj_ptr(v) ((struct pic_object *)pic_ptr(v)) @@ -328,21 +325,53 @@ pic_obj_value(void *ptr) pic_value v; pic_init_value(v, PIC_VTYPE_HEAP); - v.u.data = (void*)((long long)v.u.data | ((long long)ptr)); + v |= 0xfffffffffffful & (uint64_t)ptr; return v; } static inline pic_value pic_float_value(double f) { - pic_value v; + union { double f; uint64_t i; } u; if (f != f) { - v.u.type_ = 0x7ff80000; - v.u.i = 0; + return 0x7ff8000000000000ul; } else { - v.u.f = f; + u.f = f; + return u.i; } +} + +static inline pic_value +pic_int_value(int i) +{ + union { int i; unsigned u; } u; + pic_value v; + + u.i = i; + + pic_init_value(v, PIC_VTYPE_INT); + v |= u.u; + return v; +} + +static inline pic_value +pic_symbol_value(pic_sym sym) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_SYMBOL); + v |= sym; + return v; +} + +static inline pic_value +pic_char_value(char c) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_CHAR); + v |= c; return v; } @@ -368,8 +397,6 @@ pic_float_value(double f) return v; } -#endif - static inline pic_value pic_int_value(int i) { @@ -400,6 +427,8 @@ pic_char_value(char c) return v; } +#endif + static inline pic_value pic_undef_value() { @@ -424,13 +453,13 @@ pic_none_value() static inline bool pic_eq_p(pic_value x, pic_value y) { - return x.u.data == y.u.data; + return x == y; } static inline bool pic_eqv_p(pic_value x, pic_value y) { - return x.u.data == y.u.data; + return x == y; } #else From f9e603f32bee18a184dbb11850c67690ef068f3c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 17:36:28 +0900 Subject: [PATCH 076/232] unix and linux feature may coexist --- init.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/init.c b/init.c index a086f3ec..52ff2272 100644 --- a/init.c +++ b/init.c @@ -57,9 +57,11 @@ pic_init_features(pic_state *pic) #if __unix__ pic_add_feature(pic, "unix"); -#elif __gnu_linux__ +#endif +#if __gnu_linux__ pic_add_feature(pic, "gnu-linux"); -#elif __FreeBSD__ +#endif +#if __FreeBSD__ pic_add_feature(pic, "freebsd"); #endif From e58f216b2da6f4a14a35825f2878728872484e30 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 18:52:32 +0900 Subject: [PATCH 077/232] remove include --- boot.c | 40 ---------------------------------------- 1 file changed, 40 deletions(-) diff --git a/boot.c b/boot.c index 07756ced..6fa13d94 100644 --- a/boot.c +++ b/boot.c @@ -316,25 +316,6 @@ my $src = <<'EOL'; (lambda (form r c) `(,(r 'letrec-syntax) ,@(cdr form))))) - (define-syntax include - (letrec ((read-file - (lambda (filename) - (let ((port (open-input-file filename))) - (dynamic-wind - (lambda () #f) - (lambda () - (let loop ((expr (read port)) (exprs '())) - (if (eof-object? expr) - (reverse exprs) - (loop (read port) (cons expr exprs))))) - (lambda () - (close-port port))))))) - (er-macro-transformer - (lambda (form rename compare) - (let ((filenames (cdr form))) - (let ((exprs (apply append (map read-file filenames)))) - `(,(rename 'begin) ,@exprs))))))) - (export let let* letrec letrec* let-values let*-values define-values quasiquote unquote unquote-splicing @@ -342,7 +323,6 @@ my $src = <<'EOL'; cond case else => do when unless let-syntax letrec-syntax - include syntax-error)) EOL @@ -704,25 +684,6 @@ const char pic_boot[] = " (lambda (form r c)\n" " `(,(r 'letrec-syntax) ,@(cdr form)))))\n" "\n" -" (define-syntax include\n" -" (letrec ((read-file\n" -" (lambda (filename)\n" -" (let ((port (open-input-file filename)))\n" -" (dynamic-wind\n" -" (lambda () #f)\n" -" (lambda ()\n" -" (let loop ((expr (read port)) (exprs '()))\n" -" (if (eof-object? expr)\n" -" (reverse exprs)\n" -" (loop (read port) (cons expr exprs)))))\n" -" (lambda ()\n" -" (close-port port)))))))\n" -" (er-macro-transformer\n" -" (lambda (form rename compare)\n" -" (let ((filenames (cdr form)))\n" -" (let ((exprs (apply append (map read-file filenames))))\n" -" `(,(rename 'begin) ,@exprs)))))))\n" -"\n" " (export let let* letrec letrec*\n" " let-values let*-values define-values\n" " quasiquote unquote unquote-splicing\n" @@ -730,7 +691,6 @@ const char pic_boot[] = " cond case else =>\n" " do when unless\n" " let-syntax letrec-syntax\n" -" include\n" " syntax-error))\n" ; From d08e4014812b83fd54946c347d0851032d27be55 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:36:24 +0900 Subject: [PATCH 078/232] blob_new -> make_blob --- blob.c | 8 ++++---- include/picrin/blob.h | 2 +- port.c | 4 ++-- read.c | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/blob.c b/blob.c index 0bb28713..9e79bcd1 100644 --- a/blob.c +++ b/blob.c @@ -25,7 +25,7 @@ pic_strdup(pic_state *pic, const char *s) } struct pic_blob * -pic_blob_new(pic_state *pic, size_t len) +pic_make_blob(pic_state *pic, size_t len) { struct pic_blob *bv; @@ -56,7 +56,7 @@ pic_blob_make_bytevector(pic_state *pic) if (b < 0 || b > 255) pic_error(pic, "byte out of range"); - blob = pic_blob_new(pic, k); + blob = pic_make_blob(pic, k); for (i = 0; i < k; ++i) { blob->data[i] = b; } @@ -146,7 +146,7 @@ pic_blob_bytevector_copy(pic_state *pic) end = from->len; } - to = pic_blob_new(pic, end - start); + to = pic_make_blob(pic, end - start); while (start < end) { to->data[i++] = from->data[start++]; } @@ -169,7 +169,7 @@ pic_blob_bytevector_append(pic_state *pic) len += pic_blob_ptr(argv[i])->len; } - blob = pic_blob_new(pic, len); + blob = pic_make_blob(pic, len); len = 0; for (i = 0; i < argc; ++i) { diff --git a/include/picrin/blob.h b/include/picrin/blob.h index f61f588d..5837c04f 100644 --- a/include/picrin/blob.h +++ b/include/picrin/blob.h @@ -18,7 +18,7 @@ struct pic_blob { #define pic_blob_p(v) (pic_type(v) == PIC_TT_BLOB) #define pic_blob_ptr(v) ((struct pic_blob *)pic_ptr(v)) -struct pic_blob *pic_blob_new(pic_state *, size_t); +struct pic_blob *pic_make_blob(pic_state *, size_t); #if defined(__cplusplus) } diff --git a/port.c b/port.c index ae7c66b2..b6c666fe 100644 --- a/port.c +++ b/port.c @@ -360,7 +360,7 @@ pic_port_get_output_bytevector(pic_state *pic) xrewind(port->file); /* copy to buf */ - blob = pic_blob_new(pic, endpos); + blob = pic_make_blob(pic, endpos); xfread(blob->data, 1, endpos, port->file); return pic_obj_value(blob); @@ -528,7 +528,7 @@ pic_port_read_blob(pic_state *pic) assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector"); - blob = pic_blob_new(pic, k); + blob = pic_make_blob(pic, k); i = xfread(blob->data, sizeof(char), k, port->file); if ( i == 0 ) { diff --git a/read.c b/read.c index d52f1416..5f3bd383 100644 --- a/read.c +++ b/read.c @@ -534,7 +534,7 @@ read_blob(pic_state *pic, struct pic_port *port, const char *str) c = next(port); } - blob = pic_blob_new(pic, len); + blob = pic_make_blob(pic, len); for (i = 0; i < len; ++i) { blob->data[i] = dat[i]; } From a99fb41c63cab8f2b4c5624946e084d40c5d4b71 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:41:20 +0900 Subject: [PATCH 079/232] dict_new -> make_dict --- dict.c | 4 ++-- include/picrin/dict.h | 2 +- lib.c | 2 +- proc.c | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/dict.c b/dict.c index 8adfc3b5..5bd25ff0 100644 --- a/dict.c +++ b/dict.c @@ -7,7 +7,7 @@ #include "picrin/cont.h" struct pic_dict * -pic_dict_new(pic_state *pic) +pic_make_dict(pic_state *pic) { struct pic_dict *dict; @@ -70,7 +70,7 @@ pic_dict_dict(pic_state *pic) pic_get_args(pic, ""); - dict = pic_dict_new(pic); + dict = pic_make_dict(pic); return pic_obj_value(dict); } diff --git a/include/picrin/dict.h b/include/picrin/dict.h index 8bc58ad8..bf681cad 100644 --- a/include/picrin/dict.h +++ b/include/picrin/dict.h @@ -17,7 +17,7 @@ struct pic_dict { #define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT) #define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v)) -struct pic_dict *pic_dict_new(pic_state *); +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); diff --git a/lib.c b/lib.c index f52626a4..b752fcc7 100644 --- a/lib.c +++ b/lib.c @@ -78,7 +78,7 @@ import_table(pic_state *pic, pic_value spec) pic_sym sym; xh_iter it; - imports = pic_dict_new(pic); + imports = pic_make_dict(pic); if (pic_list_p(spec)) { if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sONLY))) { diff --git a/proc.c b/proc.c index c06dce80..c604c87e 100644 --- a/proc.c +++ b/proc.c @@ -53,7 +53,7 @@ struct pic_dict * pic_attr(pic_state *pic, struct pic_proc *proc) { if (proc->attr == NULL) { - proc->attr = pic_dict_new(pic); + proc->attr = pic_make_dict(pic); } return proc->attr; } From b5e429e3e25a42eeccaf4f27a83895e9320800e0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:42:09 +0900 Subject: [PATCH 080/232] error_new -> make_error --- error.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/error.c b/error.c index 71d24c71..1dbff265 100644 --- a/error.c +++ b/error.c @@ -72,7 +72,7 @@ pic_pop_try(pic_state *pic) } static struct pic_error * -error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs) +make_error(pic_state *pic, short type, pic_str *msg, pic_value irrs) { struct pic_error *e; pic_str *stack; @@ -109,7 +109,7 @@ pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs) { struct pic_error *e; - e = error_new(pic, type, pic_str_new_cstr(pic, msg), irrs); + e = make_error(pic, type, pic_str_new_cstr(pic, msg), irrs); pic_throw_error(pic, e); } From d05a2a2da1f244b0819431a4fad6523e3ee6d7d2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:43:50 +0900 Subject: [PATCH 081/232] senv_new -> make_senv --- include/picrin/macro.h | 2 +- macro.c | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 6224a537..e4f03b42 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -33,7 +33,7 @@ struct pic_senv *pic_null_syntactic_environment(pic_state *); 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); -struct pic_senv *pic_senv_new(pic_state *, struct pic_senv *); +struct pic_senv *pic_make_senv(pic_state *, struct pic_senv *); 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 */); diff --git a/macro.c b/macro.c index ec627215..7db0775e 100644 --- a/macro.c +++ b/macro.c @@ -164,7 +164,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_error(pic, "syntax error"); } - in = pic_senv_new(pic, senv); + in = pic_make_senv(pic, senv); for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { pic_value v = pic_car(pic, a); @@ -386,7 +386,7 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) } struct pic_senv * -pic_senv_new(pic_state *pic, struct pic_senv *up) +pic_make_senv(pic_state *pic, struct pic_senv *up) { struct pic_senv *senv; @@ -403,7 +403,7 @@ pic_null_syntactic_environment(pic_state *pic) { struct pic_senv *senv; - senv = pic_senv_new(pic, NULL); + senv = pic_make_senv(pic, NULL); pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT); From 1422840a84b9e300c21d210d1cdb75e92df20c41 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:46:54 +0900 Subject: [PATCH 082/232] proc_new -> make_proc --- codegen.c | 2 +- cont.c | 4 ++-- include/picrin/proc.h | 4 ++-- macro.c | 2 +- proc.c | 4 ++-- read.c | 2 +- vm.c | 4 ++-- 7 files changed, 11 insertions(+), 11 deletions(-) diff --git a/codegen.c b/codegen.c index 1fa4167b..b593a5d1 100644 --- a/codegen.c +++ b/codegen.c @@ -1501,5 +1501,5 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, pic_obj_value(irep)); - return pic_proc_new_irep(pic, irep, NULL); + return pic_make_proc_irep(pic, irep, NULL); } diff --git a/cont.c b/cont.c index 6839c586..695e39b0 100644 --- a/cont.c +++ b/cont.c @@ -283,7 +283,7 @@ pic_callcc(pic_state *pic, struct pic_proc *proc) else { struct pic_proc *c; - c = pic_proc_new(pic, cont_call, ""); + c = pic_make_proc(pic, cont_call, ""); /* save the continuation object in proc */ pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); @@ -304,7 +304,7 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc) else { struct pic_proc *c; - c = pic_proc_new(pic, cont_call, ""); + c = pic_make_proc(pic, cont_call, ""); /* save the continuation object in proc */ pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); diff --git a/include/picrin/proc.h b/include/picrin/proc.h index b91960de..b443d3d9 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -46,8 +46,8 @@ struct pic_proc { #define pic_env_p(o) (pic_type(o) == PIC_TT_ENV) #define pic_env_ptr(o) ((struct pic_env *)pic_ptr(o)) -struct pic_proc *pic_proc_new(pic_state *, pic_func_t, const char *); -struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_env *); +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 *); pic_sym pic_proc_name(struct pic_proc *); diff --git a/macro.c b/macro.c index 7db0775e..17f12cc6 100644 --- a/macro.c +++ b/macro.c @@ -430,7 +430,7 @@ pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func) pic_put_rename(pic, pic->lib->env, name, id); /* symbol registration */ - define_macro(pic, id, pic_proc_new(pic, func, pic_symbol_name(pic, name)), NULL); + define_macro(pic, id, pic_make_proc(pic, func, pic_symbol_name(pic, name)), NULL); /* auto export! */ pic_export(pic, name); diff --git a/proc.c b/proc.c index c604c87e..a518214f 100644 --- a/proc.c +++ b/proc.c @@ -9,7 +9,7 @@ #include "picrin/dict.h" struct pic_proc * -pic_proc_new(pic_state *pic, pic_func_t func, const char *name) +pic_make_proc(pic_state *pic, pic_func_t func, const char *name) { struct pic_proc *proc; @@ -25,7 +25,7 @@ pic_proc_new(pic_state *pic, pic_func_t func, const char *name) } struct pic_proc * -pic_proc_new_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_env *env) { struct pic_proc *proc; diff --git a/read.c b/read.c index 5f3bd383..48ca7498 100644 --- a/read.c +++ b/read.c @@ -788,7 +788,7 @@ pic_define_reader(pic_state *pic, const char *str, pic_func_t reader) } trie = trie->table[c]; } - trie->proc = pic_proc_new(pic, reader, "reader"); + trie->proc = pic_make_proc(pic, reader, "reader"); } #define DEFINE_READER(name) \ diff --git a/vm.c b/vm.c index 044c5eb2..b13f3fb6 100644 --- a/vm.c +++ b/vm.c @@ -456,7 +456,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) { struct pic_proc *proc; - proc = pic_proc_new(pic, cfunc, name); + proc = pic_make_proc(pic, cfunc, name); pic_define(pic, name, pic_obj_value(proc)); } @@ -906,7 +906,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) vm_push_env(pic); } - proc = pic_proc_new_irep(pic, irep->irep[c.u.i], pic->ci->env); + proc = pic_make_proc_irep(pic, irep->irep[c.u.i], pic->ci->env); PUSH(pic_obj_value(proc)); pic_gc_arena_restore(pic, ai); NEXT; From 46dec7bc7ef64c60dfc435a1614f59e46f6de9a1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:49:00 +0900 Subject: [PATCH 083/232] trie_new -> make_trie --- include/picrin/read.h | 2 +- read.c | 4 ++-- state.c | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/include/picrin/read.h b/include/picrin/read.h index 8b977d58..c77398e3 100644 --- a/include/picrin/read.h +++ b/include/picrin/read.h @@ -29,7 +29,7 @@ void pic_init_reader(pic_state *); void pic_define_reader(pic_state *, const char *, pic_func_t); -struct pic_trie *pic_trie_new(pic_state *); +struct pic_trie *pic_make_trie(pic_state *); void pic_trie_delete(pic_state *, struct pic_trie *); #if defined(__cplusplus) diff --git a/read.c b/read.c index 48ca7498..1d9a4a74 100644 --- a/read.c +++ b/read.c @@ -751,7 +751,7 @@ read(pic_state *pic, struct pic_port *port, int c) } struct pic_trie * -pic_trie_new(pic_state *pic) +pic_make_trie(pic_state *pic) { struct pic_trie *trie; @@ -784,7 +784,7 @@ pic_define_reader(pic_state *pic, const char *str, pic_func_t reader) while ((c = *str++)) { if (trie->table[c] == NULL) { - trie->table[c] = pic_trie_new(pic); + trie->table[c] = pic_make_trie(pic); } trie = trie->table[c]; } diff --git a/state.c b/state.c index d0c05e4e..d98ee2f2 100644 --- a/state.c +++ b/state.c @@ -67,7 +67,7 @@ pic_open(int argc, char *argv[], char **envp) /* reader */ pic->reader = malloc(sizeof(struct pic_reader)); pic->reader->typecase = PIC_CASE_DEFAULT; - pic->reader->trie = pic_trie_new(pic); + pic->reader->trie = pic_make_trie(pic); xh_init_int(&pic->reader->labels, sizeof(pic_value)); /* error handling */ From 1d03b0786240ffa0d29e1e3accfff59b84efa4e9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:49:58 +0900 Subject: [PATCH 084/232] record_new -> make_record --- include/picrin/record.h | 2 +- record.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/include/picrin/record.h b/include/picrin/record.h index bf8698f1..d2944c06 100644 --- a/include/picrin/record.h +++ b/include/picrin/record.h @@ -17,7 +17,7 @@ struct pic_record { #define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD) #define pic_record_ptr(v) ((struct pic_record *)pic_ptr(v)) -struct pic_record *pic_record_new(pic_state *, pic_value); +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); diff --git a/record.c b/record.c index 2137e4f1..52fbe050 100644 --- a/record.c +++ b/record.c @@ -6,7 +6,7 @@ #include "picrin/record.h" struct pic_record * -pic_record_new(pic_state *pic, pic_value rectype) +pic_make_record(pic_state *pic, pic_value rectype) { struct pic_record *rec; @@ -52,7 +52,7 @@ pic_record_make_record(pic_state *pic) pic_get_args(pic, "o", &rectype); - rec = pic_record_new(pic, rectype); + rec = pic_make_record(pic, rectype); return pic_obj_value(rec); } From df4bc3838b40264698ea6799d3e59777d5aafc13 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:52:49 +0900 Subject: [PATCH 085/232] str_new -> make_str --- debug.c | 22 +++++++++++----------- error.c | 2 +- include/picrin/string.h | 6 +++--- number.c | 4 ++-- port.c | 2 +- read.c | 4 ++-- string.c | 26 +++++++++++++------------- symbol.c | 2 +- system.c | 8 ++++---- 9 files changed, 38 insertions(+), 38 deletions(-) diff --git a/debug.c b/debug.c index f59a4125..09c70553 100644 --- a/debug.c +++ b/debug.c @@ -14,18 +14,18 @@ pic_get_backtrace(pic_state *pic) pic_callinfo *ci; pic_str *trace; - trace = pic_str_new(pic, NULL, 0); + trace = pic_make_str(pic, NULL, 0); for (ci = pic->ci; ci != pic->cibase; --ci) { struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " at ")); - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc)))); + 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)))); if (pic_proc_func_p(proc)) { - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (native function)\n")); + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " (native function)\n")); } else if (pic_proc_irep_p(proc)) { - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (unknown location)\n")); /* TODO */ + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */ } } @@ -43,20 +43,20 @@ pic_print_backtrace(pic_state *pic, struct pic_error *e) assert(pic->err != NULL); - trace = pic_str_new(pic, NULL, 0); + trace = pic_make_str(pic, NULL, 0); switch (e->type) { case PIC_ERROR_OTHER: - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "error: ")); + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "error: ")); break; case PIC_ERROR_FILE: - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "file error: ")); + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "file error: ")); break; case PIC_ERROR_READ: - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "read error: ")); + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "read error: ")); break; case PIC_ERROR_RAISED: - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "raised: ")); + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "raised: ")); break; } @@ -64,7 +64,7 @@ pic_print_backtrace(pic_state *pic, struct pic_error *e) /* TODO: print error irritants */ - trace = pic_strcat(pic, trace, pic_str_new(pic, "\n", 1)); + trace = pic_strcat(pic, trace, pic_make_str(pic, "\n", 1)); trace = pic_strcat(pic, trace, e->stack); /* print! */ diff --git a/error.c b/error.c index 1dbff265..d5596a7b 100644 --- a/error.c +++ b/error.c @@ -109,7 +109,7 @@ pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs) { struct pic_error *e; - e = make_error(pic, type, pic_str_new_cstr(pic, msg), irrs); + e = make_error(pic, type, pic_make_str_cstr(pic, msg), irrs); pic_throw_error(pic, e); } diff --git a/include/picrin/string.h b/include/picrin/string.h index 3df116cf..5a224d3d 100644 --- a/include/picrin/string.h +++ b/include/picrin/string.h @@ -17,9 +17,9 @@ struct pic_string { #define pic_str_p(v) (pic_type(v) == PIC_TT_STRING) #define pic_str_ptr(o) ((struct pic_string *)pic_ptr(o)) -pic_str *pic_str_new(pic_state *, const char * /* nullable */, size_t); -pic_str *pic_str_new_cstr(pic_state *, const char *); -pic_str *pic_str_new_fill(pic_state *, size_t, char); +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); diff --git a/number.c b/number.c index 60ae5892..10dc03aa 100644 --- a/number.c +++ b/number.c @@ -539,14 +539,14 @@ pic_number_number_to_string(pic_state *pic) number_string(ival, radix, ilen, buf); - return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1)); + return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); } else { char buf[snprintf(NULL, 0, "%a", f) + 1]; snprintf(buf, sizeof buf, "%a", f); - return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1)); + return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); } } diff --git a/port.c b/port.c index b6c666fe..84cbfaff 100644 --- a/port.c +++ b/port.c @@ -101,7 +101,7 @@ pic_get_output_string(pic_state *pic, struct pic_port *port) buf[size] = 0; xfread(buf, size, 1, port->file); - return pic_str_new(pic, buf, size); + return pic_make_str(pic, buf, size); } void diff --git a/read.c b/read.c index 1d9a4a74..8becb1f9 100644 --- a/read.c +++ b/read.c @@ -443,7 +443,7 @@ read_string(pic_state *pic, struct pic_port *port, const char *name) } buf[cnt] = '\0'; - str = pic_str_new(pic, buf, cnt); + str = pic_make_str(pic, buf, cnt); pic_free(pic, buf); return pic_obj_value(str); } @@ -730,7 +730,7 @@ read_nullable(pic_state *pic, struct pic_port *port, int c) if (trie->proc == NULL) { read_error(pic, "no reader registered for current string"); } - str = pic_str_new(pic, buf, i); + str = pic_make_str(pic, buf, i); return pic_apply2(pic, trie->proc, pic_obj_value(port), pic_obj_value(str)); } diff --git a/string.c b/string.c index cc225935..4f1afe23 100644 --- a/string.c +++ b/string.c @@ -10,7 +10,7 @@ #include "picrin/port.h" static pic_str * -str_new_rope(pic_state *pic, xrope *rope) +make_str_rope(pic_state *pic, xrope *rope) { pic_str *str; @@ -20,22 +20,22 @@ str_new_rope(pic_state *pic, xrope *rope) } pic_str * -pic_str_new(pic_state *pic, const char *imbed, size_t len) +pic_make_str(pic_state *pic, const char *imbed, size_t len) { if (imbed == NULL && len > 0) { pic_errorf(pic, "zero length specified against NULL ptr"); } - return str_new_rope(pic, xr_new_copy(imbed, len)); + return make_str_rope(pic, xr_new_copy(imbed, len)); } pic_str * -pic_str_new_cstr(pic_state *pic, const char *cstr) +pic_make_str_cstr(pic_state *pic, const char *cstr) { - return pic_str_new(pic, cstr, strlen(cstr)); + return pic_make_str(pic, cstr, strlen(cstr)); } pic_str * -pic_str_new_fill(pic_state *pic, size_t len, char fill) +pic_make_str_fill(pic_state *pic, size_t len, char fill) { size_t i; char buf[len + 1]; @@ -45,7 +45,7 @@ pic_str_new_fill(pic_state *pic, size_t len, char fill) } buf[i] = '\0'; - return pic_str_new(pic, buf, len); + return pic_make_str(pic, buf, len); } size_t @@ -76,7 +76,7 @@ pic_str_set(pic_state *pic, pic_str *str, size_t i, char c) } x = pic_substr(pic, str, 0, i); - y = pic_str_new_fill(pic, 1, c); + y = pic_make_str_fill(pic, 1, c); z = pic_substr(pic, str, i + 1, pic_strlen(str)); tmp = pic_strcat(pic, x, pic_strcat(pic, y, z)); @@ -89,13 +89,13 @@ pic_str_set(pic_state *pic, pic_str *str, size_t i, char c) pic_str * pic_strcat(pic_state *pic, pic_str *a, pic_str *b) { - return str_new_rope(pic, xr_cat(a->rope, b->rope)); + return make_str_rope(pic, xr_cat(a->rope, b->rope)); } pic_str * pic_substr(pic_state *pic, pic_str *str, size_t s, size_t e) { - return str_new_rope(pic, xr_sub(str->rope, s, e)); + return make_str_rope(pic, xr_sub(str->rope, s, e)); } int @@ -258,7 +258,7 @@ pic_str_make_string(pic_state *pic) pic_get_args(pic, "i|c", &len, &c); - return pic_obj_value(pic_str_new_fill(pic, len, c)); + return pic_obj_value(pic_make_str_fill(pic, len, c)); } static pic_value @@ -377,7 +377,7 @@ pic_str_string_append(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - str = pic_str_new(pic, NULL, 0); + str = pic_make_str(pic, NULL, 0); for (i = 0; i < argc; ++i) { if (! pic_str_p(argv[i])) { pic_error(pic, "type error"); @@ -418,7 +418,7 @@ pic_str_list_to_string(pic_state *pic) pic_get_args(pic, "o", &list); - str = pic_str_new_fill(pic, pic_length(pic, list), ' '); + str = pic_make_str_fill(pic, pic_length(pic, list), ' '); pic_for_each (e, list) { pic_assert_type(pic, e, char); diff --git a/symbol.c b/symbol.c index 9a1d7d8d..7c6479b4 100644 --- a/symbol.c +++ b/symbol.c @@ -135,7 +135,7 @@ pic_symbol_symbol_to_string(pic_state *pic) pic_error(pic, "symbol->string: expected symbol"); } - return pic_obj_value(pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(v)))); + return pic_obj_value(pic_make_str_cstr(pic, pic_symbol_name(pic, pic_sym(v)))); } static pic_value diff --git a/system.c b/system.c index e9096a2b..4c54b905 100644 --- a/system.c +++ b/system.c @@ -20,7 +20,7 @@ pic_system_cmdline(pic_state *pic) for (i = 0; i < pic->argc; ++i) { size_t ai = pic_gc_arena_preserve(pic); - v = pic_cons(pic, pic_obj_value(pic_str_new_cstr(pic, pic->argv[i])), v); + v = pic_cons(pic, pic_obj_value(pic_make_str_cstr(pic, pic->argv[i])), v); pic_gc_arena_restore(pic, ai); } @@ -87,7 +87,7 @@ pic_system_getenv(pic_state *pic) if (val == NULL) return pic_nil_value(); else - return pic_obj_value(pic_str_new_cstr(pic, val)); + return pic_obj_value(pic_make_str_cstr(pic, val)); } static pic_value @@ -110,8 +110,8 @@ pic_system_getenvs(pic_state *pic) for (i = 0; (*envp)[i] != '='; ++i) ; - key = pic_str_new(pic, *envp, i); - val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key))); + key = pic_make_str(pic, *envp, i); + val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key))); /* push */ data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); From 642bd10fb3f86a717b380a52d29e23321cd9c260 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:54:21 +0900 Subject: [PATCH 086/232] var_new -> make_var --- include/picrin/var.h | 2 +- port.c | 6 +++--- var.c | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/include/picrin/var.h b/include/picrin/var.h index d3bbaf4e..556647a8 100644 --- a/include/picrin/var.h +++ b/include/picrin/var.h @@ -18,7 +18,7 @@ struct pic_var { #define pic_var_p(o) (pic_type(o) == PIC_TT_VAR) #define pic_var_ptr(o) ((struct pic_var *)pic_ptr(o)) -struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc * /* = NULL */); +struct pic_var *pic_make_var(pic_state *, pic_value, struct pic_proc * /* = NULL */); pic_value pic_var_ref(pic_state *, struct pic_var *); void pic_var_set(pic_state *, struct pic_var *, pic_value); diff --git a/port.c b/port.c index 84cbfaff..94641c06 100644 --- a/port.c +++ b/port.c @@ -682,9 +682,9 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { - pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(pic->xSTDIN), NULL))); - pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(pic->xSTDOUT), NULL))); - pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(pic->xSTDERR), NULL))); + pic_define(pic, "current-input-port", pic_obj_value(pic_make_var(pic, pic_obj_value(pic->xSTDIN), NULL))); + pic_define(pic, "current-output-port", pic_obj_value(pic_make_var(pic, pic_obj_value(pic->xSTDOUT), NULL))); + pic_define(pic, "current-error-port", pic_obj_value(pic_make_var(pic, pic_obj_value(pic->xSTDERR), NULL))); pic_defun(pic, "call-with-port", pic_port_call_with_port); diff --git a/var.c b/var.c index 71f605e8..a91245ef 100644 --- a/var.c +++ b/var.c @@ -7,7 +7,7 @@ #include "picrin/pair.h" struct pic_var * -pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv) +pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) { struct pic_var *var; @@ -58,7 +58,7 @@ pic_var_make_parameter(pic_state *pic) pic_get_args(pic, "o|l", &init, &conv); - return pic_obj_value(pic_var_new(pic, init, conv)); + return pic_obj_value(pic_make_var(pic, init, conv)); } static pic_value From 49f09b19bca8418a72db5e48eced6774da00275b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 19:55:32 +0900 Subject: [PATCH 087/232] vec_new -> make_vec --- include/picrin/vector.h | 4 ++-- read.c | 4 ++-- vector.c | 14 +++++++------- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/include/picrin/vector.h b/include/picrin/vector.h index facac432..d4e54da9 100644 --- a/include/picrin/vector.h +++ b/include/picrin/vector.h @@ -18,8 +18,8 @@ struct pic_vector { #define pic_vec_p(v) (pic_type(v) == PIC_TT_VECTOR) #define pic_vec_ptr(o) ((struct pic_vector *)pic_ptr(o)) -struct pic_vector *pic_vec_new(pic_state *, size_t); -struct pic_vector *pic_vec_new_from_list(pic_state *, pic_value); +struct pic_vector *pic_make_vec(pic_state *, size_t); +struct pic_vector *pic_make_vec_from_list(pic_state *, pic_value); #if defined(__cplusplus) } diff --git a/read.c b/read.c index 8becb1f9..ad23436f 100644 --- a/read.c +++ b/read.c @@ -588,7 +588,7 @@ read_vector(pic_state *pic, struct pic_port *port, const char *str) list = read(pic, port, str[1]); - return pic_obj_value(pic_vec_new_from_list(pic, list)); + return pic_obj_value(pic_make_vec_from_list(pic, list)); } static pic_value @@ -625,7 +625,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) if (vect) { pic_vec *tmp; - val = pic_obj_value(pic_vec_new(pic, 0)); + val = pic_obj_value(pic_make_vec(pic, 0)); xh_put_int(&pic->reader->labels, i, &val); diff --git a/vector.c b/vector.c index 87dff916..d931cbe9 100644 --- a/vector.c +++ b/vector.c @@ -7,7 +7,7 @@ #include "picrin/pair.h" struct pic_vector * -pic_vec_new(pic_state *pic, size_t len) +pic_make_vec(pic_state *pic, size_t len) { struct pic_vector *vec; size_t i; @@ -22,14 +22,14 @@ pic_vec_new(pic_state *pic, size_t len) } struct pic_vector * -pic_vec_new_from_list(pic_state *pic, pic_value data) +pic_make_vec_from_list(pic_state *pic, pic_value data) { struct pic_vector *vec; size_t i, len; len = pic_length(pic, data); - vec = pic_vec_new(pic, len); + vec = pic_make_vec(pic, len); for (i = 0; i < len; ++i) { vec->data[i] = pic_car(pic, data); data = pic_cdr(pic, data); @@ -57,7 +57,7 @@ pic_vec_make_vector(pic_state *pic) n = pic_get_args(pic, "i|o", &k, &v); - vec = pic_vec_new(pic, k); + vec = pic_make_vec(pic, k); if (n == 2) { for (i = 0; i < (size_t)k; ++i) { vec->data[i] = v; @@ -152,7 +152,7 @@ pic_vec_vector_copy(pic_state *pic) end = vec->len; } - to = pic_vec_new(pic, end - start); + to = pic_make_vec(pic, end - start); while (start < end) { to->data[i++] = vec->data[start++]; } @@ -175,7 +175,7 @@ pic_vec_vector_append(pic_state *pic) len += pic_vec_ptr(argv[i])->len; } - vec = pic_vec_new(pic, len); + vec = pic_make_vec(pic, len); len = 0; for (i = 0; i < argc; ++i) { @@ -219,7 +219,7 @@ pic_vec_list_to_vector(pic_state *pic) pic_get_args(pic, "o", &list); - vec = pic_vec_new(pic, pic_length(pic, list)); + vec = pic_make_vec(pic, pic_length(pic, list)); data = vec->data; From da07f0824872f553dc25cfb32643d363d602d3a8 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 20:23:58 +0900 Subject: [PATCH 088/232] add string procedure --- string.c | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/string.c b/string.c index 4f1afe23..fc2d2ab6 100644 --- a/string.c +++ b/string.c @@ -250,6 +250,30 @@ pic_str_string_p(pic_state *pic) return pic_bool_value(pic_str_p(v)); } +static pic_value +pic_str_string(pic_state *pic) +{ + size_t argc; + pic_value *argv; + pic_str *str; + char *buf; + size_t i; + + pic_get_args(pic, "*", &argc, &argv); + + buf = pic_alloc(pic, argc); + + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], char); + buf[i] = pic_char(argv[i]); + } + + str = pic_make_str(pic, buf, argc); + pic_free(pic, buf); + + return pic_obj_value(str); +} + static pic_value pic_str_make_string(pic_state *pic) { @@ -457,6 +481,7 @@ void pic_init_str(pic_state *pic) { pic_defun(pic, "string?", pic_str_string_p); + pic_defun(pic, "string", pic_str_string); pic_defun(pic, "make-string", pic_str_make_string); pic_defun(pic, "string-length", pic_str_string_length); pic_defun(pic, "string-ref", pic_str_string_ref); From 2ad517be84d553136b356e0c40d9167a7d0e5adb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 20:51:36 +0900 Subject: [PATCH 089/232] add vector<->string --- vector.c | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) diff --git a/vector.c b/vector.c index d931cbe9..b9c16aa3 100644 --- a/vector.c +++ b/vector.c @@ -4,6 +4,7 @@ #include "picrin.h" #include "picrin/vector.h" +#include "picrin/string.h" #include "picrin/pair.h" struct pic_vector * @@ -253,6 +254,61 @@ pic_vec_vector_to_list(pic_state *pic) return pic_reverse(pic, list); } +static pic_value +pic_vec_vector_to_string(pic_state *pic) +{ + pic_vec *vec; + char *buf; + int n, start, end, i; + pic_str *str; + + n = pic_get_args(pic, "v|ii", &vec, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = vec->len; + } + + buf = pic_alloc(pic, end - start); + + for (i = start; i < end; ++i) { + pic_assert_type(pic, vec->data[i], char); + + buf[i - start] = pic_char(vec->data[i]); + } + + str = pic_make_str(pic, buf, end - start); + pic_free(pic, buf); + + return pic_obj_value(str); +} + +static pic_value +pic_vec_string_to_vector(pic_state *pic) +{ + pic_str *str; + int n, start, end, i; + pic_vec *vec; + + n = pic_get_args(pic, "s|ii", &str, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = pic_strlen(str); + } + + vec = pic_make_vec(pic, end - start); + + for (i = start; i < end; ++i) { + vec->data[i - start] = pic_char_value(pic_str_ref(pic, str, i)); + } + return pic_obj_value(vec); +} + void pic_init_vector(pic_state *pic) { @@ -267,4 +323,6 @@ pic_init_vector(pic_state *pic) pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i); pic_defun(pic, "list->vector", pic_vec_list_to_vector); pic_defun(pic, "vector->list", pic_vec_vector_to_list); + pic_defun(pic, "string->vector", pic_vec_string_to_vector); + pic_defun(pic, "vector->string", pic_vec_vector_to_string); } From 45d894d9f83d1292deb9037b05c92cbe983e3b7f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 20:55:34 +0900 Subject: [PATCH 090/232] add vector procedure --- vector.c | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/vector.c b/vector.c index b9c16aa3..4a3e8194 100644 --- a/vector.c +++ b/vector.c @@ -48,6 +48,25 @@ pic_vec_vector_p(pic_state *pic) return pic_bool_value(pic_vec_p(v)); } +static pic_value +pic_vec_vector(pic_state *pic) +{ + size_t argc; + pic_value *argv; + pic_vec *vec; + size_t i; + + pic_get_args(pic, "*", &argc, &argv); + + vec = pic_make_vec(pic, argc); + + for (i = 0; i < argc; ++i) { + vec->data[i] = argv[i]; + } + + return pic_obj_value(vec); +} + static pic_value pic_vec_make_vector(pic_state *pic) { @@ -313,6 +332,7 @@ void pic_init_vector(pic_state *pic) { pic_defun(pic, "vector?", pic_vec_vector_p); + pic_defun(pic, "vector", pic_vec_vector); pic_defun(pic, "make-vector", pic_vec_make_vector); pic_defun(pic, "vector-length", pic_vec_vector_length); pic_defun(pic, "vector-ref", pic_vec_vector_ref); From 1b97362653cd4dc30aaad43dc8d0f213f6ffd4a3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 21:14:45 +0900 Subject: [PATCH 091/232] add bytevector<->list --- blob.c | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/blob.c b/blob.c index 9e79bcd1..384431b9 100644 --- a/blob.c +++ b/blob.c @@ -6,6 +6,7 @@ #include "picrin.h" #include "picrin/blob.h" +#include "picrin/pair.h" char * pic_strndup(pic_state *pic, const char *s, size_t n) @@ -182,6 +183,54 @@ pic_blob_bytevector_append(pic_state *pic) return pic_obj_value(blob); } +static pic_value +pic_blob_list_to_bytevector(pic_state *pic) +{ + pic_blob *blob; + char *data; + pic_value list, e; + + pic_get_args(pic, "o", &list); + + blob = pic_make_blob(pic, pic_length(pic, list)); + + data = blob->data; + + pic_for_each (e, list) { + pic_assert_type(pic, e, int); + + if (pic_int(e) < 0 || pic_int(e) > 255) + pic_error(pic, "byte out of range"); + + *data++ = pic_int(e); + } + return pic_obj_value(blob); +} + +static pic_value +pic_blob_bytevector_to_list(pic_state *pic) +{ + pic_blob *blob; + pic_value list; + int n, start, end, i; + + n = pic_get_args(pic, "b|ii", &blob, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = blob->len; + } + + list = pic_nil_value(); + + for (i = start; i < end; ++i) { + pic_push(pic, pic_int_value(blob->data[i]), list); + } + return pic_reverse(pic, list); +} + void pic_init_blob(pic_state *pic) { @@ -193,4 +242,6 @@ pic_init_blob(pic_state *pic) pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i); pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy); pic_defun(pic, "bytevector-append", pic_blob_bytevector_append); + pic_defun(pic, "bytevector->list", pic_blob_bytevector_to_list); + pic_defun(pic, "list->bytevector", pic_blob_list_to_bytevector); } From 0f2a172ffcdce1e9732dd157f343b2aa0e1960db Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 12 Sep 2014 21:19:08 +0900 Subject: [PATCH 092/232] add bytevector procedure --- blob.c | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/blob.c b/blob.c index 384431b9..337e3333 100644 --- a/blob.c +++ b/blob.c @@ -46,6 +46,33 @@ pic_blob_bytevector_p(pic_state *pic) return pic_bool_value(pic_blob_p(v)); } +static pic_value +pic_blob_bytevector(pic_state *pic) +{ + pic_value *argv; + size_t argc, i; + pic_blob *blob; + char *data; + + pic_get_args(pic, "*", &argc, &argv); + + blob = pic_make_blob(pic, argc); + + data = blob->data; + + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], int); + + if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) { + pic_error(pic, "byte out of range"); + } + + *data++ = pic_int(argv[i]); + } + + return pic_obj_value(blob); +} + static pic_value pic_blob_make_bytevector(pic_state *pic) { @@ -235,6 +262,7 @@ void pic_init_blob(pic_state *pic) { pic_defun(pic, "bytevector?", pic_blob_bytevector_p); + pic_defun(pic, "bytevector", pic_blob_bytevector); pic_defun(pic, "make-bytevector", pic_blob_make_bytevector); pic_defun(pic, "bytevector-length", pic_blob_bytevector_length); pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref); From d882b5fb24f72974ef1e9294a870c1f77d1b2373 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Sep 2014 16:14:33 +0900 Subject: [PATCH 093/232] add dictionary-for-each --- dict.c | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/dict.c b/dict.c index 5bd25ff0..d5058566 100644 --- a/dict.c +++ b/dict.c @@ -5,6 +5,7 @@ #include "picrin.h" #include "picrin/dict.h" #include "picrin/cont.h" +#include "picrin/pair.h" struct pic_dict * pic_make_dict(pic_state *pic) @@ -137,6 +138,29 @@ pic_dict_dict_size(pic_state *pic) return pic_int_value(pic_dict_size(pic, dict)); } +static pic_value +pic_dict_dict_for_each(pic_state *pic) +{ + struct pic_proc *proc; + struct pic_dict *dict; + pic_value item; + xh_iter it; + + pic_get_args(pic, "ld", &proc, &dict); + + xh_begin(&it, &dict->hash); + while (xh_next(&it)) { + int ai = pic_gc_arena_preserve(pic); + + item = pic_cons(pic, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); + pic_apply1(pic, proc, item); + + pic_gc_arena_restore(pic, ai); + } + + return pic_none_value(); +} + void pic_init_dict(pic_state *pic) { @@ -146,4 +170,5 @@ pic_init_dict(pic_state *pic) pic_defun(pic, "dictionary-set!", pic_dict_dict_set); pic_defun(pic, "dictionary-delete", pic_dict_dict_del); pic_defun(pic, "dictionary-size", pic_dict_dict_size); + pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each); } From e60841a8793cbbd420e6c39890120aebf4cff25b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Sep 2014 16:22:22 +0900 Subject: [PATCH 094/232] add dictionary-map --- dict.c | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/dict.c b/dict.c index d5058566..988a2a53 100644 --- a/dict.c +++ b/dict.c @@ -138,6 +138,25 @@ pic_dict_dict_size(pic_state *pic) return pic_int_value(pic_dict_size(pic, dict)); } +static pic_value +pic_dict_dict_map(pic_state *pic) +{ + struct pic_proc *proc; + struct pic_dict *dict; + pic_value item, list = pic_nil_value(); + xh_iter it; + + pic_get_args(pic, "ld", &proc, &dict); + + xh_begin(&it, &dict->hash); + while (xh_next(&it)) { + item = pic_cons(pic, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); + pic_push(pic, pic_apply1(pic, proc, item), list); + } + + return pic_reverse(pic, list); +} + static pic_value pic_dict_dict_for_each(pic_state *pic) { @@ -170,5 +189,6 @@ pic_init_dict(pic_state *pic) pic_defun(pic, "dictionary-set!", pic_dict_dict_set); pic_defun(pic, "dictionary-delete", pic_dict_dict_del); pic_defun(pic, "dictionary-size", pic_dict_dict_size); + pic_defun(pic, "dictionary-map", pic_dict_dict_map); pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each); } From 8ed3c835eaf0124e22f4aac556ac5df7dff8f8f4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Sep 2014 16:44:27 +0900 Subject: [PATCH 095/232] add dictionary conversion functions --- dict.c | 128 +++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 112 insertions(+), 16 deletions(-) diff --git a/dict.c b/dict.c index 988a2a53..64b1ab92 100644 --- a/dict.c +++ b/dict.c @@ -65,7 +65,7 @@ pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key) } static pic_value -pic_dict_dict(pic_state *pic) +pic_dict_make_dictionary(pic_state *pic) { struct pic_dict *dict; @@ -77,7 +77,26 @@ pic_dict_dict(pic_state *pic) } static pic_value -pic_dict_dict_p(pic_state *pic) +pic_dict_dictionary(pic_state *pic) +{ + struct pic_dict *dict; + pic_value *argv; + size_t argc, i; + + pic_get_args(pic, "*", &argc, &argv); + + dict = pic_make_dict(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]); + } + + return pic_obj_value(dict); +} + +static pic_value +pic_dict_dictionary_p(pic_state *pic) { pic_value obj; @@ -87,7 +106,7 @@ pic_dict_dict_p(pic_state *pic) } static pic_value -pic_dict_dict_ref(pic_state *pic) +pic_dict_dictionary_ref(pic_state *pic) { struct pic_dict *dict; pic_sym key; @@ -102,7 +121,7 @@ pic_dict_dict_ref(pic_state *pic) } static pic_value -pic_dict_dict_set(pic_state *pic) +pic_dict_dictionary_set(pic_state *pic) { struct pic_dict *dict; pic_sym key; @@ -116,7 +135,7 @@ pic_dict_dict_set(pic_state *pic) } static pic_value -pic_dict_dict_del(pic_state *pic) +pic_dict_dictionary_del(pic_state *pic) { struct pic_dict *dict; pic_sym key; @@ -129,7 +148,7 @@ pic_dict_dict_del(pic_state *pic) } static pic_value -pic_dict_dict_size(pic_state *pic) +pic_dict_dictionary_size(pic_state *pic) { struct pic_dict *dict; @@ -139,7 +158,7 @@ pic_dict_dict_size(pic_state *pic) } static pic_value -pic_dict_dict_map(pic_state *pic) +pic_dict_dictionary_map(pic_state *pic) { struct pic_proc *proc; struct pic_dict *dict; @@ -158,7 +177,7 @@ pic_dict_dict_map(pic_state *pic) } static pic_value -pic_dict_dict_for_each(pic_state *pic) +pic_dict_dictionary_for_each(pic_state *pic) { struct pic_proc *proc; struct pic_dict *dict; @@ -180,15 +199,92 @@ pic_dict_dict_for_each(pic_state *pic) return pic_none_value(); } +static pic_value +pic_dict_dictionary_to_alist(pic_state *pic) +{ + struct pic_dict *dict; + pic_value item, alist = pic_nil_value(); + xh_iter it; + + pic_get_args(pic, "d", &dict); + + xh_begin(&it, &dict->hash); + while (xh_next(&it)) { + item = pic_cons(pic, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); + pic_push(pic, item, alist); + } + + return pic_reverse(pic, alist); +} + +static pic_value +pic_dict_alist_to_dictionary(pic_state *pic) +{ + struct pic_dict *dict; + pic_value alist, e; + + pic_get_args(pic, "o", &alist); + + dict = pic_make_dict(pic); + + pic_for_each (e, pic_reverse(pic, alist)) { + pic_assert_type(pic, pic_car(pic, e), sym); + pic_dict_set(pic, dict, pic_sym(pic_car(pic, e)), pic_cdr(pic, e)); + } + + return pic_obj_value(dict); +} + +static pic_value +pic_dict_dictionary_to_plist(pic_state *pic) +{ + struct pic_dict *dict; + pic_value plist = pic_nil_value(); + xh_iter it; + + pic_get_args(pic, "d", &dict); + + xh_begin(&it, &dict->hash); + while (xh_next(&it)) { + pic_push(pic, xh_val(it.e, pic_value), plist); + pic_push(pic, pic_sym_value(xh_key(it.e, pic_sym)), plist); + } + + return pic_reverse(pic, plist); +} + +static pic_value +pic_dict_plist_to_dictionary(pic_state *pic) +{ + struct pic_dict *dict; + pic_value plist, e; + + pic_get_args(pic, "o", &plist); + + dict = pic_make_dict(pic); + + for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) { + pic_assert_type(pic, pic_car(pic, e), sym); + pic_dict_set(pic, dict, pic_sym(pic_car(pic, e)), pic_cadr(pic, e)); + } + + return pic_obj_value(dict); +} + void pic_init_dict(pic_state *pic) { - pic_defun(pic, "make-dictionary", pic_dict_dict); - pic_defun(pic, "dictionary?", pic_dict_dict_p); - pic_defun(pic, "dictionary-ref", pic_dict_dict_ref); - pic_defun(pic, "dictionary-set!", pic_dict_dict_set); - pic_defun(pic, "dictionary-delete", pic_dict_dict_del); - pic_defun(pic, "dictionary-size", pic_dict_dict_size); - pic_defun(pic, "dictionary-map", pic_dict_dict_map); - pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each); + pic_defun(pic, "make-dictionary", pic_dict_make_dictionary); + pic_defun(pic, "dictionary?", pic_dict_dictionary_p); + 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); + pic_defun(pic, "dictionary->alist", pic_dict_dictionary_to_alist); + pic_defun(pic, "alist->dictionary", pic_dict_alist_to_dictionary); + pic_defun(pic, "dictionary->plist", pic_dict_dictionary_to_plist); + pic_defun(pic, "plist->dictionary", pic_dict_plist_to_dictionary); } From 6bc702bd89c850a3287d8420793b1740c7503c5c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Sep 2014 16:50:06 +0900 Subject: [PATCH 096/232] [bugfix] signedness of ret val from pic_int --- include/picrin/value.h | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/include/picrin/value.h b/include/picrin/value.h index b7490fda..97c05c6f 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -63,7 +63,14 @@ pic_float(pic_value v) return u.f; } -#define pic_int(v) ((v) & 0xfffffffful) +static inline int +pic_int(pic_value v) +{ + union { int i; unsigned u; } u; + u.u = v & 0xfffffffful; + return u.i; +} + #define pic_sym(v) ((v) & 0xfffffffful) #define pic_char(v) ((v) & 0xfffffffful) From ec490286180c87f53b0524d020246fed7bf83ce0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Sep 2014 16:54:01 +0900 Subject: [PATCH 097/232] dictionary-delete -> dictionary-delete! --- dict.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dict.c b/dict.c index 64b1ab92..a4a1e3d7 100644 --- a/dict.c +++ b/dict.c @@ -279,7 +279,7 @@ 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-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); From 391b597dc6d932103b4afb9480d75c155ae5e8b2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Sep 2014 18:46:02 +0900 Subject: [PATCH 098/232] pic_sym should be unsigned --- include/picrin/value.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/picrin/value.h b/include/picrin/value.h index 97c05c6f..dc8c6297 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -13,7 +13,7 @@ extern "C" { * pic_sym is just an alias to unsigned int. */ -typedef int pic_sym; +typedef unsigned int pic_sym; /** * `undef` values never seen from user-end: that is, From b20a97ed9fbc3bfcbf12158f4c2001d983e50c2d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Sep 2014 18:51:20 +0900 Subject: [PATCH 099/232] move map/for-each to pair.c --- pair.c | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ proc.c | 59 ---------------------------------------------------------- 2 files changed, 59 insertions(+), 59 deletions(-) diff --git a/pair.c b/pair.c index 3ca55610..d9960347 100644 --- a/pair.c +++ b/pair.c @@ -667,6 +667,63 @@ pic_pair_list_copy(pic_state *pic) return pic_list_copy(pic, obj); } +static pic_value +pic_pair_map(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc; + pic_value *args; + int i; + pic_value cars, ret; + + pic_get_args(pic, "l*", &proc, &argc, &args); + + ret = pic_nil_value(); + do { + cars = pic_nil_value(); + for (i = argc - 1; i >= 0; --i) { + if (! pic_pair_p(args[i])) { + break; + } + cars = pic_cons(pic, pic_car(pic, args[i]), cars); + args[i] = pic_cdr(pic, args[i]); + } + if (i >= 0) + break; + ret = pic_cons(pic, pic_apply(pic, proc, cars), ret); + } while (1); + + return pic_reverse(pic, ret); +} + +static pic_value +pic_pair_for_each(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc; + pic_value *args; + int i; + pic_value cars; + + pic_get_args(pic, "l*", &proc, &argc, &args); + + do { + cars = pic_nil_value(); + for (i = argc - 1; i >= 0; --i) { + if (! pic_pair_p(args[i])) { + break; + } + cars = pic_cons(pic, pic_car(pic, args[i]), cars); + args[i] = pic_cdr(pic, args[i]); + } + if (i >= 0) + break; + pic_apply(pic, proc, cars); + } while (1); + + return pic_none_value(); +} + static pic_value pic_pair_memq(pic_state *pic) { @@ -754,6 +811,8 @@ pic_init_pair(pic_state *pic) pic_defun(pic, "list-ref", pic_pair_list_ref); pic_defun(pic, "list-set!", pic_pair_list_set); pic_defun(pic, "list-copy", pic_pair_list_copy); + pic_defun(pic, "map", pic_pair_map); + pic_defun(pic, "for-each", pic_pair_for_each); pic_defun(pic, "memq", pic_pair_memq); pic_defun(pic, "memv", pic_pair_memv); pic_defun(pic, "member", pic_pair_member); diff --git a/proc.c b/proc.c index a518214f..e68965fc 100644 --- a/proc.c +++ b/proc.c @@ -102,63 +102,6 @@ pic_proc_apply(pic_state *pic) return pic_apply_trampoline(pic, proc, arg_list); } -static pic_value -pic_proc_map(pic_state *pic) -{ - struct pic_proc *proc; - size_t argc; - pic_value *args; - int i; - pic_value cars, ret; - - pic_get_args(pic, "l*", &proc, &argc, &args); - - ret = pic_nil_value(); - do { - cars = pic_nil_value(); - for (i = argc - 1; i >= 0; --i) { - if (! pic_pair_p(args[i])) { - break; - } - cars = pic_cons(pic, pic_car(pic, args[i]), cars); - args[i] = pic_cdr(pic, args[i]); - } - if (i >= 0) - break; - ret = pic_cons(pic, pic_apply(pic, proc, cars), ret); - } while (1); - - return pic_reverse(pic, ret); -} - -static pic_value -pic_proc_for_each(pic_state *pic) -{ - struct pic_proc *proc; - size_t argc; - pic_value *args; - int i; - pic_value cars; - - pic_get_args(pic, "l*", &proc, &argc, &args); - - do { - cars = pic_nil_value(); - for (i = argc - 1; i >= 0; --i) { - if (! pic_pair_p(args[i])) { - break; - } - cars = pic_cons(pic, pic_car(pic, args[i]), cars); - args[i] = pic_cdr(pic, args[i]); - } - if (i >= 0) - break; - pic_apply(pic, proc, cars); - } while (1); - - return pic_none_value(); -} - static pic_value pic_proc_attribute(pic_state *pic) { @@ -174,8 +117,6 @@ pic_init_proc(pic_state *pic) { pic_defun(pic, "procedure?", pic_proc_proc_p); pic_defun(pic, "apply", pic_proc_apply); - pic_defun(pic, "map", pic_proc_map); - pic_defun(pic, "for-each", pic_proc_for_each); pic_defun(pic, "attribute", pic_proc_attribute); } From 09e56c2c359fc9723e42b986ad8f58af1fae7044 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 14 Sep 2014 01:08:37 +0900 Subject: [PATCH 100/232] upgrade xvect.h --- codegen.c | 38 +++++----- include/picrin/xvect.h | 160 +++++++++++++++++++++++++++++++++++------ 2 files changed, 157 insertions(+), 41 deletions(-) diff --git a/codegen.c b/codegen.c index b593a5d1..d9238456 100644 --- a/codegen.c +++ b/codegen.c @@ -198,13 +198,13 @@ lookup_scope(analyze_scope *scope, pic_sym sym) size_t i; /* args */ - for (i = 0; i < scope->args.size; ++i) { + for (i = 0; i < xv_size(&scope->args); ++i) { arg = xv_get(&scope->args, i); if (*arg == sym) return true; } /* locals */ - for (i = 0; i < scope->locals.size; ++i) { + for (i = 0; i < xv_size(&scope->locals); ++i) { local = xv_get(&scope->locals, i); if (*local == sym) return true; @@ -218,13 +218,13 @@ capture_var(analyze_scope *scope, pic_sym sym) pic_sym *var; size_t i; - for (i = 0; i < scope->captures.size; ++i) { + for (i = 0; i < xv_size(&scope->captures); ++i) { var = xv_get(&scope->captures, i); if (*var == sym) { break; } } - if (i == scope->captures.size) { + if (i == xv_size(&scope->captures)) { xv_push(&scope->captures, &sym); } } @@ -384,7 +384,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v size_t i; args = pic_nil_value(); - for (i = scope->args.size; i > 0; --i) { + for (i = xv_size(&scope->args); i > 0; --i) { var = xv_get(&scope->args, i - 1); pic_push(pic, pic_sym_value(*var), args); } @@ -399,13 +399,13 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v analyze_deferred(state); locals = pic_nil_value(); - for (i = scope->locals.size; i > 0; --i) { + for (i = xv_size(&scope->locals); i > 0; --i) { var = xv_get(&scope->locals, i - 1); pic_push(pic, pic_sym_value(*var), locals); } captures = pic_nil_value(); - for (i = scope->captures.size; i > 0; --i) { + for (i = xv_size(&scope->captures); i > 0; --i) { var = xv_get(&scope->captures, i - 1); pic_push(pic, pic_sym_value(*var), captures); } @@ -940,21 +940,21 @@ create_activation(codegen_context *cxt) xh_init_int(®s, sizeof(size_t)); offset = 1; - for (i = 0; i < cxt->args.size; ++i) { + for (i = 0; i < xv_size(&cxt->args); ++i) { var = xv_get(&cxt->args, i); n = i + offset; xh_put_int(®s, *var, &n); } offset += i; - for (i = 0; i < cxt->locals.size; ++i) { + for (i = 0; i < xv_size(&cxt->locals); ++i) { var = xv_get(&cxt->locals, i); n = i + offset; xh_put_int(®s, *var, &n); } - for (i = 0; i < cxt->captures.size; ++i) { + 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)) <= cxt->args.size || (cxt->varg && n == cxt->args.size + 1)) { + if ((n = xh_val(xh_get_int(®s, *var), size_t)) <= 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 = n; @@ -1031,9 +1031,9 @@ 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 = state->cxt->args.size + 1; - irep->localc = state->cxt->locals.size; - irep->capturec = state->cxt->captures.size; + irep->argc = xv_size(&state->cxt->args) + 1; + irep->localc = xv_size(&state->cxt->locals); + irep->capturec = 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); @@ -1065,7 +1065,7 @@ index_capture(codegen_state *state, pic_sym sym, int depth) cxt = cxt->up; } - for (i = 0; i < cxt->captures.size; ++i) { + for (i = 0; i < xv_size(&cxt->captures); ++i) { var = xv_get(&cxt->captures, i); if (*var == sym) return i; @@ -1081,13 +1081,13 @@ index_local(codegen_state *state, pic_sym sym) pic_sym *var; offset = 1; - for (i = 0; i < cxt->args.size; ++i) { + for (i = 0; i < xv_size(&cxt->args); ++i) { var = xv_get(&cxt->args, i); if (*var == sym) return i + offset; } offset += i; - for (i = 0; i < cxt->locals.size; ++i) { + for (i = 0; i < xv_size(&cxt->locals); ++i) { var = xv_get(&cxt->locals, i); if (*var == sym) return i + offset; @@ -1128,7 +1128,7 @@ codegen(codegen_state *state, pic_value obj) name = pic_sym(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 + cxt->args.size + cxt->locals.size + 1; + cxt->code[cxt->clen].u.i = i + xv_size(&cxt->args) + xv_size(&cxt->locals) + 1; cxt->clen++; return; } @@ -1174,7 +1174,7 @@ codegen(codegen_state *state, pic_value obj) name = pic_sym(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 + cxt->args.size + cxt->locals.size + 1; + cxt->code[cxt->clen].u.i = i + xv_size(&cxt->args) + xv_size(&cxt->locals) + 1; cxt->clen++; cxt->code[cxt->clen].insn = OP_PUSHNONE; cxt->clen++; diff --git a/include/picrin/xvect.h b/include/picrin/xvect.h index ec68a2cb..b98886e9 100644 --- a/include/picrin/xvect.h +++ b/include/picrin/xvect.h @@ -2,40 +2,52 @@ #define XVECT_H__ /* - * Copyright (c) 2014 by Yuichi Nishiwaki + * Copyright (c) 2014 by Yuichi Nishiwaki */ #if defined(__cplusplus) extern "C" { #endif +#include #include #include +#include typedef struct xvect { char *data; - size_t size, capa, width; + size_t size, mask, head, tail, width; } xvect; static inline void xv_init(xvect *, size_t); static inline void xv_destroy(xvect *); +static inline size_t xv_size(xvect *); + static inline void xv_reserve(xvect *, size_t); +static inline void xv_shrink(xvect *, size_t); static inline void *xv_get(xvect *, size_t); static inline void xv_set(xvect *, size_t, void *); static inline void xv_push(xvect *, void *); -static inline void *xv_peek(xvect *); static inline void *xv_pop(xvect *); +static inline void *xv_shift(xvect *); +static inline void xv_unshift(xvect *, void *); + +static inline void xv_splice(xvect *, size_t, size_t); +static inline void xv_insert(xvect *, size_t, void *); + static inline void xv_init(xvect *x, size_t width) { x->data = NULL; - x->size = 0; - x->capa = 0; x->width = width; + x->size = 0; + x->mask = -1; + x->head = 0; + x->tail = 0; } static inline void @@ -44,44 +56,148 @@ xv_destroy(xvect *x) free(x->data); } -static inline void -xv_reserve(xvect *x, size_t newcapa) +static inline size_t +xv_size(xvect *x) { - x->data = realloc(x->data, newcapa * x->width); - x->capa = newcapa; + 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) { - return x->data + i * x->width; + 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(x->data + i * x->width, src, x->width); + memcpy(xv_get(x, i), src, x->width); } static inline void xv_push(xvect *x, void *src) { - if (x->capa <= x->size + 1) { - xv_reserve(x, x->size * 2 + 1); - } - xv_set(x, x->size++, src); -} - -static inline void * -xv_peek(xvect *x) -{ - return xv_get(x, x->size); + 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) { - return xv_get(x, --x->size); + 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) From 0c8d5aa33cee0f79e9ae7a6f8352244b62e7a121 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 14 Sep 2014 17:54:53 +0900 Subject: [PATCH 101/232] eliminate uses of '__' --- include/picrin.h | 8 ++++---- include/picrin/blob.h | 4 ++-- include/picrin/cont.h | 4 ++-- include/picrin/data.h | 4 ++-- include/picrin/dict.h | 4 ++-- include/picrin/error.h | 4 ++-- include/picrin/gc.h | 4 ++-- include/picrin/irep.h | 4 ++-- include/picrin/lib.h | 4 ++-- include/picrin/macro.h | 4 ++-- include/picrin/pair.h | 8 ++++---- include/picrin/port.h | 4 ++-- include/picrin/proc.h | 4 ++-- include/picrin/read.h | 4 ++-- include/picrin/string.h | 4 ++-- include/picrin/util.h | 16 ++++++++-------- include/picrin/value.h | 4 ++-- include/picrin/var.h | 4 ++-- include/picrin/vector.h | 4 ++-- 19 files changed, 48 insertions(+), 48 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index f752d2cf..8dcd87b5 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -21,8 +21,8 @@ * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ -#ifndef PICRIN_H__ -#define PICRIN_H__ +#ifndef PICRIN_H +#define PICRIN_H #if defined(__cplusplus) extern "C" { @@ -188,8 +188,8 @@ struct pic_lib *pic_open_library(pic_state *, pic_value); struct pic_lib *pic_find_library(pic_state *, pic_value); #define pic_deflibrary(pic, spec) \ - pic_deflibrary_helper__(pic, GENSYM(i), GENSYM(prev_lib), spec) -#define pic_deflibrary_helper__(pic, i, prev_lib, spec) \ + pic_deflibrary_helper_(pic, GENSYM(i), 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) diff --git a/include/picrin/blob.h b/include/picrin/blob.h index 5837c04f..29a285e9 100644 --- a/include/picrin/blob.h +++ b/include/picrin/blob.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_BLOB_H__ -#define PICRIN_BLOB_H__ +#ifndef PICRIN_BLOB_H +#define PICRIN_BLOB_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 0a0da9f1..eeabb798 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_CONT_H__ -#define PICRIN_CONT_H__ +#ifndef PICRIN_CONT_H +#define PICRIN_CONT_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/data.h b/include/picrin/data.h index a80ff209..0e59095d 100644 --- a/include/picrin/data.h +++ b/include/picrin/data.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_DATA_H__ -#define PICRIN_DATA_H__ +#ifndef PICRIN_DATA_H +#define PICRIN_DATA_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/dict.h b/include/picrin/dict.h index bf681cad..8d6077af 100644 --- a/include/picrin/dict.h +++ b/include/picrin/dict.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_DICT_H__ -#define PICRIN_DICT_H__ +#ifndef PICRIN_DICT_H +#define PICRIN_DICT_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/error.h b/include/picrin/error.h index bea590e2..5005346a 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_ERROR_H__ -#define PICRIN_ERROR_H__ +#ifndef PICRIN_ERROR_H +#define PICRIN_ERROR_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/gc.h b/include/picrin/gc.h index c5f33e6a..9f165d80 100644 --- a/include/picrin/gc.h +++ b/include/picrin/gc.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_GC_H__ -#define PICRIN_GC_H__ +#ifndef PICRIN_GC_H +#define PICRIN_GC_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/irep.h b/include/picrin/irep.h index 4cb1cfba..c6e5befb 100644 --- a/include/picrin/irep.h +++ b/include/picrin/irep.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_IREP_H__ -#define PICRIN_IREP_H__ +#ifndef PICRIN_IREP_H +#define PICRIN_IREP_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/lib.h b/include/picrin/lib.h index ba43e49d..98ab3ae8 100644 --- a/include/picrin/lib.h +++ b/include/picrin/lib.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_LIB_H__ -#define PICRIN_LIB_H__ +#ifndef PICRIN_LIB_H +#define PICRIN_LIB_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/macro.h b/include/picrin/macro.h index e4f03b42..79148e51 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_MACRO_H__ -#define PICRIN_MACRO_H__ +#ifndef PICRIN_MACRO_H +#define PICRIN_MACRO_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 49de01cc..89cfe938 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_PAIR_H__ -#define PICRIN_PAIR_H__ +#ifndef PICRIN_PAIR_H +#define PICRIN_PAIR_H #if defined(__cplusplus) extern "C" { @@ -36,8 +36,8 @@ pic_value pic_list_by_array(pic_state *, size_t, pic_value *); pic_value pic_make_list(pic_state *, int, pic_value); #define pic_for_each(var, list) \ - pic_for_each_helper__(var, GENSYM(tmp), list) -#define pic_for_each_helper__(var, tmp, list) \ + pic_for_each_helper_(var, 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)) diff --git a/include/picrin/port.h b/include/picrin/port.h index e51d8759..334746cb 100644 --- a/include/picrin/port.h +++ b/include/picrin/port.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_PORT_H__ -#define PICRIN_PORT_H__ +#ifndef PICRIN_PORT_H +#define PICRIN_PORT_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/proc.h b/include/picrin/proc.h index b443d3d9..bf5dda36 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_PROC_H__ -#define PICRIN_PROC_H__ +#ifndef PICRIN_PROC_H +#define PICRIN_PROC_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/read.h b/include/picrin/read.h index c77398e3..18d46ff7 100644 --- a/include/picrin/read.h +++ b/include/picrin/read.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_READ_H__ -#define PICRIN_READ_H__ +#ifndef PICRIN_READ_H +#define PICRIN_READ_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/string.h b/include/picrin/string.h index 5a224d3d..325bec11 100644 --- a/include/picrin/string.h +++ b/include/picrin/string.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_STRING_H__ -#define PICRIN_STRING_H__ +#ifndef PICRIN_STRING_H +#define PICRIN_STRING_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/util.h b/include/picrin/util.h index f2f5e719..d56cd9f6 100644 --- a/include/picrin/util.h +++ b/include/picrin/util.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_UTIL_H__ -#define PICRIN_UTIL_H__ +#ifndef PICRIN_UTIL_H +#define PICRIN_UTIL_H #if defined(__cplusplus) extern "C" { @@ -20,12 +20,12 @@ extern "C" { #define FALLTHROUGH ((void)0) #define UNUSED(v) ((void)(v)) -#define GENSYM2__(x,y) G##x##_##y##__ -#define GENSYM1__(x,y) GENSYM2__(x,y) +#define GENSYM2_(x,y) G##x##_##y##__ +#define GENSYM1_(x,y) GENSYM2_(x,y) #if defined(__COUNTER__) -# define GENSYM(x) GENSYM1__(__COUNTER__,x) +# define GENSYM(x) GENSYM1_(__COUNTER__,x) #else -# define GENSYM(x) GENSYM1__(__LINE__,x) +# define GENSYM(x) GENSYM1_(__LINE__,x) #endif #if GCC_VERSION >= 40500 || __clang__ @@ -36,8 +36,8 @@ extern "C" { #endif #define SWAP(type,a,b) \ - SWAP_HELPER__(type,GENSYM(tmp),a,b) -#define SWAP_HELPER__(type,tmp,a,b) \ + SWAP_HELPER_(type,GENSYM(tmp),a,b) +#define SWAP_HELPER_(type,tmp,a,b) \ do { \ type tmp = (a); \ (a) = (b); \ diff --git a/include/picrin/value.h b/include/picrin/value.h index dc8c6297..560e578a 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_VALUE_H__ -#define PICRIN_VALUE_H__ +#ifndef PICRIN_VALUE_H +#define PICRIN_VALUE_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/var.h b/include/picrin/var.h index 556647a8..4c1ba7c5 100644 --- a/include/picrin/var.h +++ b/include/picrin/var.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_VAR_H__ -#define PICRIN_VAR_H__ +#ifndef PICRIN_VAR_H +#define PICRIN_VAR_H #if defined(__cplusplus) extern "C" { diff --git a/include/picrin/vector.h b/include/picrin/vector.h index d4e54da9..514ecb4b 100644 --- a/include/picrin/vector.h +++ b/include/picrin/vector.h @@ -2,8 +2,8 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_VECTOR_H__ -#define PICRIN_VECTOR_H__ +#ifndef PICRIN_VECTOR_H +#define PICRIN_VECTOR_H #if defined(__cplusplus) extern "C" { From 78b3cb8c6eb2def286e4310b2862f817735cd2b1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 14 Sep 2014 18:06:36 +0900 Subject: [PATCH 102/232] avoid import error not propagated to the toplevel --- lib.c | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/lib.c b/lib.c index b752fcc7..1a74221e 100644 --- a/lib.c +++ b/lib.c @@ -133,12 +133,7 @@ import(pic_state *pic, pic_value spec) struct pic_dict *imports; xh_iter it; - pic_try { - imports = import_table(pic, spec); - } - pic_catch { - pic_errorf(pic, "syntax error around import statement: ~s", spec); - } + imports = import_table(pic, spec); xh_begin(&it, &imports->hash); while (xh_next(&it)) { From 0fe6e3dc7bb843e45a90be516a7d2dd5cbabbc2b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 14 Sep 2014 18:14:23 +0900 Subject: [PATCH 103/232] add pic_import_library --- include/picrin.h | 1 + lib.c | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/include/picrin.h b/include/picrin.h index 8dcd87b5..a1428268 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -195,6 +195,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value); 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) void pic_import(pic_state *, pic_value); +void pic_import_library(pic_state *, struct pic_lib *); void pic_export(pic_state *, pic_sym); noreturn void pic_abort(pic_state *, const char *); diff --git a/lib.c b/lib.c index 1a74221e..3d715907 100644 --- a/lib.c +++ b/lib.c @@ -190,6 +190,12 @@ pic_import(pic_state *pic, pic_value spec) import(pic, spec); } +void +pic_import_library(pic_state *pic, struct pic_lib *lib) +{ + import(pic, lib->name); +} + void pic_export(pic_state *pic, pic_sym sym) { From 2d8535ae6adc66005809ecda8d87e07a3a2e0f2d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 14 Sep 2014 18:16:02 +0900 Subject: [PATCH 104/232] move pic_std* prototypes to picrin.h --- include/picrin.h | 4 ++++ include/picrin/port.h | 4 ---- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index a1428268..3007db00 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -216,6 +216,10 @@ static inline void pic_warn(pic_state *pic, const char *msg) const char *pic_errmsg(pic_state *); +struct pic_port *pic_stdin(pic_state *); +struct pic_port *pic_stdout(pic_state *); +struct pic_port *pic_stderr(pic_state *); + pic_value pic_write(pic_state *, pic_value); /* returns given obj */ pic_value pic_fwrite(pic_state *, pic_value, xFILE *); void pic_printf(pic_state *, const char *, ...); diff --git a/include/picrin/port.h b/include/picrin/port.h index 334746cb..4f763902 100644 --- a/include/picrin/port.h +++ b/include/picrin/port.h @@ -33,10 +33,6 @@ struct pic_port { pic_value pic_eof_object(); -struct pic_port *pic_stdin(pic_state *); -struct pic_port *pic_stdout(pic_state *); -struct pic_port *pic_stderr(pic_state *); - struct pic_port *pic_open_input_string(pic_state *, const char *); struct pic_port *pic_open_output_string(pic_state *); struct pic_string *pic_get_output_string(pic_state *, struct pic_port *); From a24748c49adf6c9992541fb1ea017bb3d09427ba Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 14 Sep 2014 18:44:33 +0900 Subject: [PATCH 105/232] huge improvement of README --- README.md | 45 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 4c14ac09..37fc4165 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,49 @@ # Benz -Benz is core module of the Picrin Scheme interpreter. It includes all components necessary to run in a stand-alone environment. +Benz is a super tiny scheme interpreter intended to be embedded in other applications such as game engine and network server. It provides a subset language of R7RS with several useful extensions. By default, Benz just contains some C files and headers and this README file. In embedding, you only need to copy the files into the project and add `include` dir to the include path. + +Originally, Benz used to be the core component of [Picrin Scheme](https://github.com/picrin-scheme/picrin). They are currently maintained at separate repositories. + +## Example + +```c +#include + +#include "picrin.h" + +/* Simple REPL program */ + +int +main(int argc, char *argv[]) +{ + pic_state *pic; + pic_value expr; + + pic = pic_open(argc, argv, NULL); + + pic_import_library(pic, pic->PICRIN_BASE); + + while (1) { + printf("> "); + + expr = pic_read(pic, pic_stdin(pic)); + + if (pic_eof_p(expr)) { + break; + } + + pic_printf(pic, "~s\n", pic_eval(pic, expr, pic->lib)); + } + + pic_close(pic); + + return 0; +} +``` + +## Language + +All procedures and syntaces are exported from a single library named `(picrin base)`. The complete list is found at https://gist.github.com/wasabiz/344d802a2340d1f734b7 . ## Authors From 9f7bde294c9a3d701797f98160ced89dd702a10c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 14 Sep 2014 19:17:23 +0900 Subject: [PATCH 106/232] change actual type of pic_sym --- include/picrin/value.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/include/picrin/value.h b/include/picrin/value.h index 560e578a..18637de1 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -10,10 +10,10 @@ extern "C" { #endif /** - * pic_sym is just an alias to unsigned int. + * pic_sym is just an alias of uint32_t. */ -typedef unsigned int pic_sym; +typedef uint32_t pic_sym; /** * `undef` values never seen from user-end: that is, From 0ae0618edf25258622f37cc504386bd9827c0732 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 14 Sep 2014 22:59:29 +0900 Subject: [PATCH 107/232] move debug prints in the VM --- vm.c | 116 ++++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 71 insertions(+), 45 deletions(-) diff --git a/vm.c b/vm.c index b13f3fb6..f0139de6 100644 --- a/vm.c +++ b/vm.c @@ -564,6 +564,68 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2 #define PUSHCI() (++pic->ci) #define POPCI() (pic->ci--) +#if VM_DEBUG +# define VM_BOOT_PRINT \ + do { \ + puts("### booting VM... ###"); \ + stbase = pic->sp; \ + cibase = pic->ci; \ + } while (0) +#else +# define VM_BOOT_PRINT +#endif + +#if VM_DEBUG +# define VM_END_PRINT \ + do { \ + puts("**VM END STATE**"); \ + printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp); \ + printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci); \ + if (stbase < pic->sp - 1) { \ + pic_value *sp; \ + printf("* stack trace:"); \ + for (sp = stbase; pic->sp != sp; ++sp) { \ + pic_debug(pic, *sp); \ + puts(""); \ + } \ + } \ + if (stbase > pic->sp - 1) { \ + puts("*** stack underflow!"); \ + } \ + } while (0) +#else +# define VM_END_PRINT +#endif + +#if VM_DEBUG +# define VM_CALL_PRINT \ + do { \ + 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) { \ + 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(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ + pic_dump_irep(proc->u.irep); \ + } \ + else { \ + printf(" cfunc = %p\n", (void *)proc->u.func.f); \ + printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ + } \ + puts("== end\n"); \ + } while (0) +#else +# define VM_CALL_PRINT +#endif + pic_value pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) { @@ -584,17 +646,18 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) }; #endif +#if VM_DEBUG + pic_value *stbase; + pic_callinfo *cibase; +#endif + if (! pic_list_p(argv)) { pic_error(pic, "argv must be a proper list"); } argc = pic_length(pic, argv) + 1; -#if VM_DEBUG - puts("### booting VM... ###"); - pic_value *stbase = pic->sp; - pic_callinfo *cibase = pic->ci; -#endif + VM_BOOT_PRINT; PUSH(pic_obj_value(proc)); for (i = 1; i < argc; ++i) { @@ -655,7 +718,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) xh_entry *e; 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)); + pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, c.u.i)); } PUSH(xh_val(e, pic_value)); NEXT; @@ -756,29 +819,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) } proc = pic_proc_ptr(x); -#if VM_DEBUG - 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) { - 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(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); - pic_dump_irep(proc->u.irep); - } - else { - printf(" cfunc = %p\n", (void *)proc->u.func.f); - printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); - } - puts("== end\n"); -#endif + VM_CALL_PRINT; ci = PUSHCI(); ci->argc = c.u.i; @@ -1016,22 +1057,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) CASE(OP_STOP) { -#if VM_DEBUG - puts("**VM END STATE**"); - printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp); - printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci); - if (stbase < pic->sp - 1) { - pic_value *sp; - printf("* stack trace:"); - for (sp = stbase; pic->sp != sp; ++sp) { - pic_debug(pic, *sp); - puts(""); - } - } - if (stbase > pic->sp - 1) { - puts("*** stack underflow!"); - } -#endif + VM_END_PRINT; return pic_gc_protect(pic, POP()); } From fc9f09e05bc2bd8dd35c421493e278c21f6c4d18 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 12:32:20 +0900 Subject: [PATCH 108/232] don't use dictionaries as import_table --- lib.c | 68 +++++++++++++++++++++++++++++++---------------------------- 1 file changed, 36 insertions(+), 32 deletions(-) diff --git a/lib.c b/lib.c index 3d715907..7e62cde0 100644 --- a/lib.c +++ b/lib.c @@ -7,7 +7,6 @@ #include "picrin/pair.h" #include "picrin/macro.h" #include "picrin/error.h" -#include "picrin/dict.h" #include "picrin/string.h" #include "picrin/proc.h" @@ -65,55 +64,54 @@ pic_find_library(pic_state *pic, pic_value spec) return pic_lib_ptr(pic_cdr(pic, v)); } -static struct pic_dict * -import_table(pic_state *pic, pic_value spec) +static void +import_table(pic_state *pic, pic_value spec, xhash *imports) { const pic_sym sONLY = pic_intern_cstr(pic, "only"); const pic_sym sRENAME = pic_intern_cstr(pic, "rename"); const pic_sym sPREFIX = pic_intern_cstr(pic, "prefix"); const pic_sym sEXCEPT = pic_intern_cstr(pic, "except"); struct pic_lib *lib; - struct pic_dict *imports, *dict; - pic_value val, id; - pic_sym sym; + xhash table; + pic_value val; + pic_sym sym, id; xh_iter it; - imports = pic_make_dict(pic); + xh_init_int(&table, sizeof(pic_sym)); if (pic_list_p(spec)) { if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sONLY))) { - dict = import_table(pic, pic_cadr(pic, spec)); + import_table(pic, pic_cadr(pic, spec), &table); pic_for_each (val, pic_cddr(pic, spec)) { - pic_dict_set(pic, imports, pic_sym(val), pic_dict_ref(pic, dict, pic_sym(val))); + xh_put_int(imports, pic_sym(val), &xh_val(xh_get_int(&table, pic_sym(val)), pic_sym)); } - return imports; + goto exit; } if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) { - imports = import_table(pic, pic_cadr(pic, spec)); + import_table(pic, pic_cadr(pic, spec), imports); pic_for_each (val, pic_cddr(pic, spec)) { - id = pic_dict_ref(pic, imports, pic_sym(pic_car(pic, val))); - pic_dict_del(pic, imports, pic_sym(pic_car(pic, val))); - pic_dict_set(pic, imports, pic_sym(pic_cadr(pic, val)), id); + 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); } - return imports; + goto exit; } if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sPREFIX))) { - dict = import_table(pic, pic_cadr(pic, spec)); - xh_begin(&it, &dict->hash); + import_table(pic, pic_cadr(pic, spec), &table); + xh_begin(&it, &table); while (xh_next(&it)) { - id = pic_sym_value(xh_key(it.e, pic_sym)); val = pic_list_ref(pic, spec, 2); - sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, id)); - pic_dict_set(pic, imports, sym, xh_val(it.e, pic_value)); + sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, pic_sym_value(xh_key(it.e, pic_sym)))); + xh_put_int(imports, sym, &xh_val(it.e, pic_sym)); } - return imports; + goto exit; } if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sEXCEPT))) { - imports = import_table(pic, pic_cadr(pic, spec)); + import_table(pic, pic_cadr(pic, spec), imports); pic_for_each (val, pic_cddr(pic, spec)) { - pic_dict_del(pic, imports, pic_sym(val)); + xh_del_int(imports, pic_sym(val)); } - return imports; + goto exit; } } lib = pic_find_library(pic, spec); @@ -122,28 +120,34 @@ import_table(pic_state *pic, pic_value spec) } xh_begin(&it, &lib->exports); while (xh_next(&it)) { - pic_dict_set(pic, imports, xh_key(it.e, pic_sym), pic_sym_value(xh_val(it.e, pic_sym))); + xh_put_int(imports, xh_key(it.e, pic_sym), &xh_val(it.e, pic_sym)); } - return imports; + + exit: + xh_destroy(&table); } static void import(pic_state *pic, pic_value spec) { - struct pic_dict *imports; + xhash imports; xh_iter it; - imports = import_table(pic, spec); + xh_init_int(&imports, sizeof(pic_sym)); /* pic_sym to pic_sym */ - xh_begin(&it, &imports->hash); + import_table(pic, spec, &imports); + + xh_begin(&it, &imports); while (xh_next(&it)) { -#if DEBUG - printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, pic_sym(xh_val(it.e, pic_value)))); +#if 1 + printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym))); #endif - pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), pic_sym(xh_val(it.e, pic_value))); + pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym)); } + + xh_destroy(&imports); } static void From f8ec4ea2e1c7e057d63b161f0cd71fffb6982221 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 12:34:57 +0900 Subject: [PATCH 109/232] remove debug print --- lib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib.c b/lib.c index 7e62cde0..404b8fcb 100644 --- a/lib.c +++ b/lib.c @@ -140,7 +140,7 @@ import(pic_state *pic, pic_value spec) xh_begin(&it, &imports); while (xh_next(&it)) { -#if 1 +#if DEBUG printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym))); #endif From 48f0ec9095524fe863cde504b41f3620bcf8bc8f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 12:39:46 +0900 Subject: [PATCH 110/232] dictionary is now a equal?-based hash table --- dict.c | 115 +++++++++++++++++++++++++++++++----------- gc.c | 1 + include/picrin/dict.h | 8 +-- proc.c | 4 +- write.c | 4 +- 5 files changed, 96 insertions(+), 36 deletions(-) diff --git a/dict.c b/dict.c index a4a1e3d7..6f8b04d8 100644 --- a/dict.c +++ b/dict.c @@ -7,35 +7,96 @@ #include "picrin/cont.h" #include "picrin/pair.h" +static int +xh_value_hash(const void *key, void *data) +{ + union { double f; int i; } u; + pic_value val = *(pic_value *)key; + int hash; + + UNUSED(data); + + switch (pic_vtype(val)) { + default: + hash = 0; + break; + case PIC_VTYPE_SYMBOL: + hash = pic_sym(val); + break; + case PIC_VTYPE_FLOAT: + u.f = pic_float(val); + hash = u.i; + break; + case PIC_VTYPE_INT: + hash = pic_int(val); + break; + case PIC_VTYPE_HEAP: + hash = (int)pic_ptr(val); + break; + } + + return hash + pic_vtype(val); +} + +static int +xh_value_equal(const void *key1, const void *key2, void *pic) +{ + return pic_equal_p(pic, *(pic_value *)key1, *(pic_value *)key2); +} + +static void +xh_init_value(pic_state *pic, xhash *x) +{ + xh_init_(x, sizeof(pic_value), sizeof(pic_value), xh_value_hash, xh_value_equal, pic); +} + +static inline xh_entry * +xh_get_value(xhash *x, pic_value key) +{ + return xh_get_(x, &key); +} + +static inline xh_entry * +xh_put_value(xhash *x, pic_value key, void *val) +{ + return xh_put_(x, &key, val); +} + +static inline void +xh_del_value(xhash *x, pic_value key) +{ + xh_del_(x, &key); +} + struct pic_dict * 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_value(pic, &dict->hash); 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_value key) { xh_entry *e; - e = xh_get_int(&dict->hash, key); + e = xh_get_value(&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", 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, struct pic_dict *dict, pic_value key, pic_value val) { UNUSED(pic); - xh_put_int(&dict->hash, key, &val); + xh_put_value(&dict->hash, key, &val); } size_t @@ -47,21 +108,21 @@ pic_dict_size(pic_state *pic, struct pic_dict *dict) } bool -pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key) +pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_value key) { UNUSED(pic); - return xh_get_int(&dict->hash, key) != NULL; + return xh_get_value(&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_value 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_value(&dict->hash, key) == NULL) { + pic_errorf(pic, "no slot named ~s found in dictionary", key); } - xh_del_int(&dict->hash, key); + xh_del_value(&dict->hash, key); } static pic_value @@ -88,8 +149,7 @@ pic_dict_dictionary(pic_state *pic) dict = pic_make_dict(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, argv[i], argv[i+1]); } return pic_obj_value(dict); @@ -109,9 +169,9 @@ static pic_value pic_dict_dictionary_ref(pic_state *pic) { struct pic_dict *dict; - pic_sym key; + pic_value key; - pic_get_args(pic, "dm", &dict, &key); + pic_get_args(pic, "do", &dict, &key); if (pic_dict_has(pic, dict, key)) { return pic_values2(pic, pic_dict_ref(pic, dict, key), pic_true_value()); @@ -124,10 +184,9 @@ static pic_value pic_dict_dictionary_set(pic_state *pic) { struct pic_dict *dict; - pic_sym key; - pic_value val; + pic_value key, val; - pic_get_args(pic, "dmo", &dict, &key, &val); + pic_get_args(pic, "doo", &dict, &key, &val); pic_dict_set(pic, dict, key, val); @@ -138,9 +197,9 @@ static pic_value pic_dict_dictionary_del(pic_state *pic) { struct pic_dict *dict; - pic_sym key; + pic_value key; - pic_get_args(pic, "dm", &dict, &key); + pic_get_args(pic, "do", &dict, &key); pic_dict_del(pic, dict, key); @@ -169,7 +228,7 @@ pic_dict_dictionary_map(pic_state *pic) xh_begin(&it, &dict->hash); while (xh_next(&it)) { - item = pic_cons(pic, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); + item = pic_cons(pic, xh_key(it.e, pic_value), xh_val(it.e, pic_value)); pic_push(pic, pic_apply1(pic, proc, item), list); } @@ -190,7 +249,7 @@ pic_dict_dictionary_for_each(pic_state *pic) while (xh_next(&it)) { int ai = pic_gc_arena_preserve(pic); - item = pic_cons(pic, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); + item = pic_cons(pic, xh_key(it.e, pic_value), xh_val(it.e, pic_value)); pic_apply1(pic, proc, item); pic_gc_arena_restore(pic, ai); @@ -210,7 +269,7 @@ pic_dict_dictionary_to_alist(pic_state *pic) xh_begin(&it, &dict->hash); while (xh_next(&it)) { - item = pic_cons(pic, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); + item = pic_cons(pic, xh_key(it.e, pic_value), xh_val(it.e, pic_value)); pic_push(pic, item, alist); } @@ -228,8 +287,7 @@ pic_dict_alist_to_dictionary(pic_state *pic) dict = pic_make_dict(pic); pic_for_each (e, pic_reverse(pic, alist)) { - 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_car(pic, e), pic_cdr(pic, e)); } return pic_obj_value(dict); @@ -247,7 +305,7 @@ pic_dict_dictionary_to_plist(pic_state *pic) xh_begin(&it, &dict->hash); while (xh_next(&it)) { pic_push(pic, xh_val(it.e, pic_value), plist); - pic_push(pic, pic_sym_value(xh_key(it.e, pic_sym)), plist); + pic_push(pic, xh_key(it.e, pic_value), plist); } return pic_reverse(pic, plist); @@ -264,8 +322,7 @@ pic_dict_plist_to_dictionary(pic_state *pic) dict = pic_make_dict(pic); for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) { - pic_assert_type(pic, pic_car(pic, e), sym); - pic_dict_set(pic, dict, pic_sym(pic_car(pic, e)), pic_cadr(pic, e)); + pic_dict_set(pic, dict, pic_car(pic, e), pic_cadr(pic, e)); } return pic_obj_value(dict); diff --git a/gc.c b/gc.c index 4150be8d..9e669de4 100644 --- a/gc.c +++ b/gc.c @@ -498,6 +498,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) xh_begin(&it, &dict->hash); while (xh_next(&it)) { + gc_mark(pic, xh_key(it.e, pic_value)); gc_mark(pic, xh_val(it.e, pic_value)); } break; diff --git a/include/picrin/dict.h b/include/picrin/dict.h index 8d6077af..36160c24 100644 --- a/include/picrin/dict.h +++ b/include/picrin/dict.h @@ -19,11 +19,11 @@ 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); +pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_value); +void pic_dict_set(pic_state *, struct pic_dict *, pic_value, pic_value); +void pic_dict_del(pic_state *, struct pic_dict *, pic_value); 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_value); #if defined(__cplusplus) } diff --git a/proc.c b/proc.c index e68965fc..1dee4813 100644 --- a/proc.c +++ b/proc.c @@ -61,13 +61,13 @@ pic_attr(pic_state *pic, struct pic_proc *proc) pic_value pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key) { - return pic_dict_ref(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key)); + return pic_dict_ref(pic, pic_attr(pic, proc), pic_sym_value(pic_intern_cstr(pic, key))); } void pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v) { - pic_dict_set(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key), v); + pic_dict_set(pic, pic_attr(pic, proc), pic_sym_value(pic_intern_cstr(pic, key)), v); } static pic_value diff --git a/write.c b/write.c index d552721f..2a0e7548 100644 --- a/write.c +++ b/write.c @@ -336,7 +336,9 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(file, "#.(dictionary"); xh_begin(&it, &pic_dict_ptr(obj)->hash); while (xh_next(&it)) { - xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it.e, pic_sym))); + xfprintf(file, " '"); + write_core(p, xh_key(it.e, pic_value)); + xfprintf(file, " "); write_core(p, xh_val(it.e, pic_value)); } xfprintf(file, ")"); From 5d068017045a86b4f6b3b35e626258a85b712c8d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 12:41:51 +0900 Subject: [PATCH 111/232] [bugfix] plist<->dictionary broken --- dict.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dict.c b/dict.c index 6f8b04d8..4fc23c7a 100644 --- a/dict.c +++ b/dict.c @@ -304,8 +304,8 @@ pic_dict_dictionary_to_plist(pic_state *pic) xh_begin(&it, &dict->hash); while (xh_next(&it)) { - pic_push(pic, xh_val(it.e, pic_value), plist); pic_push(pic, xh_key(it.e, pic_value), plist); + pic_push(pic, xh_val(it.e, pic_value), plist); } return pic_reverse(pic, plist); @@ -322,7 +322,7 @@ pic_dict_plist_to_dictionary(pic_state *pic) dict = pic_make_dict(pic); for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) { - pic_dict_set(pic, dict, pic_car(pic, e), pic_cadr(pic, e)); + pic_dict_set(pic, dict, pic_cadr(pic, e), pic_car(pic, e)); } return pic_obj_value(dict); From df7a4381d09e5361665eb63a8141eec336fb3d67 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 12:47:25 +0900 Subject: [PATCH 112/232] add missing quote --- write.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/write.c b/write.c index 2a0e7548..685a5108 100644 --- a/write.c +++ b/write.c @@ -338,7 +338,7 @@ write_core(struct writer_control *p, pic_value obj) while (xh_next(&it)) { xfprintf(file, " '"); write_core(p, xh_key(it.e, pic_value)); - xfprintf(file, " "); + xfprintf(file, " '"); write_core(p, xh_val(it.e, pic_value)); } xfprintf(file, ")"); From a615eace097b7b35efb729adf10df83f8ea157fd Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 10:41:38 +0900 Subject: [PATCH 113/232] pic_var_push and pic_var_pop are private APIs --- include/picrin/var.h | 2 -- 1 file changed, 2 deletions(-) diff --git a/include/picrin/var.h b/include/picrin/var.h index 4c1ba7c5..793d3724 100644 --- a/include/picrin/var.h +++ b/include/picrin/var.h @@ -22,8 +22,6 @@ struct pic_var *pic_make_var(pic_state *, pic_value, struct pic_proc * /* = NULL pic_value pic_var_ref(pic_state *, struct pic_var *); void pic_var_set(pic_state *, struct pic_var *, pic_value); -void pic_var_push(pic_state *, struct pic_var *, pic_value); -void pic_var_pop(pic_state *, struct pic_var *); #if defined(__cplusplus) } From 8bbbbff9a25e74bb0de9cb4d5d02f05cf361eb65 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 14:40:18 +0900 Subject: [PATCH 114/232] add pic_defined_p --- include/picrin.h | 1 + vm.c | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/include/picrin.h b/include/picrin.h index 3007db00..39b55161 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -144,6 +144,7 @@ void pic_close(pic_state *); void pic_add_feature(pic_state *, const char *); void pic_define(pic_state *, const char *, pic_value); /* automatic export */ +bool pic_defined_p(pic_state *, struct pic_lib *, const char *); pic_value pic_ref(pic_state *, struct pic_lib *, const char *); void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); diff --git a/vm.c b/vm.c index f0139de6..ad265e9b 100644 --- a/vm.c +++ b/vm.c @@ -425,6 +425,12 @@ pic_define(pic_state *pic, const char *name, pic_value val) pic_export(pic, sym); } +bool +pic_defined_p(pic_state *pic, struct pic_lib *lib, const char *name) +{ + return pic_find_rename(pic, lib->env, pic_intern_cstr(pic, name), NULL); +} + pic_value pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) { From 7d64852b88561654983f97233e9508b6ff808de9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 15:36:27 +0900 Subject: [PATCH 115/232] add definition of pic_set --- vm.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/vm.c b/vm.c index ad265e9b..be82543f 100644 --- a/vm.c +++ b/vm.c @@ -445,6 +445,20 @@ pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) return xh_val(xh_get_int(&pic->globals, rename), pic_value); } +void +pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) +{ + pic_sym sym, rename; + + sym = pic_intern_cstr(pic, name); + + if (! pic_find_rename(pic, lib->env, sym, &rename)) { + pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); + } + + xh_put_int(&pic->globals, rename, &val); +} + pic_value pic_funcall(pic_state *pic, const char *name, pic_list args) { From 788ac686af39b9bd18540d298fe070cfdafdbd45 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 15:38:38 +0900 Subject: [PATCH 116/232] refactor parameter. var data structure is no longer used --- gc.c | 12 --- include/picrin.h | 2 + include/picrin/value.h | 3 - include/picrin/var.h | 30 ------- port.c | 1 - var.c | 182 ++++++++++++++++++----------------------- vm.c | 10 --- 7 files changed, 82 insertions(+), 158 deletions(-) delete mode 100644 include/picrin/var.h diff --git a/gc.c b/gc.c index 9e669de4..2d61be7f 100644 --- a/gc.c +++ b/gc.c @@ -15,7 +15,6 @@ #include "picrin/error.h" #include "picrin/macro.h" #include "picrin/lib.h" -#include "picrin/var.h" #include "picrin/data.h" #include "picrin/dict.h" #include "picrin/record.h" @@ -462,14 +461,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) gc_mark_object(pic, (struct pic_object *)lib->env); break; } - case PIC_TT_VAR: { - struct pic_var *var = (struct pic_var *)obj; - gc_mark(pic, var->stack); - if (var->conv) { - gc_mark_object(pic, (struct pic_object *)var->conv); - } - break; - } case PIC_TT_IREP: { struct pic_irep *irep = (struct pic_irep *)obj; size_t i; @@ -699,9 +690,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) xh_destroy(&lib->exports); break; } - case PIC_TT_VAR: { - break; - } case PIC_TT_IREP: { struct pic_irep *irep = (struct pic_irep *)obj; pic_free(pic, irep->code); diff --git a/include/picrin.h b/include/picrin.h index 39b55161..8719b79e 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -217,6 +217,8 @@ static inline void pic_warn(pic_state *pic, const char *msg) const char *pic_errmsg(pic_state *); +struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); + struct pic_port *pic_stdin(pic_state *); struct pic_port *pic_stdout(pic_state *); struct pic_port *pic_stderr(pic_state *); diff --git a/include/picrin/value.h b/include/picrin/value.h index 18637de1..0523c688 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -121,7 +121,6 @@ enum pic_tt { PIC_TT_SENV, PIC_TT_MACRO, PIC_TT_LIB, - PIC_TT_VAR, PIC_TT_IREP, PIC_TT_DATA, PIC_TT_DICT, @@ -266,8 +265,6 @@ pic_type_repr(enum pic_tt tt) return "macro"; case PIC_TT_LIB: return "lib"; - case PIC_TT_VAR: - return "var"; case PIC_TT_IREP: return "irep"; case PIC_TT_DATA: diff --git a/include/picrin/var.h b/include/picrin/var.h deleted file mode 100644 index 793d3724..00000000 --- a/include/picrin/var.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_VAR_H -#define PICRIN_VAR_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_var { - PIC_OBJECT_HEADER - pic_value stack; - struct pic_proc *conv; -}; - -#define pic_var_p(o) (pic_type(o) == PIC_TT_VAR) -#define pic_var_ptr(o) ((struct pic_var *)pic_ptr(o)) - -struct pic_var *pic_make_var(pic_state *, pic_value, struct pic_proc * /* = NULL */); - -pic_value pic_var_ref(pic_state *, struct pic_var *); -void pic_var_set(pic_state *, struct pic_var *, pic_value); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/port.c b/port.c index 94641c06..6b27040d 100644 --- a/port.c +++ b/port.c @@ -11,7 +11,6 @@ #include "picrin/port.h" #include "picrin/string.h" #include "picrin/blob.h" -#include "picrin/var.h" pic_value pic_eof_object() diff --git a/var.c b/var.c index a91245ef..e74e0566 100644 --- a/var.c +++ b/var.c @@ -3,53 +3,91 @@ */ #include "picrin.h" -#include "picrin/var.h" #include "picrin/pair.h" +#include "picrin/proc.h" +#include "picrin/dict.h" -struct pic_var * +static pic_value +var_lookup(pic_state *pic, pic_value var) +{ + pic_value val, env; + struct pic_dict *binding; + + val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment"); + if (pic_eq_p(val, var)) { + return pic_false_value(); + } + + env = pic_funcall(pic, "current-dynamic-environment", pic_nil_value()); + while (! pic_nil_p(env)) { + pic_assert_type(pic, pic_car(pic, env), dict); + + binding = pic_dict_ptr(pic_car(pic, env)); + if (pic_dict_has(pic, binding, var)) { + return pic_dict_ref(pic, binding, var); + } + env = pic_cdr(pic, env); + } + + return pic_false_value(); +} + +static pic_value +var_call(pic_state *pic) +{ + struct pic_proc *self = pic_get_proc(pic); + pic_value val, tmp, box, conv; + size_t n; + + n = pic_get_args(pic, "|oo", &val, &tmp); + + box = var_lookup(pic, pic_obj_value(self)); + if (! pic_test(box)) { + box = pic_attr_ref(pic, self, "@@box"); + } + + switch (n) { + case 0: + return pic_car(pic, box); + + case 1: + conv = pic_attr_ref(pic, self, "@@converter"); + if (pic_test(conv)) { + pic_assert_type(pic, conv, proc); + + val = pic_apply1(pic, pic_proc_ptr(conv), val); + } + pic_set_car(pic, box, val); + + return pic_none_value(); + + case 2: + assert(pic_false_p(tmp)); + + conv = pic_attr_ref(pic, self, "@@converter"); + if (pic_test(conv)) { + pic_assert_type(pic, conv, proc); + + return pic_apply1(pic, pic_proc_ptr(conv), val); + } else { + return val; + } + } + UNREACHABLE(); +} + +struct pic_proc * pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) { - struct pic_var *var; + struct pic_proc *var; - var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR); - var->stack = pic_nil_value(); - var->conv = conv; - - pic_var_push(pic, var, init); + var = pic_make_proc(pic, var_call, ""); + pic_attr_set(pic, var, "@@box", pic_list1(pic, init)); + pic_attr_set(pic, var, "@@converter", conv ? pic_obj_value(conv) : pic_false_value()); return var; } -pic_value -pic_var_ref(pic_state *pic, struct pic_var *var) -{ - return pic_car(pic, var->stack); -} - -void -pic_var_set(pic_state *pic, struct pic_var *var, pic_value value) -{ - if (var->conv != NULL) { - value = pic_apply1(pic, var->conv, value); - } - pic_set_car(pic, var->stack, value); -} - -void -pic_var_push(pic_state *pic, struct pic_var *var, pic_value value) -{ - if (var->conv != NULL) { - value = pic_apply1(pic, var->conv, value); - } - var->stack = pic_cons(pic, value, var->stack); -} - -void -pic_var_pop(pic_state *pic, struct pic_var *var) -{ - var->stack = pic_cdr(pic, var->stack); -} - static pic_value pic_var_make_parameter(pic_state *pic) { @@ -61,72 +99,12 @@ pic_var_make_parameter(pic_state *pic) return pic_obj_value(pic_make_var(pic, init, conv)); } -static pic_value -pic_var_parameter_ref(pic_state *pic) -{ - struct pic_var *var; - pic_value v; - - pic_get_args(pic, "o", &v); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - - return pic_var_ref(pic, var); -} - -static pic_value -pic_var_parameter_set(pic_state *pic) -{ - struct pic_var *var; - pic_value v, val; - - pic_get_args(pic, "oo", &v, &val); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_set(pic, var, val); - return pic_none_value(); -} - -static pic_value -pic_var_parameter_push(pic_state *pic) -{ - struct pic_var *var; - pic_value v, val; - - pic_get_args(pic, "oo", &v, &val); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_push(pic, var, val); - return pic_none_value(); -} - -static pic_value -pic_var_parameter_pop(pic_state *pic) -{ - struct pic_var *var; - pic_value v; - - pic_get_args(pic, "o", &v); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_pop(pic, var); - return pic_none_value(); -} - void pic_init_var(pic_state *pic) { + pic_define(pic, "current-dynamic-environment", pic_false_value()); + pic_defun(pic, "make-parameter", pic_var_make_parameter); - pic_defun(pic, "parameter-ref", pic_var_parameter_ref); - pic_defun(pic, "parameter-set!", pic_var_parameter_set); - pic_defun(pic, "parameter-push!", pic_var_parameter_push); - pic_defun(pic, "parameter-pop!", pic_var_parameter_pop); + + pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL))); } diff --git a/vm.c b/vm.c index be82543f..05ddda7c 100644 --- a/vm.c +++ b/vm.c @@ -15,7 +15,6 @@ #include "picrin/port.h" #include "picrin/irep.h" #include "picrin/blob.h" -#include "picrin/var.h" #include "picrin/lib.h" #include "picrin/macro.h" #include "picrin/error.h" @@ -826,15 +825,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) L_CALL: x = pic->sp[-c.u.i]; if (! pic_proc_p(x)) { - - if (pic_var_p(x)) { - if (c.u.i != 1) { - pic_errorf(pic, "invalid call-sequence for var object"); - } - POP(); - PUSH(pic_var_ref(pic, pic_var_ptr(x))); - NEXT; - } pic_errorf(pic, "invalid application: ~s", x); } proc = pic_proc_ptr(x); From 0a0c08500311614d0a4ec2083fb7271c1dfdfb7d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 15:44:57 +0900 Subject: [PATCH 117/232] implement parameterize --- boot.c | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) diff --git a/boot.c b/boot.c index 6fa13d94..1dd344e8 100644 --- a/boot.c +++ b/boot.c @@ -300,6 +300,34 @@ my $src = <<'EOL'; `(,(r 'begin) ,@(cdr clause))) ,(loop (cdr clauses))))))))))) + (define (dynamic-bind parameters values body) + (let* ((old-bindings + (current-dynamic-environment)) + (binding + (let ((dict (dictionary))) + (for-each + (lambda (parameter value) + (dictionary-set! dict parameter (list (parameter value #f)))) + parameters + values) + dict)) + (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)))))) + (define-syntax letrec-syntax (er-macro-transformer (lambda (form r c) @@ -322,6 +350,7 @@ my $src = <<'EOL'; and or cond case else => do when unless + parameterize let-syntax letrec-syntax syntax-error)) @@ -668,6 +697,34 @@ const char pic_boot[] = " `(,(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" +" (let ((dict (dictionary)))\n" +" (for-each\n" +" (lambda (parameter value)\n" +" (dictionary-set! dict parameter (list (parameter value #f))))\n" +" parameters\n" +" values)\n" +" dict))\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" @@ -690,6 +747,7 @@ const char pic_boot[] = " and or\n" " cond case else =>\n" " do when unless\n" +" parameterize\n" " let-syntax letrec-syntax\n" " syntax-error))\n" ; From 0cc08c69f975d76a3261e0137781547ac7b8c4db Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Sep 2014 15:51:31 +0900 Subject: [PATCH 118/232] [bugfix] funcall doesn't take a module to run --- var.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var.c b/var.c index e74e0566..20b12995 100644 --- a/var.c +++ b/var.c @@ -18,7 +18,7 @@ var_lookup(pic_state *pic, pic_value var) return pic_false_value(); } - env = pic_funcall(pic, "current-dynamic-environment", pic_nil_value()); + env = pic_apply0(pic, pic_proc_ptr(val)); while (! pic_nil_p(env)) { pic_assert_type(pic, pic_car(pic, env), dict); From 9c4d8158641530ec77fc2b8b821fba6d8e1313e6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 00:16:30 +0900 Subject: [PATCH 119/232] add pic_defvar --- include/picrin.h | 12 +++++++----- port.c | 6 +++--- vm.c | 6 ++++++ 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 8719b79e..37830c1a 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -143,15 +143,13 @@ void pic_close(pic_state *); void pic_add_feature(pic_state *, const char *); -void pic_define(pic_state *, const char *, pic_value); /* automatic export */ bool pic_defined_p(pic_state *, struct pic_lib *, const char *); -pic_value pic_ref(pic_state *, struct pic_lib *, const char *); -void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); -pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); +void pic_define(pic_state *, const char *, pic_value); /* automatic export */ +void pic_defun(pic_state *, const char *, pic_func_t); +void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *); struct pic_proc *pic_get_proc(pic_state *); int pic_get_args(pic_state *, const char *, ...); -void pic_defun(pic_state *, const char *, pic_func_t); bool pic_equal_p(pic_state *, pic_value, pic_value); @@ -172,6 +170,10 @@ pic_value pic_read_cstr(pic_state *, const char *); void pic_load(pic_state *, const char *); void pic_load_cstr(pic_state *, const char *); +pic_value pic_funcall(pic_state *pic, const char *, pic_list); +pic_value pic_ref(pic_state *, struct pic_lib *, const char *); +void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); + pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply0(pic_state *, struct pic_proc *); pic_value pic_apply1(pic_state *, struct pic_proc *, pic_value); diff --git a/port.c b/port.c index 6b27040d..11ef26ab 100644 --- a/port.c +++ b/port.c @@ -681,9 +681,9 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { - pic_define(pic, "current-input-port", pic_obj_value(pic_make_var(pic, pic_obj_value(pic->xSTDIN), NULL))); - pic_define(pic, "current-output-port", pic_obj_value(pic_make_var(pic, pic_obj_value(pic->xSTDOUT), NULL))); - pic_define(pic, "current-error-port", pic_obj_value(pic_make_var(pic, pic_obj_value(pic->xSTDERR), NULL))); + pic_defvar(pic, "current-input-port", pic_obj_value(pic->xSTDIN), NULL); + pic_defvar(pic, "current-output-port", pic_obj_value(pic->xSTDOUT), NULL); + pic_defvar(pic, "current-error-port", pic_obj_value(pic->xSTDERR), NULL); pic_defun(pic, "call-with-port", pic_port_call_with_port); diff --git a/vm.c b/vm.c index 05ddda7c..d2270ccb 100644 --- a/vm.c +++ b/vm.c @@ -479,6 +479,12 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) pic_define(pic, name, pic_obj_value(proc)); } +void +pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) +{ + pic_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); +} + static void vm_push_env(pic_state *pic) { From 597e000000b33f2a022c81daa5cf589669f58812 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 00:17:04 +0900 Subject: [PATCH 120/232] remove pic_defined_p --- include/picrin.h | 1 - vm.c | 6 ------ 2 files changed, 7 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 37830c1a..0a6ce023 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -143,7 +143,6 @@ void pic_close(pic_state *); void pic_add_feature(pic_state *, const char *); -bool pic_defined_p(pic_state *, struct pic_lib *, const char *); void pic_define(pic_state *, const char *, pic_value); /* automatic export */ void pic_defun(pic_state *, const char *, pic_func_t); void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *); diff --git a/vm.c b/vm.c index d2270ccb..15d0eb93 100644 --- a/vm.c +++ b/vm.c @@ -424,12 +424,6 @@ pic_define(pic_state *pic, const char *name, pic_value val) pic_export(pic, sym); } -bool -pic_defined_p(pic_state *pic, struct pic_lib *lib, const char *name) -{ - return pic_find_rename(pic, lib->env, pic_intern_cstr(pic, name), NULL); -} - pic_value pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) { From 7db18677ab4b3038c66d25f1ad4525c0aef8a18e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 00:21:24 +0900 Subject: [PATCH 121/232] add pic_define_noexport --- include/picrin.h | 3 ++- vm.c | 12 ++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 0a6ce023..e34e7659 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -143,7 +143,8 @@ void pic_close(pic_state *); void pic_add_feature(pic_state *, const char *); -void pic_define(pic_state *, const char *, pic_value); /* automatic export */ +void pic_define(pic_state *, const char *, pic_value); +void pic_define_noexport(pic_state *, const char *, pic_value); void pic_defun(pic_state *, const char *, pic_func_t); void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *); diff --git a/vm.c b/vm.c index 15d0eb93..72ea96d0 100644 --- a/vm.c +++ b/vm.c @@ -405,7 +405,7 @@ pic_get_args(pic_state *pic, const char *format, ...) } void -pic_define(pic_state *pic, const char *name, pic_value val) +pic_define_noexport(pic_state *pic, const char *name, pic_value val) { pic_sym sym, rename; @@ -417,11 +417,15 @@ pic_define(pic_state *pic, const char *name, pic_value val) pic_warn(pic, "redefining global"); } - /* push to the global arena */ xh_put_int(&pic->globals, rename, &val); +} - /* export! */ - pic_export(pic, sym); +void +pic_define(pic_state *pic, const char *name, pic_value val) +{ + pic_define_noexport(pic, name, val); + + pic_export(pic, pic_intern_cstr(pic, name)); } pic_value From e698621ca7d70fcbd3b0305215bf4512e01941c5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 00:22:54 +0900 Subject: [PATCH 122/232] no export current-dynamic-environment --- var.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var.c b/var.c index 20b12995..ce74d104 100644 --- a/var.c +++ b/var.c @@ -102,7 +102,7 @@ pic_var_make_parameter(pic_state *pic) void pic_init_var(pic_state *pic) { - pic_define(pic, "current-dynamic-environment", pic_false_value()); + pic_define_noexport(pic, "current-dynamic-environment", pic_false_value()); pic_defun(pic, "make-parameter", pic_var_make_parameter); From ec0e5439afda4bb18e697b5e29047a028cc1e612 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 00:29:19 +0900 Subject: [PATCH 123/232] pic_funcall should take a module for its argument --- include/picrin.h | 2 +- port.c | 12 ++++++------ vm.c | 4 ++-- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index e34e7659..01c42da5 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -170,7 +170,7 @@ pic_value pic_read_cstr(pic_state *, const char *); void pic_load(pic_state *, const char *); void pic_load_cstr(pic_state *, const char *); -pic_value pic_funcall(pic_state *pic, const char *, pic_list); +pic_value pic_funcall(pic_state *pic, struct pic_lib *, const char *, pic_list); pic_value pic_ref(pic_state *, struct pic_lib *, const char *); void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); diff --git a/port.c b/port.c index 11ef26ab..b9679e54 100644 --- a/port.c +++ b/port.c @@ -25,21 +25,21 @@ pic_eof_object() struct pic_port * pic_stdin(pic_state *pic) { - struct pic_proc *proc; + pic_value obj; - proc = pic_proc_ptr(pic_ref(pic, pic->PICRIN_BASE, "current-input-port")); + obj = pic_funcall(pic, pic->PICRIN_BASE, "current-input-port", pic_nil_value()); - return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); + return pic_port_ptr(obj); } struct pic_port * pic_stdout(pic_state *pic) { - struct pic_proc *proc; + pic_value obj; - proc = pic_proc_ptr(pic_ref(pic, pic->PICRIN_BASE, "current-output-port")); + obj = pic_funcall(pic, pic->PICRIN_BASE, "current-output-port", pic_nil_value()); - return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); + return pic_port_ptr(obj); } struct pic_port * diff --git a/vm.c b/vm.c index 72ea96d0..b84bc96e 100644 --- a/vm.c +++ b/vm.c @@ -457,11 +457,11 @@ pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) } pic_value -pic_funcall(pic_state *pic, const char *name, pic_list args) +pic_funcall(pic_state *pic, struct pic_lib *lib, const char *name, pic_list args) { pic_value proc; - proc = pic_ref(pic, pic->lib, name); + proc = pic_ref(pic, lib, name); pic_assert_type(pic, proc, proc); From 8729a98af7828db25e1b8c74678f3de0aa1e1fc5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 15:02:47 +0900 Subject: [PATCH 124/232] more preinterned symbols --- include/picrin.h | 3 +- lib.c | 34 +++++++--------- state.c | 100 ++++++++++++++++++++++++----------------------- 3 files changed, 68 insertions(+), 69 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 01c42da5..e726ee4c 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -76,7 +76,8 @@ typedef struct { pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; pic_sym sDEFINE_SYNTAX, sIMPORT, sEXPORT; pic_sym sDEFINE_LIBRARY, sIN_LIBRARY; - pic_sym sCOND_EXPAND; + pic_sym sCOND_EXPAND, sAND, sOR, sELSE, sLIBRARY; + pic_sym sONLY, sRENAME, sPREFIX, sEXCEPT; pic_sym sCONS, sCAR, sCDR, sNILP; pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; diff --git a/lib.c b/lib.c index 404b8fcb..f9ccacdd 100644 --- a/lib.c +++ b/lib.c @@ -67,27 +67,26 @@ pic_find_library(pic_state *pic, pic_value spec) static void import_table(pic_state *pic, pic_value spec, xhash *imports) { - const pic_sym sONLY = pic_intern_cstr(pic, "only"); - const pic_sym sRENAME = pic_intern_cstr(pic, "rename"); - const pic_sym sPREFIX = pic_intern_cstr(pic, "prefix"); - const pic_sym sEXCEPT = pic_intern_cstr(pic, "except"); struct pic_lib *lib; xhash table; pic_value val; - pic_sym sym, id; + pic_sym sym, id, tag; xh_iter it; xh_init_int(&table, sizeof(pic_sym)); - if (pic_list_p(spec)) { - if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sONLY))) { + if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) { + + tag = pic_sym(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)); } goto exit; } - if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) { + 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); @@ -96,7 +95,7 @@ import_table(pic_state *pic, pic_value spec, xhash *imports) } goto exit; } - if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sPREFIX))) { + if (tag == pic->sPREFIX) { import_table(pic, pic_cadr(pic, spec), &table); xh_begin(&it, &table); while (xh_next(&it)) { @@ -106,7 +105,7 @@ import_table(pic_state *pic, pic_value spec, xhash *imports) } goto exit; } - if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sEXCEPT))) { + 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)); @@ -209,15 +208,10 @@ pic_export(pic_state *pic, pic_sym sym) static bool condexpand(pic_state *pic, pic_value clause) { - const pic_sym sELSE = pic_intern_cstr(pic, "else"); - const pic_sym sLIBRARY = pic_intern_cstr(pic, "library"); - const pic_sym sOR = pic_intern_cstr(pic, "or"); - const pic_sym sAND = pic_intern_cstr(pic, "and"); - const pic_sym sNOT = pic_intern_cstr(pic, "not"); pic_sym tag; pic_value c, feature; - if (pic_eq_p(clause, pic_sym_value(sELSE))) { + if (pic_eq_p(clause, pic_sym_value(pic->sELSE))) { return true; } if (pic_sym_p(clause)) { @@ -234,20 +228,20 @@ condexpand(pic_state *pic, pic_value clause) tag = pic_sym(pic_car(pic, clause)); } - if (tag == sLIBRARY) { + if (tag == pic->sLIBRARY) { return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL; } - if (tag == sNOT) { + if (tag == pic->sNOT) { return ! condexpand(pic, pic_list_ref(pic, clause, 1)); } - if (tag == sAND) { + if (tag == pic->sAND) { pic_for_each (c, pic_cdr(pic, clause)) { if (! condexpand(pic, c)) return false; } return true; } - if (tag == sOR) { + if (tag == pic->sOR) { pic_for_each (c, pic_cdr(pic, clause)) { if (condexpand(pic, c)) return true; diff --git a/state.c b/state.c index d98ee2f2..2f859642 100644 --- a/state.c +++ b/state.c @@ -90,60 +90,64 @@ pic_open(int argc, char *argv[], char **envp) /* native stack marker */ pic->native_stack_start = &t; -#define register_core_symbol(pic,slot,name) do { \ - pic->slot = pic_intern_cstr(pic, name); \ - } while (0) +#define S(slot,name) pic->slot = pic_intern_cstr(pic, name); ai = pic_gc_arena_preserve(pic); - register_core_symbol(pic, sDEFINE, "define"); - register_core_symbol(pic, sLAMBDA, "lambda"); - register_core_symbol(pic, sIF, "if"); - register_core_symbol(pic, sBEGIN, "begin"); - register_core_symbol(pic, sSETBANG, "set!"); - register_core_symbol(pic, sQUOTE, "quote"); - register_core_symbol(pic, sQUASIQUOTE, "quasiquote"); - register_core_symbol(pic, sUNQUOTE, "unquote"); - register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing"); - register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax"); - register_core_symbol(pic, sIMPORT, "import"); - register_core_symbol(pic, sEXPORT, "export"); - register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); - register_core_symbol(pic, sIN_LIBRARY, "in-library"); - register_core_symbol(pic, sCOND_EXPAND, "cond-expand"); - register_core_symbol(pic, sCONS, "cons"); - register_core_symbol(pic, sCAR, "car"); - register_core_symbol(pic, sCDR, "cdr"); - register_core_symbol(pic, sNILP, "null?"); - register_core_symbol(pic, sADD, "+"); - register_core_symbol(pic, sSUB, "-"); - register_core_symbol(pic, sMUL, "*"); - register_core_symbol(pic, sDIV, "/"); - register_core_symbol(pic, sMINUS, "minus"); - register_core_symbol(pic, sEQ, "="); - register_core_symbol(pic, sLT, "<"); - register_core_symbol(pic, sLE, "<="); - register_core_symbol(pic, sGT, ">"); - register_core_symbol(pic, sGE, ">="); - register_core_symbol(pic, sNOT, "not"); + S(sDEFINE, "define"); + S(sLAMBDA, "lambda"); + S(sIF, "if"); + S(sBEGIN, "begin"); + S(sSETBANG, "set!"); + S(sQUOTE, "quote"); + S(sQUASIQUOTE, "quasiquote"); + S(sUNQUOTE, "unquote"); + S(sUNQUOTE_SPLICING, "unquote-splicing"); + S(sDEFINE_SYNTAX, "define-syntax"); + 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"); + S(sELSE, "else"); + S(sLIBRARY, "library"); + S(sONLY, "only"); + S(sRENAME, "rename"); + S(sPREFIX, "prefix"); + S(sEXCEPT, "except"); + S(sCONS, "cons"); + S(sCAR, "car"); + S(sCDR, "cdr"); + S(sNILP, "null?"); + S(sADD, "+"); + S(sSUB, "-"); + S(sMUL, "*"); + S(sDIV, "/"); + S(sMINUS, "minus"); + S(sEQ, "="); + S(sLT, "<"); + S(sLE, "<="); + S(sGT, ">"); + S(sGE, ">="); + S(sNOT, "not"); pic_gc_arena_restore(pic, ai); -#define register_renamed_symbol(pic,slot,name) do { \ - pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); \ - } while (0) +#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); ai = pic_gc_arena_preserve(pic); - register_renamed_symbol(pic, rDEFINE, "define"); - register_renamed_symbol(pic, rLAMBDA, "lambda"); - register_renamed_symbol(pic, rIF, "if"); - register_renamed_symbol(pic, rBEGIN, "begin"); - register_renamed_symbol(pic, rSETBANG, "set!"); - register_renamed_symbol(pic, rQUOTE, "quote"); - register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax"); - register_renamed_symbol(pic, rIMPORT, "import"); - register_renamed_symbol(pic, rEXPORT, "export"); - register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); - register_renamed_symbol(pic, rIN_LIBRARY, "in-library"); - register_renamed_symbol(pic, rCOND_EXPAND, "cond-expand"); + R(rDEFINE, "define"); + R(rLAMBDA, "lambda"); + R(rIF, "if"); + R(rBEGIN, "begin"); + R(rSETBANG, "set!"); + R(rQUOTE, "quote"); + R(rDEFINE_SYNTAX, "define-syntax"); + R(rIMPORT, "import"); + R(rEXPORT, "export"); + R(rDEFINE_LIBRARY, "define-library"); + R(rIN_LIBRARY, "in-library"); + R(rCOND_EXPAND, "cond-expand"); pic_gc_arena_restore(pic, ai); /* root block */ From db5a4e367b86d76c6be993ed4ffe611385465d5d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 15:06:45 +0900 Subject: [PATCH 125/232] s/pic_port_make_stdport/pic_make_standard_port/g --- port.c | 2 +- state.c | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/port.c b/port.c index b9679e54..859df8a5 100644 --- a/port.c +++ b/port.c @@ -43,7 +43,7 @@ pic_stdout(pic_state *pic) } struct pic_port * -pic_port_make_stdport(pic_state *pic, xFILE *file, short dir) +pic_make_standard_port(pic_state *pic, xFILE *file, short dir) { struct pic_port *port; diff --git a/state.c b/state.c index 2f859642..b93559f4 100644 --- a/state.c +++ b/state.c @@ -18,7 +18,7 @@ void pic_init_core(pic_state *); pic_state * pic_open(int argc, char *argv[], char **envp) { - struct pic_port *pic_port_make_stdport(pic_state *, xFILE *, short); + struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short); char t; pic_state *pic; @@ -165,9 +165,9 @@ pic_open(int argc, char *argv[], char **envp) pic->lib = pic->PICRIN_USER; /* standard I/O */ - pic->xSTDIN = pic_port_make_stdport(pic, xstdin, PIC_PORT_IN); - pic->xSTDOUT = pic_port_make_stdport(pic, xstdout, PIC_PORT_OUT); - pic->xSTDERR = pic_port_make_stdport(pic, xstderr, PIC_PORT_OUT); + 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); pic_init_core(pic); From eb261a293ae88ff5f71e0569208e77e7a23e1e59 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 16:18:19 +0900 Subject: [PATCH 126/232] add custom marker --- gc.c | 3 +++ include/picrin/data.h | 1 + 2 files changed, 4 insertions(+) diff --git a/gc.c b/gc.c index 2d61be7f..b0dc6a08 100644 --- a/gc.c +++ b/gc.c @@ -481,6 +481,9 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) while (xh_next(&it)) { gc_mark(pic, xh_val(it.e, pic_value)); } + if (data->type->mark) { + data->type->mark(pic, data->data, gc_mark); + } break; } case PIC_TT_DICT: { diff --git a/include/picrin/data.h b/include/picrin/data.h index 0e59095d..79b633a5 100644 --- a/include/picrin/data.h +++ b/include/picrin/data.h @@ -12,6 +12,7 @@ extern "C" { typedef struct { const char *type_name; void (*dtor)(pic_state *, void *); + void (*mark)(pic_state *, void *, void (*)(pic_state *, pic_value)); } pic_data_type; struct pic_data { From 1b36b5d2ff702df5f6bd7c1a8bc19633fc9ad244 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 16:44:44 +0900 Subject: [PATCH 127/232] update xhash (orderd map) --- codegen.c | 7 +-- dict.c | 30 ++++----- gc.c | 35 +++++------ include/picrin/xhash.h | 138 ++++++++++++++++++++++------------------- lib.c | 23 +++---- state.c | 7 +-- write.c | 10 ++- 7 files changed, 123 insertions(+), 127 deletions(-) diff --git a/codegen.c b/codegen.c index d9238456..34505723 100644 --- a/codegen.c +++ b/codegen.c @@ -62,7 +62,7 @@ static analyze_state * new_analyze_state(pic_state *pic) { analyze_state *state; - xh_iter it; + xh_entry *it; state = pic_alloc(pic, sizeof(analyze_state)); state->pic = pic; @@ -98,9 +98,8 @@ new_analyze_state(pic_state *pic) /* push initial scope */ push_scope(state, pic_nil_value()); - xh_begin(&it, &pic->globals); - while (xh_next(&it)) { - pic_sym sym = xh_key(it.e, pic_sym); + 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); } diff --git a/dict.c b/dict.c index 4fc23c7a..229b55ad 100644 --- a/dict.c +++ b/dict.c @@ -222,13 +222,12 @@ pic_dict_dictionary_map(pic_state *pic) struct pic_proc *proc; struct pic_dict *dict; pic_value item, list = pic_nil_value(); - xh_iter it; + xh_entry *it; pic_get_args(pic, "ld", &proc, &dict); - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { - item = pic_cons(pic, xh_key(it.e, pic_value), xh_val(it.e, pic_value)); + for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { + item = pic_cons(pic, xh_key(it, pic_value), xh_val(it, pic_value)); pic_push(pic, pic_apply1(pic, proc, item), list); } @@ -241,15 +240,14 @@ pic_dict_dictionary_for_each(pic_state *pic) struct pic_proc *proc; struct pic_dict *dict; pic_value item; - xh_iter it; + xh_entry *it; pic_get_args(pic, "ld", &proc, &dict); - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { + for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { int ai = pic_gc_arena_preserve(pic); - item = pic_cons(pic, xh_key(it.e, pic_value), xh_val(it.e, pic_value)); + item = pic_cons(pic, xh_key(it, pic_value), xh_val(it, pic_value)); pic_apply1(pic, proc, item); pic_gc_arena_restore(pic, ai); @@ -263,13 +261,12 @@ pic_dict_dictionary_to_alist(pic_state *pic) { struct pic_dict *dict; pic_value item, alist = pic_nil_value(); - xh_iter it; + xh_entry *it; pic_get_args(pic, "d", &dict); - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { - item = pic_cons(pic, xh_key(it.e, pic_value), xh_val(it.e, pic_value)); + for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { + item = pic_cons(pic, xh_key(it, pic_value), xh_val(it, pic_value)); pic_push(pic, item, alist); } @@ -298,14 +295,13 @@ pic_dict_dictionary_to_plist(pic_state *pic) { struct pic_dict *dict; pic_value plist = pic_nil_value(); - xh_iter it; + xh_entry *it; pic_get_args(pic, "d", &dict); - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { - pic_push(pic, xh_key(it.e, pic_value), plist); - pic_push(pic, xh_val(it.e, pic_value), plist); + for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { + pic_push(pic, xh_key(it, pic_value), plist); + pic_push(pic, xh_val(it, pic_value), plist); } return pic_reverse(pic, plist); diff --git a/gc.c b/gc.c index 2d61be7f..ba0e23d7 100644 --- a/gc.c +++ b/gc.c @@ -475,32 +475,29 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_DATA: { struct pic_data *data = (struct pic_data *)obj; - xh_iter it; + xh_entry *it; - xh_begin(&it, &data->storage); - while (xh_next(&it)) { - gc_mark(pic, xh_val(it.e, pic_value)); + for (it = xh_begin(&data->storage); it != NULL; it = xh_next(it)) { + gc_mark(pic, xh_val(it, pic_value)); } break; } case PIC_TT_DICT: { struct pic_dict *dict = (struct pic_dict *)obj; - xh_iter it; + xh_entry *it; - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { - gc_mark(pic, xh_key(it.e, pic_value)); - gc_mark(pic, xh_val(it.e, pic_value)); + for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { + gc_mark(pic, xh_key(it, pic_value)); + gc_mark(pic, xh_val(it, pic_value)); } break; } case PIC_TT_RECORD: { struct pic_record *rec = (struct pic_record *)obj; - xh_iter it; + xh_entry *it; - xh_begin(&it, &rec->hash); - while (xh_next(&it)) { - gc_mark(pic, xh_val(it.e, pic_value)); + for (it = xh_begin(&rec->hash); it != NULL; it = xh_next(it)) { + gc_mark(pic, xh_val(it, pic_value)); } break; } @@ -563,7 +560,7 @@ gc_mark_phase(pic_state *pic) pic_value *stack; pic_callinfo *ci; size_t i, j; - xh_iter it; + xh_entry *it; /* block */ if (pic->blk) { @@ -593,15 +590,13 @@ gc_mark_phase(pic_state *pic) } /* global variables */ - xh_begin(&it, &pic->globals); - while (xh_next(&it)) { - gc_mark(pic, xh_val(it.e, pic_value)); + for (it = xh_begin(&pic->globals); it != NULL; it = xh_next(it)) { + gc_mark(pic, xh_val(it, pic_value)); } /* macro objects */ - xh_begin(&it, &pic->macros); - while (xh_next(&it)) { - gc_mark_object(pic, xh_val(it.e, struct pic_object *)); + for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) { + gc_mark_object(pic, xh_val(it, struct pic_object *)); } /* error handlers */ diff --git a/include/picrin/xhash.h b/include/picrin/xhash.h index a249e2ff..c78dc118 100644 --- a/include/picrin/xhash.h +++ b/include/picrin/xhash.h @@ -1,5 +1,5 @@ -#ifndef XHASH_H__ -#define XHASH_H__ +#ifndef XHASH_H +#define XHASH_H /* * Copyright (c) 2013-2014 by Yuichi Nishiwaki @@ -27,6 +27,7 @@ extern "C" { typedef struct xh_entry { struct xh_entry *next; int hash; + struct xh_entry *fw, *bw; const char *key; /* == val + XHASH_ALIGN(vwidth) */ char val[]; } xh_entry; @@ -42,15 +43,16 @@ typedef struct xhash { size_t size, count, kwidth, vwidth; xh_hashf hashf; xh_equalf equalf; + xh_entry *chain; void *data; } xhash; -static inline void xh_init_(xhash *x, size_t, size_t, xh_hashf, xh_equalf, void *); -static inline xh_entry *xh_get_(xhash *x, const void *key); -static inline xh_entry *xh_put_(xhash *x, const void *key, void *val); -static inline void xh_del_(xhash *x, const void *key); -static inline void xh_clear(xhash *x); -static inline void xh_destroy(xhash *x); +/** Protected Methods: + * static inline void xh_init_(xhash *x, size_t, size_t, xh_hashf, xh_equalf, void *); + * static inline xh_entry *xh_get_(xhash *x, const void *key); + * static inline xh_entry *xh_put_(xhash *x, const void *key, void *val); + * static inline void xh_del_(xhash *x, const void *key); + */ /* string map */ static inline void xh_init_str(xhash *x, size_t width); @@ -70,14 +72,12 @@ 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); -typedef struct xh_iter { - xhash *x; - xh_entry *e, *next; - size_t bidx; -} xh_iter; +static inline size_t xh_size(xhash *x); +static inline void xh_clear(xhash *x); +static inline void xh_destroy(xhash *x); -static inline void xh_begin(xh_iter *it, xhash *x); -static inline int xh_next(xh_iter *it); +static inline xh_entry *xh_begin(xhash *x); +static inline xh_entry *xh_next(xh_entry *e); static inline void @@ -98,6 +98,7 @@ xh_init_(xhash *x, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equal x->vwidth = vwidth; x->hashf = hashf; x->equalf = equalf; + x->chain = NULL; x->data = data; xh_bucket_realloc(x, XHASH_INIT_SIZE); @@ -123,21 +124,22 @@ static inline void xh_resize_(xhash *x, size_t newsize) { xhash y; - xh_iter it; + 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_begin(&it, x); - while (xh_next(&it)) { - idx = ((unsigned)it.e->hash) % y.size; + for (it = xh_begin(x); it != NULL; it = xh_next(it)) { + idx = ((unsigned)it->hash) % y.size; /* reuse entry object */ - it.e->next = y.buckets[idx]; - y.buckets[idx] = it.e; + it->next = y.buckets[idx]; + y.buckets[idx] = it; y.count++; } + y.chain = x->chain; + free(x->buckets); /* copy all members from y to x */ @@ -169,6 +171,16 @@ xh_put_(xhash *x, const void *key, void *val) memcpy((void *)e->key, key, x->kwidth); memcpy(e->val, val, x->vwidth); + if (x->chain == NULL) { + x->chain = e; + e->fw = e->bw = NULL; + } else { + x->chain->fw = e; + e->bw = x->chain; + e->fw = NULL; + x->chain = e; + } + x->count++; return x->buckets[idx] = e; @@ -179,28 +191,54 @@ xh_del_(xhash *x, const void *key) { int hash; size_t idx; - xh_entry *e, *d; + xh_entry *p, *q, *r; hash = x->hashf(key, x->data); idx = ((unsigned)hash) % x->size; if (x->buckets[idx]->hash == hash && x->equalf(key, x->buckets[idx]->key, x->data)) { - e = x->buckets[idx]->next; - free(x->buckets[idx]); - x->buckets[idx] = e; + q = x->buckets[idx]; + if (q->fw) { + q->fw->bw = q->bw; + } + if (q->bw) { + q->bw->fw = q->fw; + } + if (x->chain == q) { + x->chain = q->bw; + } + r = q->next; + free(q); + x->buckets[idx] = r; } else { - for (e = x->buckets[idx]; ; e = e->next) { - if (e->next->hash == hash && x->equalf(key, e->next->key, x->data)) + for (p = x->buckets[idx]; ; p = p->next) { + if (p->next->hash == hash && x->equalf(key, p->next->key, x->data)) break; } - d = e->next->next; - free(e->next); - e->next = d; + q = p->next; + if (q->fw) { + q->fw->bw = q->bw; + } + if (q->bw) { + q->bw->fw = q->fw; + } + if (x->chain == q) { + x->chain = q->bw; + } + r = q->next; + free(q); + p->next = r; } x->count--; } +static inline size_t +xh_size(xhash *x) +{ + return x->count; +} + static inline void xh_clear(xhash *x) { @@ -217,6 +255,7 @@ xh_clear(xhash *x) x->buckets[i] = NULL; } + x->chain = NULL; x->count = 0; } @@ -361,43 +400,16 @@ xh_del_int(xhash *x, int key) /** iteration */ -static inline void -xh_begin(xh_iter *it, xhash *x) +static inline xh_entry * +xh_begin(xhash *x) { - size_t bidx; - - it->x = x; - - for (bidx = 0; bidx < x->size; ++bidx) { - if (x->buckets[bidx]) - break; - } - it->e = NULL; - it->next = x->buckets[bidx]; - it->bidx = bidx; + return x->chain; } -static inline int -xh_next(xh_iter *it) +static inline xh_entry * +xh_next(xh_entry *e) { - size_t bidx; - - if (! it->next) { - return 0; - } - - it->e = it->next; - if (it->next->next) { - it->next = it->next->next; - return 1; - } - for (bidx = it->bidx + 1; bidx < it->x->size; ++bidx) { - if (it->x->buckets[bidx]) - break; - } - it->next = it->x->buckets[bidx]; - it->bidx = bidx; - return 1; + return e->bw; } #if defined(__cplusplus) diff --git a/lib.c b/lib.c index f9ccacdd..b716d41e 100644 --- a/lib.c +++ b/lib.c @@ -71,7 +71,7 @@ import_table(pic_state *pic, pic_value spec, xhash *imports) xhash table; pic_value val; pic_sym sym, id, tag; - xh_iter it; + xh_entry *it; xh_init_int(&table, sizeof(pic_sym)); @@ -97,11 +97,10 @@ import_table(pic_state *pic, pic_value spec, xhash *imports) } if (tag == pic->sPREFIX) { import_table(pic, pic_cadr(pic, spec), &table); - xh_begin(&it, &table); - while (xh_next(&it)) { + 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.e, pic_sym)))); - xh_put_int(imports, sym, &xh_val(it.e, pic_sym)); + 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)); } goto exit; } @@ -117,9 +116,8 @@ import_table(pic_state *pic, pic_value spec, xhash *imports) if (! lib) { pic_errorf(pic, "library not found: ~a", spec); } - xh_begin(&it, &lib->exports); - while (xh_next(&it)) { - xh_put_int(imports, xh_key(it.e, pic_sym), &xh_val(it.e, pic_sym)); + 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)); } exit: @@ -130,20 +128,19 @@ static void import(pic_state *pic, pic_value spec) { xhash imports; - xh_iter it; + xh_entry *it; xh_init_int(&imports, sizeof(pic_sym)); /* pic_sym to pic_sym */ import_table(pic, spec, &imports); - xh_begin(&it, &imports); - while (xh_next(&it)) { + 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.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym))); + 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.e, pic_sym), xh_val(it.e, pic_sym)); + pic_put_rename(pic, pic->lib->env, xh_key(it, pic_sym), xh_val(it, pic_sym)); } xh_destroy(&imports); diff --git a/state.c b/state.c index b93559f4..e7300e9c 100644 --- a/state.c +++ b/state.c @@ -177,7 +177,7 @@ pic_open(int argc, char *argv[], char **envp) void pic_close(pic_state *pic) { - xh_iter it; + xh_entry *it; /* invoke exit handlers */ while (pic->blk) { @@ -221,9 +221,8 @@ pic_close(pic_state *pic) free(pic->arena); /* free symbol names */ - xh_begin(&it, &pic->sym_names); - while (xh_next(&it)) { - free(xh_val(it.e, char *)); + for (it = xh_begin(&pic->sym_names); it != NULL; it = xh_next(it)) { + free(xh_val(it, char *)); } xh_destroy(&pic->sym_names); diff --git a/write.c b/write.c index 685a5108..752964a1 100644 --- a/write.c +++ b/write.c @@ -209,8 +209,7 @@ write_core(struct writer_control *p, pic_value obj) pic_state *pic = p->pic; xFILE *file = p->file; size_t i; - xh_entry *e; - xh_iter it; + xh_entry *e, *it; int c; float f; @@ -334,12 +333,11 @@ write_core(struct writer_control *p, pic_value obj) break; case PIC_TT_DICT: xfprintf(file, "#.(dictionary"); - xh_begin(&it, &pic_dict_ptr(obj)->hash); - while (xh_next(&it)) { + for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) { xfprintf(file, " '"); - write_core(p, xh_key(it.e, pic_value)); + write_core(p, xh_key(it, pic_value)); xfprintf(file, " '"); - write_core(p, xh_val(it.e, pic_value)); + write_core(p, xh_val(it, pic_value)); } xfprintf(file, ")"); break; From 33efb3e950b88cbefa9554ce1e4f2f194d388a76 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Sep 2014 23:43:15 +0900 Subject: [PATCH 128/232] remove pic_error --- blob.c | 8 ++++---- char.c | 2 +- codegen.c | 24 ++++++++++++------------ include/picrin.h | 4 ---- macro.c | 14 +++++++------- number.c | 6 +++--- pair.c | 8 ++++---- port.c | 18 +++++++++--------- proc.c | 2 +- string.c | 2 +- symbol.c | 4 ++-- vector.c | 4 ++-- vm.c | 24 ++++++++++++------------ 13 files changed, 58 insertions(+), 62 deletions(-) diff --git a/blob.c b/blob.c index 337e3333..a8f28c9b 100644 --- a/blob.c +++ b/blob.c @@ -64,7 +64,7 @@ pic_blob_bytevector(pic_state *pic) pic_assert_type(pic, argv[i], int); if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) { - pic_error(pic, "byte out of range"); + pic_errorf(pic, "byte out of range"); } *data++ = pic_int(argv[i]); @@ -82,7 +82,7 @@ pic_blob_make_bytevector(pic_state *pic) pic_get_args(pic, "i|i", &k, &b); if (b < 0 || b > 255) - pic_error(pic, "byte out of range"); + pic_errorf(pic, "byte out of range"); blob = pic_make_blob(pic, k); for (i = 0; i < k; ++i) { @@ -122,7 +122,7 @@ pic_blob_bytevector_u8_set(pic_state *pic) pic_get_args(pic, "bii", &bv, &k, &v); if (v < 0 || v > 255) - pic_error(pic, "byte out of range"); + pic_errorf(pic, "byte out of range"); bv->data[k] = v; return pic_none_value(); @@ -227,7 +227,7 @@ pic_blob_list_to_bytevector(pic_state *pic) pic_assert_type(pic, e, int); if (pic_int(e) < 0 || pic_int(e) > 255) - pic_error(pic, "byte out of range"); + pic_errorf(pic, "byte out of range"); *data++ = pic_int(e); } diff --git a/char.c b/char.c index 0dca9f52..a460fb2b 100644 --- a/char.c +++ b/char.c @@ -53,7 +53,7 @@ pic_char_integer_to_char(pic_state *pic) if (pic_char_p(argv[i])) \ d = pic_char(argv[i]); \ else \ - pic_error(pic, #op ": char required"); \ + pic_errorf(pic, #op ": char required"); \ \ if (! (c op d)) \ return pic_false_value(); \ diff --git a/codegen.c b/codegen.c index 34505723..55bb8587 100644 --- a/codegen.c +++ b/codegen.c @@ -425,7 +425,7 @@ analyze_lambda(analyze_state *state, pic_value obj) pic_value formals, body_exprs; if (pic_length(pic, obj) < 2) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } formals = pic_list_ref(pic, obj, 1); @@ -450,12 +450,12 @@ analyze_define(analyze_state *state, pic_value obj) pic_sym sym; if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } var = pic_list_ref(pic, obj, 1); if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } else { sym = pic_sym(var); } @@ -472,7 +472,7 @@ analyze_define(analyze_state *state, pic_value obj) val = analyze_defer(state, pic_sym_value(sym), formals, body_exprs); } else { if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } val = analyze(state, pic_list_ref(pic, obj, 2), false); } @@ -489,7 +489,7 @@ analyze_if(analyze_state *state, pic_value obj, bool tailpos) if_false = pic_none_value(); switch (pic_length(pic, obj)) { default: - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); break; case 4: if_false = pic_list_ref(pic, obj, 3); @@ -539,12 +539,12 @@ analyze_set(analyze_state *state, pic_value obj) pic_value var, val; if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } var = pic_list_ref(pic, obj, 1); if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } val = pic_list_ref(pic, obj, 2); @@ -561,14 +561,14 @@ analyze_quote(analyze_state *state, pic_value obj) pic_state *pic = state->pic; if (pic_length(pic, obj) != 2) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); } #define ARGC_ASSERT_GE(n) do { \ if (pic_length(pic, obj) < (n) + 1) { \ - pic_error(pic, "wrong number of arguments"); \ + pic_errorf(pic, "wrong number of arguments"); \ } \ } while (0) @@ -699,7 +699,7 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) pic_sym call; if (pic_length(pic, obj) != 3) { - pic_error(pic, "wrong number of arguments"); + pic_errorf(pic, "wrong number of arguments"); } if (! tailpos) { @@ -714,7 +714,7 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) #define ARGC_ASSERT(n) do { \ if (pic_length(pic, obj) != (n) + 1) { \ - pic_error(pic, "wrong number of arguments"); \ + pic_errorf(pic, "wrong number of arguments"); \ } \ } while (0) @@ -1413,7 +1413,7 @@ codegen(codegen_state *state, pic_value obj) cxt->clen++; return; } - pic_error(pic, "codegen: unknown AST type"); + pic_errorf(pic, "codegen: unknown AST type"); } static struct pic_irep * diff --git a/include/picrin.h b/include/picrin.h index e726ee4c..e911ff04 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -209,10 +209,6 @@ pic_str *pic_get_backtrace(pic_state *); void pic_print_backtrace(pic_state *, struct pic_error *); /* obsoleted */ -noreturn static inline void pic_error(pic_state *pic, const char *msg) -{ - pic_errorf(pic, msg); -} static inline void pic_warn(pic_state *pic, const char *msg) { pic_warnf(pic, msg); diff --git a/macro.c b/macro.c index 17f12cc6..c7cd243f 100644 --- a/macro.c +++ b/macro.c @@ -161,7 +161,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_value a; if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } in = pic_make_senv(pic, senv); @@ -170,7 +170,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_value v = pic_car(pic, a); if (! pic_sym_p(v)) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } pic_add_rename(pic, in, pic_sym(v)); } @@ -178,7 +178,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_add_rename(pic, in, pic_sym(a)); } else if (! pic_nil_p(a)) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } formal = macroexpand_list(pic, pic_cadr(pic, expr), in); @@ -203,12 +203,12 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) } if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } var = pic_cadr(pic, expr); if (! pic_sym_p(var)) { - pic_error(pic, "binding to non-symbol object"); + pic_errorf(pic, "binding to non-symbol object"); } sym = pic_sym(var); if (! pic_find_rename(pic, senv, sym, &rename)) { @@ -226,12 +226,12 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_sym sym, rename; if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax error"); + pic_errorf(pic, "syntax error"); } var = pic_cadr(pic, expr); if (! pic_sym_p(var)) { - pic_error(pic, "binding to non-symbol object"); + pic_errorf(pic, "binding to non-symbol object"); } sym = pic_sym(var); if (! pic_find_rename(pic, senv, sym, &rename)) { diff --git a/number.c b/number.c index 10dc03aa..4c13df35 100644 --- a/number.c +++ b/number.c @@ -179,7 +179,7 @@ pic_number_nan_p(pic_state *pic) else if (pic_int_p(argv[i])) \ g = pic_int(argv[i]); \ else \ - pic_error(pic, #op ": number required"); \ + pic_errorf(pic, #op ": number required"); \ \ if (! (f op g)) \ return pic_false_value(); \ @@ -216,7 +216,7 @@ DEFINE_ARITH_CMP(>=, ge) f op##= pic_float(argv[i]); \ } \ else { \ - pic_error(pic, #op ": number required"); \ + pic_errorf(pic, #op ": number required"); \ } \ } \ \ @@ -252,7 +252,7 @@ DEFINE_ARITH_OP(*, mul, 1) f op##= pic_float(argv[i]); \ } \ else { \ - pic_error(pic, #op ": number required"); \ + pic_errorf(pic, #op ": number required"); \ } \ } \ \ diff --git a/pair.c b/pair.c index d9960347..0bb0d90e 100644 --- a/pair.c +++ b/pair.c @@ -51,7 +51,7 @@ pic_set_car(pic_state *pic, pic_value obj, pic_value val) struct pic_pair *pair; if (! pic_pair_p(obj)) { - pic_error(pic, "pair required"); + pic_errorf(pic, "pair required"); } pair = pic_pair_ptr(obj); @@ -64,7 +64,7 @@ pic_set_cdr(pic_state *pic, pic_value obj, pic_value val) struct pic_pair *pair; if (! pic_pair_p(obj)) { - pic_error(pic, "pair required"); + pic_errorf(pic, "pair required"); } pair = pic_pair_ptr(obj); @@ -520,7 +520,7 @@ pic_pair_set_car(pic_state *pic) pic_get_args(pic, "oo", &v, &w); if (! pic_pair_p(v)) - pic_error(pic, "pair expected"); + pic_errorf(pic, "pair expected"); pic_pair_ptr(v)->car = w; return pic_none_value(); @@ -534,7 +534,7 @@ pic_pair_set_cdr(pic_state *pic) pic_get_args(pic, "oo", &v, &w); if (! pic_pair_p(v)) - pic_error(pic, "pair expected"); + pic_errorf(pic, "pair expected"); pic_pair_ptr(v)->cdr = w; return pic_none_value(); diff --git a/port.c b/port.c index 859df8a5..558a81b6 100644 --- a/port.c +++ b/port.c @@ -107,7 +107,7 @@ void pic_close_port(pic_state *pic, struct pic_port *port) { if (xfclose(port->file) == EOF) { - pic_error(pic, "close-port: failure"); + pic_errorf(pic, "close-port: failure"); } port->status = PIC_PORT_CLOSE; } @@ -247,25 +247,25 @@ pic_port_close_port(pic_state *pic) if ((port->flags & (flgs)) != (flgs)) { \ switch (flgs) { \ case PIC_PORT_IN: \ - pic_error(pic, caller ": expected output port"); \ + pic_errorf(pic, caller ": expected output port"); \ case PIC_PORT_OUT: \ - pic_error(pic, caller ": expected input port"); \ + pic_errorf(pic, caller ": expected input port"); \ case PIC_PORT_IN | PIC_PORT_TEXT: \ - pic_error(pic, caller ": expected input/textual port"); \ + pic_errorf(pic, caller ": expected input/textual port"); \ case PIC_PORT_IN | PIC_PORT_BINARY: \ - pic_error(pic, caller ": expected input/binary port"); \ + pic_errorf(pic, caller ": expected input/binary port"); \ case PIC_PORT_OUT | PIC_PORT_TEXT: \ - pic_error(pic, caller ": expected output/textual port"); \ + pic_errorf(pic, caller ": expected output/textual port"); \ case PIC_PORT_OUT | PIC_PORT_BINARY: \ - pic_error(pic, caller ": expected output/binary port"); \ + pic_errorf(pic, caller ": expected output/binary port"); \ } \ } \ if (port->status != stat) { \ switch (stat) { \ case PIC_PORT_OPEN: \ - pic_error(pic, caller ": expected open port"); \ + pic_errorf(pic, caller ": expected open port"); \ case PIC_PORT_CLOSE: \ - pic_error(pic, caller ": expected close port"); \ + pic_errorf(pic, caller ": expected close port"); \ } \ } \ } while (0) diff --git a/proc.c b/proc.c index 1dee4813..9702819c 100644 --- a/proc.c +++ b/proc.c @@ -91,7 +91,7 @@ pic_proc_apply(pic_state *pic) pic_get_args(pic, "l*", &proc, &argc, &args); if (argc == 0) { - pic_error(pic, "apply: wrong number of arguments"); + pic_errorf(pic, "apply: wrong number of arguments"); } arg_list = args[--argc]; diff --git a/string.c b/string.c index fc2d2ab6..6876a969 100644 --- a/string.c +++ b/string.c @@ -404,7 +404,7 @@ pic_str_string_append(pic_state *pic) str = pic_make_str(pic, NULL, 0); for (i = 0; i < argc; ++i) { if (! pic_str_p(argv[i])) { - pic_error(pic, "type error"); + pic_errorf(pic, "type error"); } str = pic_strcat(pic, str, pic_str_ptr(argv[i])); } diff --git a/symbol.c b/symbol.c index 7c6479b4..6629abac 100644 --- a/symbol.c +++ b/symbol.c @@ -132,7 +132,7 @@ pic_symbol_symbol_to_string(pic_state *pic) pic_get_args(pic, "o", &v); if (! pic_sym_p(v)) { - pic_error(pic, "symbol->string: expected symbol"); + pic_errorf(pic, "symbol->string: expected symbol"); } return pic_obj_value(pic_make_str_cstr(pic, pic_symbol_name(pic, pic_sym(v)))); @@ -146,7 +146,7 @@ pic_symbol_string_to_symbol(pic_state *pic) pic_get_args(pic, "o", &v); if (! pic_str_p(v)) { - pic_error(pic, "string->symbol: expected string"); + pic_errorf(pic, "string->symbol: expected string"); } return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v)))); diff --git a/vector.c b/vector.c index 4a3e8194..57790b36 100644 --- a/vector.c +++ b/vector.c @@ -105,7 +105,7 @@ pic_vec_vector_ref(pic_state *pic) pic_get_args(pic, "vi", &v, &k); if (k < 0 || v->len <= (size_t)k) { - pic_error(pic, "vector-ref: index out of range"); + pic_errorf(pic, "vector-ref: index out of range"); } return v->data[k]; } @@ -120,7 +120,7 @@ pic_vec_vector_set(pic_state *pic) pic_get_args(pic, "vio", &v, &k, &o); if (k < 0 || v->len <= (size_t)k) { - pic_error(pic, "vector-set!: index out of range"); + pic_errorf(pic, "vector-set!: index out of range"); } v->data[k] = o; return pic_none_value(); diff --git a/vm.c b/vm.c index b84bc96e..609c702f 100644 --- a/vm.c +++ b/vm.c @@ -29,7 +29,7 @@ pic_get_proc(pic_state *pic) pic_value v = GET_OPERAND(pic,0); if (! pic_proc_p(v)) { - pic_error(pic, "fatal error"); + pic_errorf(pic, "fatal error"); } return pic_proc_ptr(v); } @@ -70,7 +70,7 @@ pic_get_args(pic_state *pic, const char *format, ...) switch (c) { default: if (argc <= i && ! opt) { - pic_error(pic, "wrong number of arguments"); + pic_errorf(pic, "wrong number of arguments"); } break; case '|': @@ -375,7 +375,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *e = pic_error_ptr(v); } else { - pic_error(pic, "pic_get_args, expected error"); + pic_errorf(pic, "pic_get_args, expected error"); } i++; } @@ -398,7 +398,7 @@ pic_get_args(pic_state *pic, const char *format, ...) } } else if (argc > i) { - pic_error(pic, "wrong number of arguments"); + pic_errorf(pic, "wrong number of arguments"); } va_end(ap); return i - 1; @@ -675,7 +675,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) #endif if (! pic_list_p(argv)) { - pic_error(pic, "argv must be a proper list"); + pic_errorf(pic, "argv must be a proper list"); } argc = pic_length(pic, argv) + 1; @@ -728,11 +728,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) self = pic->ci->fp[0]; if (! pic_proc_p(self)) { - pic_error(pic, "logic flaw"); + pic_errorf(pic, "logic flaw"); } irep = pic_proc_ptr(self)->u.irep; if (! pic_proc_irep_p(pic_proc_ptr(self))) { - pic_error(pic, "logic flaw"); + pic_errorf(pic, "logic flaw"); } PUSH(irep->pool[c.u.i]); NEXT; @@ -950,11 +950,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) self = pic->ci->fp[0]; if (! pic_proc_p(self)) { - pic_error(pic, "logic flaw"); + pic_errorf(pic, "logic flaw"); } irep = pic_proc_ptr(self)->u.irep; if (! pic_proc_irep_p(pic_proc_ptr(self))) { - pic_error(pic, "logic flaw"); + pic_errorf(pic, "logic flaw"); } if (pic->ci->env == NULL) { @@ -1017,7 +1017,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) PUSH(pic_float_value(pic_float(a) op pic_int(b))); \ } \ else { \ - pic_error(pic, #op " got non-number operands"); \ + pic_errorf(pic, #op " got non-number operands"); \ } \ NEXT; \ } @@ -1037,7 +1037,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) PUSH(pic_float_value(-pic_float(n))); } else { - pic_error(pic, "unary - got a non-number operand"); + pic_errorf(pic, "unary - got a non-number operand"); } NEXT; } @@ -1060,7 +1060,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \ } \ else { \ - pic_error(pic, #op " got non-number operands"); \ + pic_errorf(pic, #op " got non-number operands"); \ } \ NEXT; \ } From 78a982fb4148d1c5dcd8ec24a8d3d0a36f5d3ccb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 00:28:55 +0900 Subject: [PATCH 129/232] refactor error object --- debug.c | 41 +++++++++++++---------------- error.c | 60 +++++++++++++++++++++++++----------------- file.c | 2 +- gc.c | 4 +-- include/picrin.h | 5 ++-- include/picrin/error.h | 14 ++++------ include/picrin/value.h | 1 + lib.c | 2 +- read.c | 2 +- state.c | 6 +++-- 10 files changed, 71 insertions(+), 66 deletions(-) diff --git a/debug.c b/debug.c index 09c70553..3d7b92c6 100644 --- a/debug.c +++ b/debug.c @@ -36,37 +36,32 @@ pic_get_backtrace(pic_state *pic) } void -pic_print_backtrace(pic_state *pic, struct pic_error *e) +pic_print_backtrace(pic_state *pic) { size_t ai = pic_gc_arena_preserve(pic); pic_str *trace; - assert(pic->err != NULL); + assert(! pic_undef_p(pic->err)); - trace = pic_make_str(pic, NULL, 0); + if (! pic_error_p(pic->err)) { + trace = pic_format(pic, "raised: ~s", pic->err); + } else { + struct pic_error *e; - switch (e->type) { - case PIC_ERROR_OTHER: - trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "error: ")); - break; - case PIC_ERROR_FILE: - trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "file error: ")); - break; - case PIC_ERROR_READ: - trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "read error: ")); - break; - case PIC_ERROR_RAISED: - trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "raised: ")); - break; + 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); + } + trace = pic_strcat(pic, trace, pic_format(pic, "error: ~s", pic_obj_value(e->msg))); + + /* TODO: print error irritants */ + + trace = pic_strcat(pic, trace, pic_make_str(pic, "\n", 1)); + trace = pic_strcat(pic, trace, e->stack); } - trace = pic_strcat(pic, trace, e->msg); - - /* TODO: print error irritants */ - - trace = pic_strcat(pic, trace, pic_make_str(pic, "\n", 1)); - trace = pic_strcat(pic, trace, e->stack); - /* print! */ printf("%s", pic_str_cstr(trace)); diff --git a/error.c b/error.c index d5596a7b..dad4a604 100644 --- a/error.c +++ b/error.c @@ -89,37 +89,51 @@ make_error(pic_state *pic, short type, pic_str *msg, pic_value irrs) } noreturn void -pic_throw_error(pic_state *pic, struct pic_error *e) +pic_raise(pic_state *pic, pic_value err) { void pic_vm_tear_off(pic_state *); pic_vm_tear_off(pic); /* tear off */ - pic->err = e; + pic->err = err; if (! pic->jmp) { puts(pic_errmsg(pic)); - abort(); + pic_abort(pic, "no handler found on stack"); } longjmp(*pic->jmp, 1); } noreturn void -pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs) +pic_throw(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) { struct pic_error *e; e = make_error(pic, type, pic_make_str_cstr(pic, msg), irrs); - pic_throw_error(pic, e); + pic_raise(pic, pic_obj_value(e)); +} + +noreturn void +pic_error(pic_state *pic, const char *msg, pic_value irrs) +{ + pic_throw(pic, pic_intern_cstr(pic, ""), msg, irrs); } const char * pic_errmsg(pic_state *pic) { - assert(pic->err != NULL); + pic_str *str; - return pic_str_cstr(pic->err->msg); + assert(! pic_undef_p(pic->err)); + + if (! pic_error_p(pic->err)) { + str = pic_format(pic, "~s", pic->err); + } else { + str = pic_error_ptr(pic->err)->msg; + } + + return pic_str_cstr(str); } void @@ -136,34 +150,30 @@ pic_errorf(pic_state *pic, const char *fmt, ...) msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))); irrs = pic_cdr(pic, err_line); - pic_throw(pic, PIC_ERROR_OTHER, msg, irrs); + pic_error(pic, msg, irrs); } static pic_value pic_error_with_exception_handler(pic_state *pic) { struct pic_proc *handler, *thunk; - pic_value v; + pic_value val; pic_get_args(pic, "ll", &handler, &thunk); pic_try_with_handler(handler) { - v = pic_apply0(pic, thunk); + val = pic_apply0(pic, thunk); } pic_catch { - struct pic_error *e = pic->err; + pic_value e = pic->err; - pic->err = NULL; + pic->err = pic_undef_value(); - if (e->type == PIC_ERROR_RAISED) { - v = pic_list_ref(pic, e->irrs, 0); - } else { - v = pic_obj_value(e); - } - v = pic_apply1(pic, handler, v); - pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e)); + val = pic_apply1(pic, handler, e); + + pic_errorf(pic, "error handler returned with ~s on error ~s", val, e); } - return v; + return val; } noreturn static pic_value @@ -173,7 +183,7 @@ pic_error_raise(pic_state *pic) pic_get_args(pic, "o", &v); - pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v)); + pic_raise(pic, v); } static pic_value @@ -206,7 +216,7 @@ pic_error_error(pic_state *pic) pic_get_args(pic, "z*", &str, &argc, &argv); - pic_throw(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv)); + pic_error(pic, str, pic_list_by_array(pic, argc, argv)); } static pic_value @@ -252,7 +262,8 @@ pic_error_read_error_p(pic_state *pic) } e = pic_error_ptr(v); - return pic_bool_value(e->type == PIC_ERROR_READ); + + return pic_bool_value(e->type == pic->sREAD); } static pic_value @@ -268,7 +279,8 @@ pic_error_file_error_p(pic_state *pic) } e = pic_error_ptr(v); - return pic_bool_value(e->type == PIC_ERROR_FILE); + + return pic_bool_value(e->type == pic->sFILE); } void diff --git a/file.c b/file.c index cfc266b5..4a5f57d7 100644 --- a/file.c +++ b/file.c @@ -9,7 +9,7 @@ static noreturn void file_error(pic_state *pic, const char *msg) { - pic_throw(pic, PIC_ERROR_FILE, msg, pic_nil_value()); + pic_throw(pic, pic->sFILE, msg, pic_nil_value()); } static pic_value diff --git a/gc.c b/gc.c index ba0e23d7..bb241a43 100644 --- a/gc.c +++ b/gc.c @@ -580,9 +580,7 @@ gc_mark_phase(pic_state *pic) } /* error object */ - if (pic->err) { - gc_mark_object(pic, (struct pic_object *)pic->err); - } + gc_mark(pic, pic->err); /* arena */ for (j = 0; j < pic->arena_idx; ++j) { diff --git a/include/picrin.h b/include/picrin.h index e911ff04..fe564822 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -81,6 +81,7 @@ typedef struct { pic_sym sCONS, sCAR, sCDR, sNILP; pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; + pic_sym sREAD, sFILE; pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT; @@ -104,7 +105,7 @@ typedef struct { struct pic_reader *reader; jmp_buf *jmp; - struct pic_error *err; + pic_value err; struct pic_jmpbuf *try_jmps; size_t try_jmp_size, try_jmp_idx; @@ -206,7 +207,7 @@ noreturn void pic_abort(pic_state *, const char *); noreturn void pic_errorf(pic_state *, const char *, ...); void pic_warnf(pic_state *, const char *, ...); pic_str *pic_get_backtrace(pic_state *); -void pic_print_backtrace(pic_state *, struct pic_error *); +void pic_print_backtrace(pic_state *); /* obsoleted */ static inline void pic_warn(pic_state *pic, const char *msg) diff --git a/include/picrin/error.h b/include/picrin/error.h index 5005346a..f61f8082 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -34,18 +34,14 @@ struct pic_jmpbuf { void pic_push_try(pic_state *, struct pic_proc *); void pic_pop_try(pic_state *); -noreturn void pic_throw(pic_state *, short, const char *, pic_value); -noreturn void pic_throw_error(pic_state *, struct pic_error *); +noreturn void pic_raise(pic_state *, pic_value); +noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list); +noreturn void pic_error(pic_state *, const char *, pic_list); struct pic_error { PIC_OBJECT_HEADER - enum pic_error_kind { - PIC_ERROR_OTHER, - PIC_ERROR_FILE, - PIC_ERROR_READ, - PIC_ERROR_RAISED - } type; - struct pic_string *msg; + pic_sym type; + pic_str *msg; pic_value irrs; pic_str *stack; }; diff --git a/include/picrin/value.h b/include/picrin/value.h index 0523c688..6a211dc1 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -142,6 +142,7 @@ struct pic_blob; struct pic_proc; struct pic_port; +struct pic_error; /* set aliases to basic types */ typedef pic_value pic_list; diff --git a/lib.c b/lib.c index b716d41e..cb1843d8 100644 --- a/lib.c +++ b/lib.c @@ -318,7 +318,7 @@ pic_lib_define_library(pic_state *pic) } pic_catch { pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */ - pic_throw_error(pic, pic->err); + pic_raise(pic, pic->err); } return pic_none_value(); diff --git a/read.c b/read.c index ad23436f..7deb5eb2 100644 --- a/read.c +++ b/read.c @@ -21,7 +21,7 @@ static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c); static noreturn void read_error(pic_state *pic, const char *msg) { - pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value()); + pic_throw(pic, pic->sREAD, msg, pic_nil_value()); } static int diff --git a/state.c b/state.c index e7300e9c..b88f40a1 100644 --- a/state.c +++ b/state.c @@ -72,7 +72,7 @@ pic_open(int argc, char *argv[], char **envp) /* error handling */ pic->jmp = NULL; - pic->err = NULL; + pic->err = pic_undef_value(); pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf)); pic->try_jmp_idx = 0; pic->try_jmp_size = PIC_RESCUE_SIZE; @@ -131,6 +131,8 @@ pic_open(int argc, char *argv[], char **envp) S(sGT, ">"); S(sGE, ">="); S(sNOT, "not"); + S(sREAD, "read"); + S(sFILE, "file"); pic_gc_arena_restore(pic, ai); #define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); @@ -191,7 +193,7 @@ pic_close(pic_state *pic) pic->sp = pic->stbase; pic->ci = pic->cibase; pic->arena_idx = 0; - pic->err = NULL; + pic->err = pic_undef_value(); xh_clear(&pic->macros); pic->features = pic_nil_value(); pic->libs = pic_nil_value(); From 486c99bf6fdebf453c3aa2199c4c48715e50828e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 00:32:52 +0900 Subject: [PATCH 130/232] [bugfix] 'type' field is now of pic_sym type --- error.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/error.c b/error.c index dad4a604..82f7f968 100644 --- a/error.c +++ b/error.c @@ -72,7 +72,7 @@ pic_pop_try(pic_state *pic) } static struct pic_error * -make_error(pic_state *pic, short type, pic_str *msg, pic_value irrs) +make_error(pic_state *pic, pic_sym type, pic_str *msg, pic_value irrs) { struct pic_error *e; pic_str *stack; From 061ddb58eed60a6c02dc0ed6ebb9874367865602 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 00:43:03 +0900 Subject: [PATCH 131/232] publish pic_make_error --- error.c | 8 ++++---- include/picrin/error.h | 2 ++ 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/error.c b/error.c index 82f7f968..468935c3 100644 --- a/error.c +++ b/error.c @@ -71,8 +71,8 @@ pic_pop_try(pic_state *pic) pic->jmp = try_jmp->prev_jmp; } -static struct pic_error * -make_error(pic_state *pic, pic_sym type, pic_str *msg, pic_value irrs) +struct pic_error * +pic_make_error(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) { struct pic_error *e; pic_str *stack; @@ -81,7 +81,7 @@ make_error(pic_state *pic, pic_sym type, pic_str *msg, pic_value irrs) e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR); e->type = type; - e->msg = msg; + e->msg = pic_make_str_cstr(pic, msg); e->irrs = irrs; e->stack = stack; @@ -109,7 +109,7 @@ pic_throw(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) { struct pic_error *e; - e = make_error(pic, type, pic_make_str_cstr(pic, msg), irrs); + e = pic_make_error(pic, type, msg, irrs); pic_raise(pic, pic_obj_value(e)); } diff --git a/include/picrin/error.h b/include/picrin/error.h index f61f8082..1b96f3ee 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -49,6 +49,8 @@ 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); + #if defined(__cplusplus) } #endif From 854f83a247b6f980c9db9462c9f8d088fa58f9ef Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 00:43:12 +0900 Subject: [PATCH 132/232] add make-error-object procedure --- error.c | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/error.c b/error.c index 468935c3..276fc7d1 100644 --- a/error.c +++ b/error.c @@ -219,6 +219,22 @@ pic_error_error(pic_state *pic) pic_error(pic, str, pic_list_by_array(pic, argc, argv)); } +static pic_value +pic_error_make_error_object(pic_state *pic) +{ + struct pic_error *e; + 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)); + + return pic_obj_value(e); +} + static pic_value pic_error_error_object_p(pic_state *pic) { @@ -290,6 +306,7 @@ pic_init_error(pic_state *pic) pic_defun(pic, "raise", pic_error_raise); pic_defun(pic, "raise-continuable", pic_error_raise_continuable); pic_defun(pic, "error", pic_error_error); + pic_defun(pic, "make-error-object", pic_error_make_error_object); pic_defun(pic, "error-object?", pic_error_error_object_p); pic_defun(pic, "error-object-message", pic_error_error_object_message); pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants); From 05e76c0467af886f2cd88d2f6ad3d008dc64e73d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 00:49:37 +0900 Subject: [PATCH 133/232] remove read-error? and file-error? and add error-object-type instead --- error.c | 33 ++++----------------------------- 1 file changed, 4 insertions(+), 29 deletions(-) diff --git a/error.c b/error.c index 276fc7d1..054a780a 100644 --- a/error.c +++ b/error.c @@ -266,37 +266,13 @@ pic_error_error_object_irritants(pic_state *pic) } static pic_value -pic_error_read_error_p(pic_state *pic) +pic_error_error_object_type(pic_state *pic) { - pic_value v; struct pic_error *e; - pic_get_args(pic, "o", &v); + pic_get_args(pic, "e", &e); - if (! pic_error_p(v)) { - return pic_false_value(); - } - - e = pic_error_ptr(v); - - return pic_bool_value(e->type == pic->sREAD); -} - -static pic_value -pic_error_file_error_p(pic_state *pic) -{ - pic_value v; - struct pic_error *e; - - pic_get_args(pic, "o", &v); - - if (! pic_error_p(v)) { - return pic_false_value(); - } - - e = pic_error_ptr(v); - - return pic_bool_value(e->type == pic->sFILE); + return pic_sym_value(e->type); } void @@ -310,6 +286,5 @@ pic_init_error(pic_state *pic) pic_defun(pic, "error-object?", pic_error_error_object_p); pic_defun(pic, "error-object-message", pic_error_error_object_message); pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants); - pic_defun(pic, "read-error?", pic_error_read_error_p); - pic_defun(pic, "file-error?", pic_error_file_error_p); + pic_defun(pic, "error-object-type", pic_error_error_object_type); } From 565ee431af73649d417e9de77e17240d9c4392b4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 01:02:27 +0900 Subject: [PATCH 134/232] s/pic_abort/pic_panic/g --- error.c | 4 ++-- gc.c | 12 ++++++------ include/picrin.h | 2 +- symbol.c | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/error.c b/error.c index 054a780a..bc618630 100644 --- a/error.c +++ b/error.c @@ -12,7 +12,7 @@ #include "picrin/error.h" void -pic_abort(pic_state *pic, const char *msg) +pic_panic(pic_state *pic, const char *msg) { UNUSED(pic); @@ -98,7 +98,7 @@ pic_raise(pic_state *pic, pic_value err) pic->err = err; if (! pic->jmp) { puts(pic_errmsg(pic)); - pic_abort(pic, "no handler found on stack"); + pic_panic(pic, "no handler found on stack"); } longjmp(*pic->jmp, 1); diff --git a/gc.c b/gc.c index bb241a43..6712dd9e 100644 --- a/gc.c +++ b/gc.c @@ -138,7 +138,7 @@ pic_alloc(pic_state *pic, size_t size) ptr = alloc(NULL, size); if (ptr == NULL && size > 0) { - pic_abort(pic, "memory exhausted"); + pic_panic(pic, "memory exhausted"); } return ptr; } @@ -148,7 +148,7 @@ pic_realloc(pic_state *pic, void *ptr, size_t size) { ptr = alloc(ptr, size); if (ptr == NULL && size > 0) { - pic_abort(pic, "memory exhausted"); + pic_panic(pic, "memory exhausted"); } return ptr; } @@ -161,7 +161,7 @@ pic_calloc(pic_state *pic, size_t count, size_t size) size *= count; ptr = alloc(NULL, size); if (ptr == NULL && size > 0) { - pic_abort(pic, "memory exhausted"); + pic_panic(pic, "memory exhausted"); } memset(ptr, 0, size); return ptr; @@ -523,7 +523,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_CHAR: case PIC_TT_EOF: case PIC_TT_UNDEF: - pic_abort(pic, "logic flaw"); + pic_panic(pic, "logic flaw"); } } @@ -717,7 +717,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) case PIC_TT_CHAR: case PIC_TT_EOF: case PIC_TT_UNDEF: - pic_abort(pic, "logic flaw"); + pic_panic(pic, "logic flaw"); } } @@ -846,7 +846,7 @@ pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt) add_heap_page(pic); obj = (struct pic_object *)gc_alloc(pic, size); if (obj == NULL) - pic_abort(pic, "GC memory exhausted"); + pic_panic(pic, "GC memory exhausted"); } } obj->tt = tt; diff --git a/include/picrin.h b/include/picrin.h index fe564822..3df0c538 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -203,7 +203,7 @@ void pic_import(pic_state *, pic_value); void pic_import_library(pic_state *, struct pic_lib *); void pic_export(pic_state *, pic_sym); -noreturn void pic_abort(pic_state *, const char *); +noreturn void pic_panic(pic_state *, const char *); noreturn void pic_errorf(pic_state *, const char *, ...); void pic_warnf(pic_state *, const char *, ...); pic_str *pic_get_backtrace(pic_state *); diff --git a/symbol.c b/symbol.c index 6629abac..c15a967d 100644 --- a/symbol.c +++ b/symbol.c @@ -78,7 +78,7 @@ pic_ungensym(pic_state *pic, pic_sym base) name = pic_symbol_name(pic, base); if ((occr = strrchr(name, '@')) == NULL) { - pic_abort(pic, "logic flaw"); + pic_panic(pic, "logic flaw"); } return pic_intern(pic, name, occr - name); } From dbbc2c1a25e32524ff087e657aab982f4d451e9c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 01:07:25 +0900 Subject: [PATCH 135/232] inline pic_car and pic_cdr --- include/picrin/pair.h | 28 ++++++++++++++++++++++++++-- pair.c | 34 ++-------------------------------- 2 files changed, 28 insertions(+), 34 deletions(-) diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 89cfe938..16c61863 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -18,9 +18,33 @@ 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_car(pic_state *pic, pic_value obj) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_errorf(pic, "pair required, but got ~s", obj); + } + pair = pic_pair_ptr(obj); + + return pair->car; +} + +static inline pic_value +pic_cdr(pic_state *pic, pic_value obj) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_errorf(pic, "pair required, but got ~s", obj); + } + pair = pic_pair_ptr(obj); + + return pair->cdr; +} + pic_value pic_cons(pic_state *, pic_value, pic_value); -pic_value pic_car(pic_state *, pic_value); -pic_value pic_cdr(pic_state *, pic_value); void pic_set_car(pic_state *, pic_value, pic_value); void pic_set_cdr(pic_state *, pic_value, pic_value); diff --git a/pair.c b/pair.c index 0bb0d90e..ee2263c7 100644 --- a/pair.c +++ b/pair.c @@ -19,32 +19,6 @@ pic_cons(pic_state *pic, pic_value car, pic_value cdr) return pic_obj_value(pair); } -pic_value -pic_car(pic_state *pic, pic_value obj) -{ - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_errorf(pic, "pair required, but got ~s", obj); - } - pair = pic_pair_ptr(obj); - - return pair->car; -} - -pic_value -pic_cdr(pic_state *pic, pic_value obj) -{ - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_errorf(pic, "pair required, but got ~s", obj); - } - pair = pic_pair_ptr(obj); - - return pair->cdr; -} - void pic_set_car(pic_state *pic, pic_value obj, pic_value val) { @@ -519,10 +493,8 @@ pic_pair_set_car(pic_state *pic) pic_get_args(pic, "oo", &v, &w); - if (! pic_pair_p(v)) - pic_errorf(pic, "pair expected"); + pic_set_car(pic, v, w); - pic_pair_ptr(v)->car = w; return pic_none_value(); } @@ -533,10 +505,8 @@ pic_pair_set_cdr(pic_state *pic) pic_get_args(pic, "oo", &v, &w); - if (! pic_pair_p(v)) - pic_errorf(pic, "pair expected"); + pic_set_cdr(pic, v, w); - pic_pair_ptr(v)->cdr = w; return pic_none_value(); } From e7c9b15d1f8ea61d4079264744c3bfff2d8467b8 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 03:40:10 +0900 Subject: [PATCH 136/232] import (picrin base) to (picrin user) by default --- README.md | 2 -- init.c | 2 ++ 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 37fc4165..ed7e26d5 100644 --- a/README.md +++ b/README.md @@ -21,8 +21,6 @@ main(int argc, char *argv[]) pic = pic_open(argc, argv, NULL); - pic_import_library(pic, pic->PICRIN_BASE); - while (1) { printf("> "); diff --git a/init.c b/init.c index 52ff2272..33c4e084 100644 --- a/init.c +++ b/init.c @@ -141,4 +141,6 @@ pic_init_core(pic_state *pic) pic_load_cstr(pic, pic_boot); } + + pic_import_library(pic, pic->PICRIN_BASE); } From de854c0d471dd1de4e5dc7ae3429bb9fb8fd3b69 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 04:00:17 +0900 Subject: [PATCH 137/232] add "more example" --- README.md | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/README.md b/README.md index ed7e26d5..ce4188a0 100644 --- a/README.md +++ b/README.md @@ -39,6 +39,40 @@ main(int argc, char *argv[]) } ``` +## More Example + +Function binding is also easy. `pic_defun` defines a scheme procedure converting from a C function. In the native function, callee arguments can be taken with `pic_get_args`. `pic_get_args` gets arguments according to the format string. If actual arguments does not match a number or incompatible types, it will raise an exception. + +```c +#include "picrin.h" + +int fact(int i) { + return i == 1 ? 1 : i * fact(i - 1); +} + +pic_value factorial(pic_state *pic) { + int i; + + pic_get_args(pic, "i", &i); + + return pic_int_value(fact(i)); +} + +int +main(int argc, char *argv[]) +{ + pic_state *pic = pic_open(argc, argv, NULL); + + pic_defun(pic, "fact", factorial); /* define fact procedure */ + + pic_load_cstr(pic, "(display (fact 10))"); + + pic_close(pic); + + return 0; +} +``` + ## Language All procedures and syntaces are exported from a single library named `(picrin base)`. The complete list is found at https://gist.github.com/wasabiz/344d802a2340d1f734b7 . From b4c3f4fb730335d091becb0f62419fa0db4ab301 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 15:09:15 +0900 Subject: [PATCH 138/232] pic_block -> pic_winder --- cont.c | 26 ++++++++++++-------------- gc.c | 41 +++++++++++++++++++---------------------- include/picrin.h | 9 ++++++++- include/picrin/cont.h | 9 +-------- include/picrin/value.h | 3 --- state.c | 18 +++++++++--------- 6 files changed, 49 insertions(+), 57 deletions(-) diff --git a/cont.c b/cont.c index 695e39b0..c542399d 100644 --- a/cont.c +++ b/cont.c @@ -121,7 +121,7 @@ save_cont(pic_state *pic, struct pic_cont **c) cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT); - cont->blk = pic->blk; + cont->wind = pic->wind; cont->stk_len = native_stack_length(pic, &pos); cont->stk_pos = pos; @@ -168,7 +168,6 @@ restore_cont(pic_state *pic, struct pic_cont *cont) { char v; struct pic_cont *tmp = cont; - struct pic_block *blk; if (&v < pic->native_stack_start) { if (&v > cont->stk_pos) native_stack_extend(pic, cont); @@ -177,8 +176,7 @@ restore_cont(pic_state *pic, struct pic_cont *cont) if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); } - blk = pic->blk; - pic->blk = cont->blk; + pic->wind = cont->wind; pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len); memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len); @@ -208,7 +206,7 @@ restore_cont(pic_state *pic, struct pic_cont *cont) } static void -walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there) +walk_to_block(pic_state *pic, struct pic_winder *here, struct pic_winder *there) { if (here == there) return; @@ -226,23 +224,23 @@ walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there) static pic_value pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out) { - struct pic_block *here; + struct pic_winder *here; pic_value val; if (in != NULL) { pic_apply0(pic, in); /* enter */ } - here = pic->blk; - pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK); - pic->blk->prev = here; - pic->blk->depth = here->depth + 1; - pic->blk->in = in; - pic->blk->out = out; + 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; val = pic_apply0(pic, thunk); - pic->blk = here; + pic->wind = here; if (out != NULL) { pic_apply0(pic, out); /* exit */ @@ -266,7 +264,7 @@ cont_call(pic_state *pic) cont->results = pic_list_by_array(pic, argc, argv); /* execute guard handlers */ - walk_to_block(pic, pic->blk, cont->blk); + walk_to_block(pic, pic->wind, cont->wind); restore_cont(pic, cont); } diff --git a/gc.c b/gc.c index 38be3150..15304788 100644 --- a/gc.c +++ b/gc.c @@ -333,6 +333,20 @@ gc_unmark(union header *p) p->s.mark = PIC_GC_UNMARK; } +static void +gc_mark_winder(pic_state *pic, struct pic_winder *wind) +{ + if (wind->prev) { + gc_mark_object(pic, (struct pic_object *)wind->prev); + } + if (wind->in) { + gc_mark_object(pic, (struct pic_object *)wind->in); + } + if (wind->out) { + gc_mark_object(pic, (struct pic_object *)wind->out); + } +} + static void gc_mark_object(pic_state *pic, struct pic_object *obj) { @@ -404,8 +418,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) pic_callinfo *ci; size_t i; - /* block */ - gc_mark_object(pic, (struct pic_object *)cont->blk); + /* winder */ + gc_mark_winder(pic, cont->wind); /* stack */ for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) { @@ -504,20 +518,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } break; } - case PIC_TT_BLK: { - struct pic_block *blk = (struct pic_block *)obj; - - if (blk->prev) { - gc_mark_object(pic, (struct pic_object *)blk->prev); - } - if (blk->in) { - gc_mark_object(pic, (struct pic_object *)blk->in); - } - if (blk->out) { - gc_mark_object(pic, (struct pic_object *)blk->out); - } - break; - } case PIC_TT_NIL: case PIC_TT_BOOL: case PIC_TT_FLOAT: @@ -565,9 +565,9 @@ gc_mark_phase(pic_state *pic) size_t i, j; xh_entry *it; - /* block */ - if (pic->blk) { - gc_mark_object(pic, (struct pic_object *)pic->blk); + /* winder */ + if (pic->wind) { + gc_mark_winder(pic, pic->wind); } /* stack */ @@ -709,9 +709,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) xh_destroy(&rec->hash); break; } - case PIC_TT_BLK: { - break; - } case PIC_TT_NIL: case PIC_TT_BOOL: case PIC_TT_FLOAT: diff --git a/include/picrin.h b/include/picrin.h index 3df0c538..5bec9eb0 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -46,6 +46,13 @@ extern "C" { typedef struct pic_code pic_code; +struct pic_winder { + struct pic_proc *in; + struct pic_proc *out; + int depth; + struct pic_winder *prev; +}; + typedef struct { int argc, retc; pic_code *ip; @@ -60,7 +67,7 @@ typedef struct { int argc; char **argv, **envp; - struct pic_block *blk; + struct pic_winder *wind; pic_value *sp; pic_value *stbase, *stend; diff --git a/include/picrin/cont.h b/include/picrin/cont.h index eeabb798..587a46d1 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -9,18 +9,11 @@ extern "C" { #endif -struct pic_block { - PIC_OBJECT_HEADER - struct pic_block *prev; - int depth; - struct pic_proc *in, *out; -}; - struct pic_cont { PIC_OBJECT_HEADER jmp_buf jmp; - struct pic_block *blk; + struct pic_winder *wind; char *stk_pos, *stk_ptr; ptrdiff_t stk_len; diff --git a/include/picrin/value.h b/include/picrin/value.h index 6a211dc1..453e645a 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -125,7 +125,6 @@ enum pic_tt { PIC_TT_DATA, PIC_TT_DICT, PIC_TT_RECORD, - PIC_TT_BLK, }; #define PIC_OBJECT_HEADER \ @@ -274,8 +273,6 @@ pic_type_repr(enum pic_tt tt) return "dict"; case PIC_TT_RECORD: return "record"; - case PIC_TT_BLK: - return "block"; } UNREACHABLE(); } diff --git a/state.c b/state.c index b88f40a1..df9ba02c 100644 --- a/state.c +++ b/state.c @@ -27,7 +27,7 @@ pic_open(int argc, char *argv[], char **envp) pic = malloc(sizeof(pic_state)); /* root block */ - pic->blk = NULL; + pic->wind = NULL; /* command line */ pic->argc = argc; @@ -153,10 +153,10 @@ pic_open(int argc, char *argv[], char **envp) pic_gc_arena_restore(pic, ai); /* root block */ - pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK); - pic->blk->prev = NULL; - pic->blk->depth = 0; - pic->blk->in = pic->blk->out = NULL; + pic->wind = pic_alloc(pic, sizeof(struct pic_winder)); + pic->wind->prev = NULL; + pic->wind->depth = 0; + pic->wind->in = pic->wind->out = NULL; /* init readers */ pic_init_reader(pic); @@ -182,11 +182,11 @@ pic_close(pic_state *pic) xh_entry *it; /* invoke exit handlers */ - while (pic->blk) { - if (pic->blk->out) { - pic_apply0(pic, pic->blk->out); + while (pic->wind) { + if (pic->wind->out) { + pic_apply0(pic, pic->wind->out); } - pic->blk = pic->blk->prev; + pic->wind = pic->wind->prev; } /* clear out root objects */ From 836c60797970b6b320b9cfc7f41c096e7df557f3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 15:26:42 +0900 Subject: [PATCH 139/232] s/walk_to_block/pic_wind/g --- cont.c | 10 +++++----- include/picrin/cont.h | 1 + 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/cont.c b/cont.c index c542399d..8fba3c78 100644 --- a/cont.c +++ b/cont.c @@ -205,19 +205,19 @@ restore_cont(pic_state *pic, struct pic_cont *cont) longjmp(tmp->jmp, 1); } -static void -walk_to_block(pic_state *pic, struct pic_winder *here, struct pic_winder *there) +void +pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there) { if (here == there) return; if (here->depth < there->depth) { - walk_to_block(pic, here, there->prev); + pic_wind(pic, here, there->prev); pic_apply0(pic, there->in); } else { pic_apply0(pic, there->out); - walk_to_block(pic, here->prev, there); + pic_wind(pic, here->prev, there); } } @@ -264,7 +264,7 @@ cont_call(pic_state *pic) cont->results = pic_list_by_array(pic, argc, argv); /* execute guard handlers */ - walk_to_block(pic, pic->wind, cont->wind); + pic_wind(pic, pic->wind, cont->wind); restore_cont(pic, cont); } diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 587a46d1..740a1175 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -47,6 +47,7 @@ pic_value pic_values_by_list(pic_state *, pic_value); size_t pic_receive(pic_state *, size_t, pic_value *); pic_value pic_callcc(pic_state *, struct pic_proc *); +void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *); #if defined(__cplusplus) } From a17e79a1606d84042cf2ce9950b488459a518049 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 21:58:51 +0900 Subject: [PATCH 140/232] add pic_raise_continuable --- error.c | 98 +++++++++++++++++++++++------------------- include/picrin/error.h | 1 + 2 files changed, 54 insertions(+), 45 deletions(-) diff --git a/error.c b/error.c index bc618630..feaefa92 100644 --- a/error.c +++ b/error.c @@ -33,6 +33,39 @@ pic_warnf(pic_state *pic, const char *fmt, ...) fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)))); } +void +pic_errorf(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_value err_line, irrs; + const char *msg; + + va_start(ap, fmt); + err_line = pic_xvformat(pic, fmt, ap); + va_end(ap); + + msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))); + irrs = pic_cdr(pic, err_line); + + pic_error(pic, msg, irrs); +} + +const char * +pic_errmsg(pic_state *pic) +{ + pic_str *str; + + assert(! pic_undef_p(pic->err)); + + if (! pic_error_p(pic->err)) { + str = pic_format(pic, "~s", pic->err); + } else { + str = pic_error_ptr(pic->err)->msg; + } + + return pic_str_cstr(str); +} + void pic_push_try(pic_state *pic, struct pic_proc *handler) { @@ -88,6 +121,25 @@ pic_make_error(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) return e; } +pic_value +pic_raise_continuable(pic_state *pic, pic_value err) +{ + pic_value v; + + if (pic->try_jmp_idx == 0) { + pic_errorf(pic, "no exception handler registered"); + } + if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) { + pic_errorf(pic, "uncontinuable exception handler is on top"); + } + else { + pic->try_jmp_idx--; + v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, err); + ++pic->try_jmp_idx; + } + return v; +} + noreturn void pic_raise(pic_state *pic, pic_value err) { @@ -120,39 +172,6 @@ pic_error(pic_state *pic, const char *msg, pic_value irrs) pic_throw(pic, pic_intern_cstr(pic, ""), msg, irrs); } -const char * -pic_errmsg(pic_state *pic) -{ - pic_str *str; - - assert(! pic_undef_p(pic->err)); - - if (! pic_error_p(pic->err)) { - str = pic_format(pic, "~s", pic->err); - } else { - str = pic_error_ptr(pic->err)->msg; - } - - return pic_str_cstr(str); -} - -void -pic_errorf(pic_state *pic, const char *fmt, ...) -{ - va_list ap; - pic_value err_line, irrs; - const char *msg; - - va_start(ap, fmt); - err_line = pic_xvformat(pic, fmt, ap); - va_end(ap); - - msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))); - irrs = pic_cdr(pic, err_line); - - pic_error(pic, msg, irrs); -} - static pic_value pic_error_with_exception_handler(pic_state *pic) { @@ -193,18 +212,7 @@ pic_error_raise_continuable(pic_state *pic) pic_get_args(pic, "o", &v); - if (pic->try_jmp_idx == 0) { - pic_errorf(pic, "no exception handler registered"); - } - if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) { - pic_errorf(pic, "uncontinuable exception handler is on top"); - } - else { - pic->try_jmp_idx--; - v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v); - ++pic->try_jmp_idx; - } - return v; + return pic_raise_continuable(pic, v); } noreturn static pic_value diff --git a/include/picrin/error.h b/include/picrin/error.h index 1b96f3ee..9541ab55 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -34,6 +34,7 @@ struct pic_jmpbuf { void pic_push_try(pic_state *, struct pic_proc *); void pic_pop_try(pic_state *); +pic_value pic_raise_continuable(pic_state *, pic_value); noreturn void pic_raise(pic_state *, pic_value); noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list); noreturn void pic_error(pic_state *, const char *, pic_list); From d33d0eee8588f99e8931013e052d14cfead1f640 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 22:13:00 +0900 Subject: [PATCH 141/232] inline pic_try/pic_catch in with_exception_handler --- error.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/error.c b/error.c index feaefa92..10a778d7 100644 --- a/error.c +++ b/error.c @@ -180,10 +180,16 @@ pic_error_with_exception_handler(pic_state *pic) pic_get_args(pic, "ll", &handler, &thunk); - pic_try_with_handler(handler) { + pic_push_try(pic, handler); + if (setjmp(*pic->jmp) == 0) { + val = pic_apply0(pic, thunk); + + pic_pop_try(pic); } - pic_catch { + else { + pic_pop_try(pic); + pic_value e = pic->err; pic->err = pic_undef_value(); From de92aab1946e39d20cf86bdb0dca0bd21203495d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 22:21:31 +0900 Subject: [PATCH 142/232] with-exception-handler don't need to catch the continuation! --- error.c | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/error.c b/error.c index 10a778d7..84cdb64d 100644 --- a/error.c +++ b/error.c @@ -143,6 +143,21 @@ pic_raise_continuable(pic_state *pic, pic_value err) noreturn void pic_raise(pic_state *pic, pic_value err) { + if (pic->try_jmps[pic->try_jmp_idx - 1].handler != NULL) { + struct pic_proc *handler; + pic_value val; + + handler = pic->try_jmps[pic->try_jmp_idx - 1].handler; + + pic_pop_try(pic); + + pic_gc_protect(pic, pic_obj_value(handler)); + + val = pic_apply1(pic, handler, err); + + pic_errorf(pic, "error handler returned with ~s on error ~s", val, err); + } + void pic_vm_tear_off(pic_state *); pic_vm_tear_off(pic); /* tear off */ @@ -181,23 +196,11 @@ pic_error_with_exception_handler(pic_state *pic) pic_get_args(pic, "ll", &handler, &thunk); pic_push_try(pic, handler); - if (setjmp(*pic->jmp) == 0) { - val = pic_apply0(pic, thunk); + val = pic_apply0(pic, thunk); - pic_pop_try(pic); - } - else { - pic_pop_try(pic); + pic_pop_try(pic); - pic_value e = pic->err; - - pic->err = pic_undef_value(); - - val = pic_apply1(pic, handler, e); - - pic_errorf(pic, "error handler returned with ~s on error ~s", val, e); - } return val; } From 6a8a7d93e7bda66feade30a7d126a474c5e70fe5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Sep 2014 22:34:51 +0900 Subject: [PATCH 143/232] use raise-continuable in raise procedure --- error.c | 58 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/error.c b/error.c index 84cdb64d..2e7ec4d5 100644 --- a/error.c +++ b/error.c @@ -129,46 +129,46 @@ pic_raise_continuable(pic_state *pic, pic_value err) if (pic->try_jmp_idx == 0) { pic_errorf(pic, "no exception handler registered"); } + if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) { - pic_errorf(pic, "uncontinuable exception handler is on top"); - } - else { - pic->try_jmp_idx--; - v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, err); - ++pic->try_jmp_idx; + void pic_vm_tear_off(pic_state *); + + pic_vm_tear_off(pic); /* tear off */ + + pic->err = err; + if (! pic->jmp) { + puts(pic_errmsg(pic)); + pic_panic(pic, "no handler found on stack"); + } + + longjmp(*pic->jmp, 1); } + + struct pic_proc *handler; + + handler = pic->try_jmps[pic->try_jmp_idx - 1].handler; + + pic_gc_protect(pic, pic_obj_value(handler)); + + pic->try_jmp_idx--; + + v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, err); + + pic->try_jmp_idx++; + return v; } noreturn void pic_raise(pic_state *pic, pic_value err) { - if (pic->try_jmps[pic->try_jmp_idx - 1].handler != NULL) { - struct pic_proc *handler; - pic_value val; + pic_value val; - handler = pic->try_jmps[pic->try_jmp_idx - 1].handler; + val = pic_raise_continuable(pic, err); - pic_pop_try(pic); + pic_pop_try(pic); - pic_gc_protect(pic, pic_obj_value(handler)); - - val = pic_apply1(pic, handler, err); - - pic_errorf(pic, "error handler returned with ~s on error ~s", val, err); - } - - void pic_vm_tear_off(pic_state *); - - pic_vm_tear_off(pic); /* tear off */ - - pic->err = err; - if (! pic->jmp) { - puts(pic_errmsg(pic)); - pic_panic(pic, "no handler found on stack"); - } - - longjmp(*pic->jmp, 1); + pic_errorf(pic, "error handler returned with ~s on error ~s", val, err); } noreturn void From 46c1d0f2a77e1b8c46634fe586db043089fbff56 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Sep 2014 14:12:18 +0900 Subject: [PATCH 144/232] use call/cc in exception handler implementation --- error.c | 88 +++++++++++++++++++++++------------------- include/picrin.h | 1 - include/picrin/error.h | 7 +--- state.c | 1 - 4 files changed, 51 insertions(+), 46 deletions(-) diff --git a/error.c b/error.c index 2e7ec4d5..4eb34157 100644 --- a/error.c +++ b/error.c @@ -8,6 +8,8 @@ #include "picrin.h" #include "picrin/pair.h" +#include "picrin/proc.h" +#include "picrin/cont.h" #include "picrin/string.h" #include "picrin/error.h" @@ -66,42 +68,60 @@ pic_errmsg(pic_state *pic) return pic_str_cstr(str); } -void -pic_push_try(pic_state *pic, struct pic_proc *handler) +static pic_value +native_exception_handler(pic_state *pic) { + pic_value err; + struct pic_proc *cont; + + pic_get_args(pic, "o", &err); + + pic->err = err; + + cont = pic_proc_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape")); + + pic_apply1(pic, cont, pic_false_value()); + + UNREACHABLE(); +} + +static pic_value +native_push_try(pic_state *pic) +{ + struct pic_proc *cont, *handler; struct pic_jmpbuf *try_jmp; + pic_get_args(pic, "l", &cont); + + handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); + + pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont)); + if (pic->try_jmp_idx >= pic->try_jmp_size) { pic->try_jmp_size *= 2; pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); } try_jmp = pic->try_jmps + pic->try_jmp_idx++; - try_jmp->handler = handler; - try_jmp->ci_offset = pic->ci - pic->cibase; - try_jmp->sp_offset = pic->sp - pic->stbase; - try_jmp->ip = pic->ip; + return pic_true_value(); +} - try_jmp->prev_jmp = pic->jmp; - pic->jmp = &try_jmp->here; +bool +pic_push_try(pic_state *pic) +{ + pic_value val; + + val = pic_callcc(pic, pic_make_proc(pic, native_push_try, "(native-push-try)")); + + return pic_test(val); } void pic_pop_try(pic_state *pic) { - struct pic_jmpbuf *try_jmp; - - try_jmp = pic->try_jmps + --pic->try_jmp_idx; - - /* assert(pic->jmp == &try_jmp->here); */ - - pic->ci = try_jmp->ci_offset + pic->cibase; - pic->sp = try_jmp->sp_offset + pic->stbase; - pic->ip = try_jmp->ip; - - pic->jmp = try_jmp->prev_jmp; + --pic->try_jmp_idx; } struct pic_error * @@ -124,28 +144,13 @@ pic_make_error(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) pic_value pic_raise_continuable(pic_state *pic, pic_value err) { + struct pic_proc *handler; pic_value v; if (pic->try_jmp_idx == 0) { - pic_errorf(pic, "no exception handler registered"); + pic_panic(pic, "no exception handler registered"); } - if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) { - void pic_vm_tear_off(pic_state *); - - pic_vm_tear_off(pic); /* tear off */ - - pic->err = err; - if (! pic->jmp) { - puts(pic_errmsg(pic)); - pic_panic(pic, "no handler found on stack"); - } - - longjmp(*pic->jmp, 1); - } - - struct pic_proc *handler; - handler = pic->try_jmps[pic->try_jmp_idx - 1].handler; pic_gc_protect(pic, pic_obj_value(handler)); @@ -154,7 +159,7 @@ pic_raise_continuable(pic_state *pic, pic_value err) v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, err); - pic->try_jmp_idx++; + pic->try_jmps[pic->try_jmp_idx++].handler = handler; return v; } @@ -195,11 +200,16 @@ pic_error_with_exception_handler(pic_state *pic) pic_get_args(pic, "ll", &handler, &thunk); - pic_push_try(pic, handler); + if (pic->try_jmp_idx >= pic->try_jmp_size) { + pic->try_jmp_size *= 2; + pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + } + + pic->try_jmps[pic->try_jmp_idx++].handler = handler; val = pic_apply0(pic, thunk); - pic_pop_try(pic); + pic->try_jmp_idx--; return val; } diff --git a/include/picrin.h b/include/picrin.h index 5bec9eb0..17a159dd 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -111,7 +111,6 @@ typedef struct { struct pic_reader *reader; - jmp_buf *jmp; pic_value err; struct pic_jmpbuf *try_jmps; size_t try_jmp_size, try_jmp_idx; diff --git a/include/picrin/error.h b/include/picrin/error.h index 9541ab55..8686d3ff 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -21,17 +21,14 @@ struct pic_jmpbuf { /* do not return from try block! */ #define pic_try \ - pic_try_with_handler(NULL) -#define pic_try_with_handler(handler) \ - pic_push_try(pic, handler); \ - if (setjmp(*pic->jmp) == 0) \ + if (pic_push_try(pic)) \ do #define pic_catch \ while (pic_pop_try(pic), 0); \ else \ if (pic_pop_try(pic), 1) -void pic_push_try(pic_state *, struct pic_proc *); +bool pic_push_try(pic_state *); void pic_pop_try(pic_state *); pic_value pic_raise_continuable(pic_state *, pic_value); diff --git a/state.c b/state.c index df9ba02c..e75876a2 100644 --- a/state.c +++ b/state.c @@ -71,7 +71,6 @@ pic_open(int argc, char *argv[], char **envp) xh_init_int(&pic->reader->labels, sizeof(pic_value)); /* error handling */ - pic->jmp = NULL; pic->err = pic_undef_value(); pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf)); pic->try_jmp_idx = 0; From b0b1b77c6528d17b45e9bd52d9eb2af3fccbda35 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Sep 2014 14:14:09 +0900 Subject: [PATCH 145/232] [bugfix] don't refer to env storage when accessing non-captured variable --- vm.c | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/vm.c b/vm.c index 609c702f..92af1ce7 100644 --- a/vm.c +++ b/vm.c @@ -755,20 +755,28 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) } CASE(OP_LREF) { pic_callinfo *ci = pic->ci; + struct pic_irep *irep; if (ci->env != NULL && ci->env->regs == ci->env->storage) { - PUSH(ci->env->regs[c.u.i - (ci->regs - ci->fp)]); - NEXT; + irep = pic_get_proc(pic)->u.irep; + if (c.u.i >= irep->argc + irep->localc) { + PUSH(ci->env->regs[c.u.i - (ci->regs - ci->fp)]); + NEXT; + } } PUSH(pic->ci->fp[c.u.i]); NEXT; } CASE(OP_LSET) { pic_callinfo *ci = pic->ci; + struct pic_irep *irep; if (ci->env != NULL && ci->env->regs == ci->env->storage) { - ci->env->regs[c.u.i - (ci->regs - ci->fp)] = POP(); - NEXT; + irep = pic_get_proc(pic)->u.irep; + if (c.u.i >= irep->argc + irep->localc) { + ci->env->regs[c.u.i - (ci->regs - ci->fp)] = POP(); + NEXT; + } } pic->ci->fp[c.u.i] = POP(); NEXT; From 978c51bb2629483dc7fce2a91aa32ea80e5f7a15 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Sep 2014 14:50:01 +0900 Subject: [PATCH 146/232] compact struct pic_jmpbuf --- cont.c | 28 ++++++++++++++-------------- error.c | 40 ++++++++++++++++++++++------------------ gc.c | 33 ++++++++++++++++----------------- include/picrin.h | 9 +++++---- include/picrin/cont.h | 6 +++--- include/picrin/error.h | 9 --------- state.c | 12 +++++++----- 7 files changed, 67 insertions(+), 70 deletions(-) diff --git a/cont.c b/cont.c index 8fba3c78..563332aa 100644 --- a/cont.c +++ b/cont.c @@ -131,14 +131,19 @@ save_cont(pic_state *pic, struct pic_cont **c) cont->sp_offset = pic->sp - pic->stbase; cont->st_len = pic->stend - pic->stbase; - cont->st_ptr = (pic_value *)pic_alloc(pic, sizeof(pic_value) * cont->st_len); + cont->st_ptr = pic_alloc(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_callinfo *)pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len); + cont->ci_ptr = pic_alloc(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); + memcpy(cont->xp_ptr, pic->xpbase, sizeof(struct pic_proc *) * cont->xp_len); + cont->ip = pic->ip; cont->arena_idx = pic->arena_idx; @@ -146,11 +151,6 @@ save_cont(pic_state *pic, struct pic_cont **c) cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size); memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size); - cont->try_jmp_idx = pic->try_jmp_idx; - cont->try_jmp_size = pic->try_jmp_size; - cont->try_jmps = pic_alloc(pic, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); - memcpy(cont->try_jmps, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); - cont->results = pic_undef_value(); } @@ -178,16 +178,21 @@ restore_cont(pic_state *pic, struct pic_cont *cont) pic->wind = cont->wind; - pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len); + 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); pic->sp = pic->stbase + cont->sp_offset; pic->stend = pic->stbase + cont->st_len; - pic->cibase = (pic_callinfo *)pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len); + pic->cibase = pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len); memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * cont->ci_len); pic->ci = pic->cibase + cont->ci_offset; pic->ciend = pic->cibase + cont->ci_len; + pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * cont->xp_len); + memcpy(pic->xpbase, cont->xp_ptr, sizeof(struct pic_proc *) * cont->xp_len); + pic->xp = pic->xpbase + cont->xp_offset; + pic->xpend = pic->xpbase + cont->xp_len; + pic->ip = cont->ip; pic->arena = (struct pic_object **)pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size); @@ -195,11 +200,6 @@ restore_cont(pic_state *pic, struct pic_cont *cont) pic->arena_size = cont->arena_size; pic->arena_idx = cont->arena_idx; - pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size); - memcpy(pic->try_jmps, cont->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size); - pic->try_jmp_size = cont->try_jmp_size; - pic->try_jmp_idx = cont->try_jmp_idx; - memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len); longjmp(tmp->jmp, 1); diff --git a/error.c b/error.c index 4eb34157..8023c0be 100644 --- a/error.c +++ b/error.c @@ -89,7 +89,7 @@ static pic_value native_push_try(pic_state *pic) { struct pic_proc *cont, *handler; - struct pic_jmpbuf *try_jmp; + size_t xp_len, xp_offset; pic_get_args(pic, "l", &cont); @@ -97,13 +97,15 @@ native_push_try(pic_state *pic) pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont)); - if (pic->try_jmp_idx >= pic->try_jmp_size) { - pic->try_jmp_size *= 2; - pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + if (pic->xp >= pic->xpend) { + xp_len = (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; } - try_jmp = pic->try_jmps + pic->try_jmp_idx++; - try_jmp->handler = handler; + *pic->xp++ = handler; return pic_true_value(); } @@ -121,7 +123,7 @@ pic_push_try(pic_state *pic) void pic_pop_try(pic_state *pic) { - --pic->try_jmp_idx; + --pic->xp; } struct pic_error * @@ -147,19 +149,17 @@ pic_raise_continuable(pic_state *pic, pic_value err) struct pic_proc *handler; pic_value v; - if (pic->try_jmp_idx == 0) { + if (pic->xp == pic->xpbase) { pic_panic(pic, "no exception handler registered"); } - handler = pic->try_jmps[pic->try_jmp_idx - 1].handler; + handler = *--pic->xp; pic_gc_protect(pic, pic_obj_value(handler)); - pic->try_jmp_idx--; + v = pic_apply1(pic, handler, err); - v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, err); - - pic->try_jmps[pic->try_jmp_idx++].handler = handler; + *pic->xp++ = handler; return v; } @@ -197,19 +197,23 @@ pic_error_with_exception_handler(pic_state *pic) { struct pic_proc *handler, *thunk; pic_value val; + size_t xp_len, xp_offset; pic_get_args(pic, "ll", &handler, &thunk); - if (pic->try_jmp_idx >= pic->try_jmp_size) { - pic->try_jmp_size *= 2; - pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + if (pic->xp >= pic->xpend) { + xp_len = (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->try_jmps[pic->try_jmp_idx++].handler = handler; + *pic->xp++ = handler; val = pic_apply0(pic, thunk); - pic->try_jmp_idx--; + --pic->xp; return val; } diff --git a/gc.c b/gc.c index 15304788..7ac019ff 100644 --- a/gc.c +++ b/gc.c @@ -416,6 +416,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) struct pic_cont *cont = (struct pic_cont *)obj; pic_value *stack; pic_callinfo *ci; + struct pic_proc **xhandler; size_t i; /* winder */ @@ -433,18 +434,16 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } } + /* exception handlers */ + for (xhandler = cont->xp_ptr; xhandler != cont->xp_ptr + cont->xp_offset; ++xhandler) { + gc_mark_object(pic, (struct pic_object *)*xhandler); + } + /* arena */ for (i = 0; i < (size_t)cont->arena_idx; ++i) { gc_mark_object(pic, cont->arena[i]); } - /* error handlers */ - for (i = 0; i < cont->try_jmp_idx; ++i) { - if (cont->try_jmps[i].handler) { - gc_mark_object(pic, (struct pic_object *)cont->try_jmps[i].handler); - } - } - /* result values */ gc_mark(pic, cont->results); break; @@ -562,7 +561,8 @@ gc_mark_phase(pic_state *pic) { pic_value *stack; pic_callinfo *ci; - size_t i, j; + struct pic_proc **xhandler; + size_t j; xh_entry *it; /* winder */ @@ -582,8 +582,10 @@ gc_mark_phase(pic_state *pic) } } - /* error object */ - gc_mark(pic, pic->err); + /* exception handlers */ + for (xhandler = pic->xpbase; xhandler != pic->xp; ++xhandler) { + gc_mark_object(pic, (struct pic_object *)*xhandler); + } /* arena */ for (j = 0; j < pic->arena_idx; ++j) { @@ -600,13 +602,10 @@ gc_mark_phase(pic_state *pic) gc_mark_object(pic, xh_val(it, struct pic_object *)); } - /* error handlers */ - for (i = 0; i < pic->try_jmp_idx; ++i) { - if (pic->try_jmps[i].handler) { - gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler); - } - } + /* error object */ + gc_mark(pic, pic->err); + /* features */ gc_mark(pic, pic->features); /* readers */ @@ -669,8 +668,8 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) pic_free(pic, cont->stk_ptr); pic_free(pic, cont->st_ptr); pic_free(pic, cont->ci_ptr); + pic_free(pic, cont->xp_ptr); pic_free(pic, cont->arena); - pic_free(pic, cont->try_jmps); break; } case PIC_TT_SENV: { diff --git a/include/picrin.h b/include/picrin.h index 17a159dd..b00e451d 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -75,6 +75,9 @@ typedef struct { pic_callinfo *ci; pic_callinfo *cibase, *ciend; + struct pic_proc **xp; + struct pic_proc **xpbase, **xpend; + pic_code *ip; struct pic_lib *lib; @@ -111,16 +114,14 @@ typedef struct { struct pic_reader *reader; - pic_value err; - struct pic_jmpbuf *try_jmps; - size_t try_jmp_size, try_jmp_idx; - struct pic_heap *heap; struct pic_object **arena; size_t arena_size, arena_idx; struct pic_port *xSTDIN, *xSTDOUT, *xSTDERR; + pic_value err; + char *native_stack_start; } pic_state; diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 740a1175..503651f1 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -24,15 +24,15 @@ struct pic_cont { pic_callinfo *ci_ptr; size_t ci_offset, ci_len; + struct pic_proc **xp_ptr; + size_t xp_offset, xp_len; + pic_code *ip; struct pic_object **arena; size_t arena_size; int arena_idx; - struct pic_jmpbuf *try_jmps; - size_t try_jmp_idx, try_jmp_size; - pic_value results; }; diff --git a/include/picrin/error.h b/include/picrin/error.h index 8686d3ff..0549c69d 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -9,15 +9,6 @@ extern "C" { #endif -struct pic_jmpbuf { - jmp_buf here; - struct pic_proc *handler; - ptrdiff_t ci_offset; - ptrdiff_t sp_offset; - pic_code *ip; - jmp_buf *prev_jmp; -}; - /* do not return from try block! */ #define pic_try \ diff --git a/state.c b/state.c index e75876a2..e61aef44 100644 --- a/state.c +++ b/state.c @@ -42,6 +42,10 @@ pic_open(int argc, char *argv[], char **envp) pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo)); pic->ciend = pic->cibase + PIC_STACK_SIZE; + /* exception handler */ + pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *)); + pic->xpend = pic->xpbase + PIC_RESCUE_SIZE; + /* memory heap */ pic->heap = pic_heap_open(); @@ -70,11 +74,8 @@ pic_open(int argc, char *argv[], char **envp) pic->reader->trie = pic_make_trie(pic); xh_init_int(&pic->reader->labels, sizeof(pic_value)); - /* error handling */ + /* raised error object */ pic->err = pic_undef_value(); - pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf)); - pic->try_jmp_idx = 0; - pic->try_jmp_size = PIC_RESCUE_SIZE; /* standard ports */ pic->xSTDIN = NULL; @@ -191,6 +192,7 @@ pic_close(pic_state *pic) /* clear out root objects */ pic->sp = pic->stbase; pic->ci = pic->cibase; + pic->xp = pic->xpbase; pic->arena_idx = 0; pic->err = pic_undef_value(); xh_clear(&pic->macros); @@ -206,6 +208,7 @@ pic_close(pic_state *pic) /* free runtime context */ free(pic->stbase); free(pic->cibase); + free(pic->xpbase); /* free reader struct */ xh_destroy(&pic->reader->labels); @@ -213,7 +216,6 @@ pic_close(pic_state *pic) free(pic->reader); /* free global stacks */ - free(pic->try_jmps); xh_destroy(&pic->syms); xh_destroy(&pic->globals); xh_destroy(&pic->macros); From 7a8144bbf7bc355f689aee1e1fae175caf436858 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Sep 2014 14:50:58 +0900 Subject: [PATCH 147/232] cosmetic change --- include/picrin/error.h | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/include/picrin/error.h b/include/picrin/error.h index 0549c69d..5be65502 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -9,6 +9,19 @@ extern "C" { #endif +struct pic_error { + PIC_OBJECT_HEADER + pic_sym type; + pic_str *msg; + pic_value irrs; + pic_str *stack; +}; + +#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); + /* do not return from try block! */ #define pic_try \ @@ -27,19 +40,6 @@ noreturn void pic_raise(pic_state *, pic_value); noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list); noreturn void pic_error(pic_state *, const char *, pic_list); -struct pic_error { - PIC_OBJECT_HEADER - pic_sym type; - pic_str *msg; - pic_value irrs; - pic_str *stack; -}; - -#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); - #if defined(__cplusplus) } #endif From 17602a5c8d127bb8aa086809a154d168f46f9382 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Sep 2014 19:26:58 +0900 Subject: [PATCH 148/232] unpublish pic_wind --- cont.c | 10 +++++----- include/picrin/cont.h | 1 - 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/cont.c b/cont.c index 563332aa..53ec911d 100644 --- a/cont.c +++ b/cont.c @@ -205,19 +205,19 @@ restore_cont(pic_state *pic, struct pic_cont *cont) longjmp(tmp->jmp, 1); } -void -pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there) +static void +do_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there) { if (here == there) return; if (here->depth < there->depth) { - pic_wind(pic, here, there->prev); + do_wind(pic, here, there->prev); pic_apply0(pic, there->in); } else { pic_apply0(pic, there->out); - pic_wind(pic, here->prev, there); + do_wind(pic, here->prev, there); } } @@ -264,7 +264,7 @@ cont_call(pic_state *pic) cont->results = pic_list_by_array(pic, argc, argv); /* execute guard handlers */ - pic_wind(pic, pic->wind, cont->wind); + do_wind(pic, pic->wind, cont->wind); restore_cont(pic, cont); } diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 503651f1..e30981c7 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -47,7 +47,6 @@ pic_value pic_values_by_list(pic_state *, pic_value); size_t pic_receive(pic_state *, size_t, pic_value *); pic_value pic_callcc(pic_state *, struct pic_proc *); -void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *); #if defined(__cplusplus) } From 6b1be615962d6b15becd50e0fcf055a59f8e3f99 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Sep 2014 22:25:06 +0900 Subject: [PATCH 149/232] spill out continuation type to extra data type family --- cont.c | 106 ++++++++++++++++++++++++++++++++++++++--- gc.c | 45 ----------------- include/picrin/cont.h | 27 ----------- include/picrin/value.h | 3 -- 4 files changed, 100 insertions(+), 81 deletions(-) diff --git a/cont.c b/cont.c index 53ec911d..1873fbe3 100644 --- a/cont.c +++ b/cont.c @@ -10,6 +10,7 @@ #include "picrin/proc.h" #include "picrin/cont.h" #include "picrin/pair.h" +#include "picrin/data.h" #include "picrin/error.h" pic_value @@ -93,6 +94,93 @@ pic_receive(pic_state *pic, size_t n, pic_value *argv) return retc; } +struct pic_cont { + jmp_buf jmp; + + struct pic_winder *wind; + + char *stk_pos, *stk_ptr; + ptrdiff_t stk_len; + + pic_value *st_ptr; + size_t sp_offset, st_len; + + pic_callinfo *ci_ptr; + size_t ci_offset, ci_len; + + struct pic_proc **xp_ptr; + size_t xp_offset, xp_len; + + pic_code *ip; + + struct pic_object **arena; + size_t arena_size; + int arena_idx; + + pic_value results; +}; + +static void +cont_dtor(pic_state *pic, void *data) +{ + struct pic_cont *cont = data; + + pic_free(pic, cont->stk_ptr); + pic_free(pic, cont->st_ptr); + pic_free(pic, cont->ci_ptr); + pic_free(pic, cont->xp_ptr); + pic_free(pic, cont->arena); + pic_free(pic, cont); +} + +static void +cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value)) +{ + struct pic_cont *cont = data; + struct pic_winder *wind; + 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)); + } + if (wind->out) { + mark(pic, pic_obj_value(wind->out)); + } + } + + /* stack */ + for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) { + mark(pic, *stack); + } + + /* callinfo */ + for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) { + if (ci->env) { + mark(pic, pic_obj_value(ci->env)); + } + } + + /* exception handlers */ + for (xp = cont->xp_ptr; xp != cont->xp_ptr + cont->xp_offset; ++xp) { + mark(pic, pic_obj_value(*xp)); + } + + /* arena */ + for (i = 0; i < (size_t)cont->arena_idx; ++i) { + mark(pic, pic_obj_value(cont->arena[i])); + } + + /* 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 *); @@ -119,7 +207,7 @@ save_cont(pic_state *pic, struct pic_cont **c) pic_vm_tear_off(pic); /* tear off */ - cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT); + cont = *c = pic_alloc(pic, sizeof(struct pic_cont)); cont->wind = pic->wind; @@ -148,7 +236,7 @@ save_cont(pic_state *pic, struct pic_cont **c) cont->arena_idx = pic->arena_idx; cont->arena_size = pic->arena_size; - cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size); + cont->arena = pic_alloc(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(); @@ -195,7 +283,7 @@ restore_cont(pic_state *pic, struct pic_cont *cont) pic->ip = cont->ip; - pic->arena = (struct pic_object **)pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size); + 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; pic->arena_idx = cont->arena_idx; @@ -260,7 +348,7 @@ cont_call(pic_state *pic) proc = pic_get_proc(pic); pic_get_args(pic, "*", &argc, &argv); - cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont")); + cont = pic_data_ptr(pic_attr_ref(pic, proc, "@@cont"))->data; cont->results = pic_list_by_array(pic, argc, argv); /* execute guard handlers */ @@ -280,11 +368,14 @@ pic_callcc(pic_state *pic, struct pic_proc *proc) } else { struct pic_proc *c; + struct pic_data *dat; c = pic_make_proc(pic, cont_call, ""); + dat = pic_data_alloc(pic, &cont_type, cont); + /* save the continuation object in proc */ - pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); + pic_attr_set(pic, c, "@@cont", pic_obj_value(dat)); return pic_apply1(pic, proc, pic_obj_value(c)); } @@ -301,11 +392,14 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc) } else { struct pic_proc *c; + struct pic_data *dat; c = pic_make_proc(pic, cont_call, ""); + dat = pic_data_alloc(pic, &cont_type, cont); + /* save the continuation object in proc */ - pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); + pic_attr_set(pic, c, "@@cont", pic_obj_value(dat)); return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c))); } diff --git a/gc.c b/gc.c index 7ac019ff..ed0ad7f8 100644 --- a/gc.c +++ b/gc.c @@ -412,42 +412,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_BLOB: { break; } - case PIC_TT_CONT: { - struct pic_cont *cont = (struct pic_cont *)obj; - pic_value *stack; - pic_callinfo *ci; - struct pic_proc **xhandler; - size_t i; - - /* winder */ - gc_mark_winder(pic, cont->wind); - - /* stack */ - for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) { - gc_mark(pic, *stack); - } - - /* callinfo */ - for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) { - if (ci->env) { - gc_mark_object(pic, (struct pic_object *)ci->env); - } - } - - /* exception handlers */ - for (xhandler = cont->xp_ptr; xhandler != cont->xp_ptr + cont->xp_offset; ++xhandler) { - gc_mark_object(pic, (struct pic_object *)*xhandler); - } - - /* arena */ - for (i = 0; i < (size_t)cont->arena_idx; ++i) { - gc_mark_object(pic, cont->arena[i]); - } - - /* result values */ - gc_mark(pic, cont->results); - break; - } case PIC_TT_MACRO: { struct pic_macro *mac = (struct pic_macro *)obj; @@ -663,15 +627,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) case PIC_TT_ERROR: { break; } - case PIC_TT_CONT: { - struct pic_cont *cont = (struct pic_cont *)obj; - pic_free(pic, cont->stk_ptr); - pic_free(pic, cont->st_ptr); - pic_free(pic, cont->ci_ptr); - pic_free(pic, cont->xp_ptr); - pic_free(pic, cont->arena); - break; - } case PIC_TT_SENV: { struct pic_senv *senv = (struct pic_senv *)obj; xh_destroy(&senv->map); diff --git a/include/picrin/cont.h b/include/picrin/cont.h index e30981c7..9a9d43d6 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -9,33 +9,6 @@ extern "C" { #endif -struct pic_cont { - PIC_OBJECT_HEADER - jmp_buf jmp; - - struct pic_winder *wind; - - char *stk_pos, *stk_ptr; - ptrdiff_t stk_len; - - pic_value *st_ptr; - size_t sp_offset, st_len; - - pic_callinfo *ci_ptr; - size_t ci_offset, ci_len; - - struct pic_proc **xp_ptr; - size_t xp_offset, xp_len; - - pic_code *ip; - - struct pic_object **arena; - size_t arena_size; - int arena_idx; - - pic_value results; -}; - pic_value pic_values0(pic_state *); pic_value pic_values1(pic_state *, pic_value); pic_value pic_values2(pic_state *, pic_value, pic_value); diff --git a/include/picrin/value.h b/include/picrin/value.h index 453e645a..9b1841d7 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -117,7 +117,6 @@ enum pic_tt { PIC_TT_PORT, PIC_TT_ERROR, PIC_TT_ENV, - PIC_TT_CONT, PIC_TT_SENV, PIC_TT_MACRO, PIC_TT_LIB, @@ -255,8 +254,6 @@ pic_type_repr(enum pic_tt tt) return "error"; case PIC_TT_ENV: return "env"; - case PIC_TT_CONT: - return "cont"; case PIC_TT_PROC: return "proc"; case PIC_TT_SENV: From 3aa36697235f7964b4636c94f44cec6d48cf4d4d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Sep 2014 22:33:20 +0900 Subject: [PATCH 150/232] republish dynamic wind functions --- cont.c | 90 +++++++++++++++++++++---------------------- include/picrin/cont.h | 3 ++ 2 files changed, 48 insertions(+), 45 deletions(-) diff --git a/cont.c b/cont.c index 1873fbe3..838cafce 100644 --- a/cont.c +++ b/cont.c @@ -13,6 +13,50 @@ #include "picrin/data.h" #include "picrin/error.h" +void +pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there) +{ + if (here == there) + return; + + if (here->depth < there->depth) { + pic_wind(pic, here, there->prev); + pic_apply0(pic, there->in); + } + else { + pic_apply0(pic, there->out); + pic_wind(pic, here->prev, 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_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; + + val = pic_apply0(pic, thunk); + + pic->wind = here; + + if (out != NULL) { + pic_apply0(pic, out); /* exit */ + } + + return val; +} + pic_value pic_values0(pic_state *pic) { @@ -293,50 +337,6 @@ restore_cont(pic_state *pic, struct pic_cont *cont) longjmp(tmp->jmp, 1); } -static void -do_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there) -{ - if (here == there) - return; - - if (here->depth < there->depth) { - do_wind(pic, here, there->prev); - pic_apply0(pic, there->in); - } - else { - pic_apply0(pic, there->out); - do_wind(pic, here->prev, there); - } -} - -static 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_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; - - val = pic_apply0(pic, thunk); - - pic->wind = here; - - if (out != NULL) { - pic_apply0(pic, out); /* exit */ - } - - return val; -} - noreturn static pic_value cont_call(pic_state *pic) { @@ -352,7 +352,7 @@ cont_call(pic_state *pic) cont->results = pic_list_by_array(pic, argc, argv); /* execute guard handlers */ - do_wind(pic, pic->wind, cont->wind); + pic_wind(pic, pic->wind, cont->wind); restore_cont(pic, cont); } diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 9a9d43d6..f389c0fb 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -9,6 +9,9 @@ extern "C" { #endif +void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *); +pic_value pic_dynamic_wind(pic_state *, struct pic_proc *, struct pic_proc *, struct pic_proc *); + pic_value pic_values0(pic_state *); pic_value pic_values1(pic_state *, pic_value); pic_value pic_values2(pic_state *, pic_value, pic_value); From c4258153138a33441054e75072ea30e4012f9265 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Sep 2014 17:11:59 +0900 Subject: [PATCH 151/232] print backtrace to stderr --- debug.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/debug.c b/debug.c index 3d7b92c6..bb9f711d 100644 --- a/debug.c +++ b/debug.c @@ -63,7 +63,7 @@ pic_print_backtrace(pic_state *pic) } /* print! */ - printf("%s", pic_str_cstr(trace)); + xfprintf(xstderr, "%s", pic_str_cstr(trace)); pic_gc_arena_restore(pic, ai); } From 1ff327b11f8a8b3dd59de7c86bbfda77843b1035 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Sep 2014 17:47:55 +0900 Subject: [PATCH 152/232] update xfile.h. close #40 --- include/picrin/xfile.h | 110 ++++++++++++++++++++++++++++------------- 1 file changed, 77 insertions(+), 33 deletions(-) diff --git a/include/picrin/xfile.h b/include/picrin/xfile.h index 9d814bdc..15834184 100644 --- a/include/picrin/xfile.h +++ b/include/picrin/xfile.h @@ -1,5 +1,5 @@ -#ifndef XFILE_H__ -#define XFILE_H__ +#ifndef XFILE_H +#define XFILE_H #if defined(__cplusplus) extern "C" { @@ -56,11 +56,11 @@ 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 char xgetc(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(char *); +static inline int xputs(const char *); static inline int xungetc(int, xFILE *); /* formatted I/O */ @@ -69,9 +69,9 @@ 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__()) +#define xstdin (xstdin_()) +#define xstdout (xstdout_()) +#define xstderr (xstderr_()) /* private */ @@ -105,21 +105,10 @@ xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, co * Derieved xFILE Classes */ -static inline FILE * -xf_unpack(void *cookie) -{ - switch ((long)cookie) { - default: return cookie; - case 0: return stdin; - case 1: return stdout; - case -1: return stderr; - } -} - static inline int xf_file_read(void *cookie, char *ptr, int size) { - FILE *file = xf_unpack(cookie); + FILE *file = cookie; int r; r = fread(ptr, 1, size, file); @@ -135,7 +124,7 @@ xf_file_read(void *cookie, char *ptr, int size) static inline int xf_file_write(void *cookie, const char *ptr, int size) { - FILE *file = xf_unpack(cookie); + FILE *file = cookie; int r; r = fwrite(ptr, 1, size, file); @@ -148,19 +137,19 @@ xf_file_write(void *cookie, const char *ptr, int size) static inline long xf_file_seek(void *cookie, long pos, int whence) { - return fseek(xf_unpack(cookie), pos, whence); + return fseek(cookie, pos, whence); } static inline int xf_file_flush(void *cookie) { - return fflush(xf_unpack(cookie)); + return fflush(cookie); } static inline int xf_file_close(void *cookie) { - return fclose(xf_unpack(cookie)); + return fclose(cookie); } static inline xFILE * @@ -179,27 +168,36 @@ xfpopen(FILE *fp) #define XF_FILE_VTABLE xf_file_read, xf_file_write, xf_file_seek, xf_file_flush, xf_file_close static inline xFILE * -xstdin__() +xstdin_() { - static xFILE xfile_stdin = { -1, 0, { (void *)0, XF_FILE_VTABLE } }; + static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } }; - return &xfile_stdin; + if (! x.vtable.cookie) { + x.vtable.cookie = stdin; + } + return &x; } static inline xFILE * -xstdout__() +xstdout_() { - static xFILE xfile_stdout = { -1, 0, { (void *)1, XF_FILE_VTABLE } }; + static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } }; - return &xfile_stdout; + if (! x.vtable.cookie) { + x.vtable.cookie = stdout; + } + return &x; } static inline xFILE * -xstderr__() +xstderr_() { - static xFILE xfile_stderr = { -1, 0, { (void *)-1, XF_FILE_VTABLE } }; + static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } }; - return &xfile_stderr; + if (! x.vtable.cookie) { + x.vtable.cookie = stderr; + } + return &x; } struct xf_membuf { @@ -438,13 +436,41 @@ xfgetc(xFILE *file) xfread(buf, 1, 1, file); - if (xfeof(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] = 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) { @@ -469,9 +495,18 @@ xfputc(int c, xFILE *file) buf[0] = 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) { @@ -486,9 +521,18 @@ xfputs(const char *str, xFILE *file) 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, ...) { From 0c67a4b77fcc317a78af4bd40afca591f25a09cb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Sep 2014 18:16:28 +0900 Subject: [PATCH 153/232] implement vector-map, vector-for-each, string-map, string-for-each --- string.c | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ vector.c | 63 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 135 insertions(+) diff --git a/string.c b/string.c index 6876a969..fe5bf873 100644 --- a/string.c +++ b/string.c @@ -433,6 +433,76 @@ pic_str_string_fill_ip(pic_state *pic) return pic_none_value(); } +static pic_value +pic_str_string_map(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, i, len, j; + pic_value *argv, vals, val; + + pic_get_args(pic, "l*", &proc, &argc, &argv); + + len = SIZE_MAX; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], str); + + len = len < pic_strlen(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"); + } + else { + char buf[len]; + + for (i = 0; i < len; ++i) { + vals = pic_nil_value(); + for (j = 0; j < argc; ++j) { + pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); + } + val = pic_apply(pic, proc, vals); + + pic_assert_type(pic, val, char); + buf[i] = pic_char(val); + } + + return pic_obj_value(pic_make_str(pic, buf, len)); + } +} + +static pic_value +pic_str_string_for_each(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, i, len, j; + pic_value *argv, vals, val; + + pic_get_args(pic, "l*", &proc, &argc, &argv); + + len = SIZE_MAX; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], str); + + len = len < pic_strlen(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"); + } + + for (i = 0; i < len; ++i) { + vals = pic_nil_value(); + for (j = 0; j < argc; ++j) { + pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); + } + val = pic_apply(pic, proc, vals); + } + + return pic_none_value(); +} + static pic_value pic_str_list_to_string(pic_state *pic) { @@ -490,6 +560,8 @@ pic_init_str(pic_state *pic) pic_defun(pic, "string-copy!", pic_str_string_copy_ip); pic_defun(pic, "string-append", pic_str_string_append); pic_defun(pic, "string-fill!", pic_str_string_fill_ip); + pic_defun(pic, "string-map", pic_str_string_map); + pic_defun(pic, "string-for-each", pic_str_string_for_each); pic_defun(pic, "list->string", pic_str_list_to_string); pic_defun(pic, "string->list", pic_str_string_to_list); diff --git a/vector.c b/vector.c index 57790b36..2a3099f7 100644 --- a/vector.c +++ b/vector.c @@ -231,6 +231,67 @@ pic_vec_vector_fill_i(pic_state *pic) return pic_none_value(); } +static pic_value +pic_vec_vector_map(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, i, len, j; + pic_value *argv, vals; + pic_vec *vec; + + pic_get_args(pic, "l*", &proc, &argc, &argv); + + len = SIZE_MAX; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], vec); + + len = len < pic_vec_ptr(argv[i])->len + ? len + : pic_vec_ptr(argv[i])->len; + } + + vec = pic_make_vec(pic, len); + + for (i = 0; i < len; ++i) { + vals = pic_nil_value(); + for (j = 0; j < argc; ++j) { + pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); + } + vec->data[i] = pic_apply(pic, proc, vals); + } + + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_for_each(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, i, len, j; + pic_value *argv, vals; + + pic_get_args(pic, "l*", &proc, &argc, &argv); + + len = SIZE_MAX; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], vec); + + len = len < pic_vec_ptr(argv[i])->len + ? len + : pic_vec_ptr(argv[i])->len; + } + + for (i = 0; i < len; ++i) { + vals = pic_nil_value(); + for (j = 0; j < argc; ++j) { + pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); + } + pic_apply(pic, proc, vals); + } + + return pic_none_value(); +} + static pic_value pic_vec_list_to_vector(pic_state *pic) { @@ -341,6 +402,8 @@ pic_init_vector(pic_state *pic) pic_defun(pic, "vector-copy", pic_vec_vector_copy); pic_defun(pic, "vector-append", pic_vec_vector_append); pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i); + pic_defun(pic, "vector-map", pic_vec_vector_map); + pic_defun(pic, "vector-for-each", pic_vec_vector_for_each); pic_defun(pic, "list->vector", pic_vec_list_to_vector); pic_defun(pic, "vector->list", pic_vec_vector_to_list); pic_defun(pic, "string->vector", pic_vec_string_to_vector); From 6a784897a4eaedd0faa3f710a6fc52a69a7853f6 Mon Sep 17 00:00:00 2001 From: OGINO Masanori Date: Fri, 19 Sep 2014 18:28:55 +0900 Subject: [PATCH 154/232] Fix a bug due to the operator precedence of C. The expression ```! pic_length(pic, spec) == 3``` is treated as ```(! pic_length(pic, spec)) == 3``` since ! has higher precedence than ==. Signed-off-by: OGINO Masanori --- lib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib.c b/lib.c index cb1843d8..37cba2bd 100644 --- a/lib.c +++ b/lib.c @@ -158,7 +158,7 @@ export(pic_state *pic, pic_value spec) } else { /* (export (rename a b)) */ if (! pic_list_p(spec)) goto fail; - if (! pic_length(pic, spec) == 3) + if (! (pic_length(pic, spec) == 3)) goto fail; if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) goto fail; From 15ad9d05ac26799cdec203004a06dd7e7957281d Mon Sep 17 00:00:00 2001 From: OGINO Masanori Date: Fri, 19 Sep 2014 23:52:32 +0900 Subject: [PATCH 155/232] Fix a name of compiler identifier macro for Clang. Signed-off-by: OGINO Masanori --- include/picrin/config.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/picrin/config.h b/include/picrin/config.h index 5291a927..76c30066 100644 --- a/include/picrin/config.h +++ b/include/picrin/config.h @@ -42,7 +42,7 @@ #endif #ifndef PIC_DIRECT_THREADED_VM -# if defined(__GNUC__) || defined(__CLANG__) +# if defined(__GNUC__) || defined(__clang__) # define PIC_DIRECT_THREADED_VM 1 # endif #endif From 1d7669a5d4a1ece8d73268166917677e99671136 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 20 Sep 2014 11:45:40 +0900 Subject: [PATCH 156/232] update xhash --- include/picrin/xhash.h | 46 +++++++++++++++++++++++------------------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/include/picrin/xhash.h b/include/picrin/xhash.h index c78dc118..b43884df 100644 --- a/include/picrin/xhash.h +++ b/include/picrin/xhash.h @@ -43,7 +43,7 @@ typedef struct xhash { size_t size, count, kwidth, vwidth; xh_hashf hashf; xh_equalf equalf; - xh_entry *chain; + xh_entry *head, *tail; void *data; } xhash; @@ -98,7 +98,8 @@ xh_init_(xhash *x, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equal x->vwidth = vwidth; x->hashf = hashf; x->equalf = equalf; - x->chain = NULL; + x->head = NULL; + x->tail = NULL; x->data = data; xh_bucket_realloc(x, XHASH_INIT_SIZE); @@ -138,7 +139,8 @@ xh_resize_(xhash *x, size_t newsize) y.count++; } - y.chain = x->chain; + y.head = x->head; + y.tail = x->tail; free(x->buckets); @@ -171,14 +173,14 @@ xh_put_(xhash *x, const void *key, void *val) memcpy((void *)e->key, key, x->kwidth); memcpy(e->val, val, x->vwidth); - if (x->chain == NULL) { - x->chain = e; + if (x->head == NULL) { + x->head = x->tail = e; e->fw = e->bw = NULL; } else { - x->chain->fw = e; - e->bw = x->chain; - e->fw = NULL; - x->chain = e; + x->tail->bw = e; + e->fw = x->tail; + e->bw = NULL; + x->tail = e; } x->count++; @@ -197,15 +199,16 @@ xh_del_(xhash *x, const void *key) idx = ((unsigned)hash) % x->size; if (x->buckets[idx]->hash == hash && x->equalf(key, x->buckets[idx]->key, x->data)) { q = x->buckets[idx]; - if (q->fw) { + if (q->fw == NULL) { + x->head = q->bw; + } else { q->fw->bw = q->bw; } - if (q->bw) { + if (q->bw == NULL) { + x->tail = q->fw; + } else { q->bw->fw = q->fw; } - if (x->chain == q) { - x->chain = q->bw; - } r = q->next; free(q); x->buckets[idx] = r; @@ -216,15 +219,16 @@ xh_del_(xhash *x, const void *key) break; } q = p->next; - if (q->fw) { + if (q->fw == NULL) { + x->head = q->bw; + } else { q->fw->bw = q->bw; } - if (q->bw) { + if (q->bw == NULL) { + x->tail = q->fw; + } else { q->bw->fw = q->fw; } - if (x->chain == q) { - x->chain = q->bw; - } r = q->next; free(q); p->next = r; @@ -255,7 +259,7 @@ xh_clear(xhash *x) x->buckets[i] = NULL; } - x->chain = NULL; + x->head = x->tail = NULL; x->count = 0; } @@ -403,7 +407,7 @@ xh_del_int(xhash *x, int key) static inline xh_entry * xh_begin(xhash *x) { - return x->chain; + return x->head; } static inline xh_entry * From 2dd48b4dc0f76bcec0968509cc603c06528e40fa Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Sep 2014 16:41:49 +0900 Subject: [PATCH 157/232] add pic_escape --- cont.c | 100 ++++++++++++++++++++++++++++++++++++++++++ error.c | 2 +- include/picrin/cont.h | 1 + 3 files changed, 102 insertions(+), 1 deletion(-) diff --git a/cont.c b/cont.c index 838cafce..d01281ad 100644 --- a/cont.c +++ b/cont.c @@ -57,6 +57,106 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st return val; } +struct pic_escape { + jmp_buf jmp; + + bool valid; + + struct pic_winder *wind; + + ptrdiff_t sp_offset; + ptrdiff_t ci_offset; + ptrdiff_t xp_offset; + int arena_idx; + + pic_code *ip; + + pic_value results; +}; + +static int +save_point(pic_state *pic, struct pic_escape *escape) +{ + escape->valid = true; + + /* 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; + + escape->results = pic_undef_value(); + + return setjmp(escape->jmp); +} + +noreturn static void +load_point(pic_state *pic, struct pic_escape *escape) +{ + if (! escape->valid) { + pic_errorf(pic, "calling dead escape continuation"); + } + + pic_wind(pic, pic->wind, escape->wind); + + /* 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; + + longjmp(escape->jmp, 1); +} + +noreturn static pic_value +escape_call(pic_state *pic) +{ + size_t argc; + pic_value *argv; + struct pic_data *e; + + pic_get_args(pic, "*", &argc, &argv); + + e = pic_data_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape")); + + load_point(pic, e->data); +} + +pic_value +pic_escape(pic_state *pic, struct pic_proc *proc) +{ + static const pic_data_type escape_type = { "escape", pic_free, NULL }; + struct pic_escape *escape; + + escape = pic_alloc(pic, sizeof(struct pic_escape)); + + if (save_point(pic, escape)) { + return pic_values_by_list(pic, escape->results); + } + else { + struct pic_proc *c; + pic_value val; + struct pic_data *e; + + c = pic_make_proc(pic, escape_call, ""); + + e = pic_data_alloc(pic, &escape_type, escape); + + /* save the escape continuation in proc */ + pic_attr_set(pic, c, "@@escape", pic_obj_value(e)); + + val = pic_apply1(pic, proc, pic_obj_value(c)); + + escape->valid = false; + + return val; + } +} + pic_value pic_values0(pic_state *pic) { diff --git a/error.c b/error.c index 8023c0be..978ff962 100644 --- a/error.c +++ b/error.c @@ -115,7 +115,7 @@ pic_push_try(pic_state *pic) { pic_value val; - val = pic_callcc(pic, pic_make_proc(pic, native_push_try, "(native-push-try)")); + val = pic_escape(pic, pic_make_proc(pic, native_push_try, "(native-push-try)")); return pic_test(val); } diff --git a/include/picrin/cont.h b/include/picrin/cont.h index f389c0fb..10c6913e 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -23,6 +23,7 @@ pic_value pic_values_by_list(pic_state *, pic_value); size_t pic_receive(pic_state *, size_t, pic_value *); pic_value pic_callcc(pic_state *, struct pic_proc *); +pic_value pic_escape(pic_state *, struct pic_proc *); #if defined(__cplusplus) } From de1b771326321cbc4fdde9586942f5de5d3c1581 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 20 Sep 2014 20:26:07 +0900 Subject: [PATCH 158/232] remove pic_callcc --- cont.c | 269 +----------------------------------------- include/picrin/cont.h | 1 - 2 files changed, 1 insertion(+), 269 deletions(-) diff --git a/cont.c b/cont.c index d01281ad..8ee36b33 100644 --- a/cont.c +++ b/cont.c @@ -238,273 +238,6 @@ pic_receive(pic_state *pic, size_t n, pic_value *argv) return retc; } -struct pic_cont { - jmp_buf jmp; - - struct pic_winder *wind; - - char *stk_pos, *stk_ptr; - ptrdiff_t stk_len; - - pic_value *st_ptr; - size_t sp_offset, st_len; - - pic_callinfo *ci_ptr; - size_t ci_offset, ci_len; - - struct pic_proc **xp_ptr; - size_t xp_offset, xp_len; - - pic_code *ip; - - struct pic_object **arena; - size_t arena_size; - int arena_idx; - - pic_value results; -}; - -static void -cont_dtor(pic_state *pic, void *data) -{ - struct pic_cont *cont = data; - - pic_free(pic, cont->stk_ptr); - pic_free(pic, cont->st_ptr); - pic_free(pic, cont->ci_ptr); - pic_free(pic, cont->xp_ptr); - pic_free(pic, cont->arena); - pic_free(pic, cont); -} - -static void -cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value)) -{ - struct pic_cont *cont = data; - struct pic_winder *wind; - 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)); - } - if (wind->out) { - mark(pic, pic_obj_value(wind->out)); - } - } - - /* stack */ - for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) { - mark(pic, *stack); - } - - /* callinfo */ - for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) { - if (ci->env) { - mark(pic, pic_obj_value(ci->env)); - } - } - - /* exception handlers */ - for (xp = cont->xp_ptr; xp != cont->xp_ptr + cont->xp_offset; ++xp) { - mark(pic, pic_obj_value(*xp)); - } - - /* arena */ - for (i = 0; i < (size_t)cont->arena_idx; ++i) { - mark(pic, pic_obj_value(cont->arena[i])); - } - - /* 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 ptrdiff_t -native_stack_length(pic_state *pic, char **pos) -{ - char t; - - *pos = (pic->native_stack_start > &t) - ? &t - : pic->native_stack_start; - - return (pic->native_stack_start > &t) - ? pic->native_stack_start - &t - : &t - pic->native_stack_start; -} - -static void -save_cont(pic_state *pic, struct pic_cont **c) -{ - void pic_vm_tear_off(pic_state *); - struct pic_cont *cont; - char *pos; - - pic_vm_tear_off(pic); /* tear off */ - - cont = *c = pic_alloc(pic, sizeof(struct pic_cont)); - - cont->wind = pic->wind; - - 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); - 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); - 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); - 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); - memcpy(cont->xp_ptr, pic->xpbase, sizeof(struct pic_proc *) * cont->xp_len); - - cont->ip = pic->ip; - - cont->arena_idx = pic->arena_idx; - cont->arena_size = pic->arena_size; - cont->arena = pic_alloc(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) -{ - volatile pic_value v[1024]; - - ((void)v); - restore_cont(pic, cont); -} - -noreturn static void -restore_cont(pic_state *pic, struct pic_cont *cont) -{ - char v; - struct pic_cont *tmp = cont; - - if (&v < pic->native_stack_start) { - if (&v > cont->stk_pos) native_stack_extend(pic, cont); - } - else { - if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); - } - - pic->wind = cont->wind; - - 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); - pic->sp = pic->stbase + cont->sp_offset; - pic->stend = pic->stbase + cont->st_len; - - pic->cibase = pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len); - memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * cont->ci_len); - pic->ci = pic->cibase + cont->ci_offset; - pic->ciend = pic->cibase + cont->ci_len; - - pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * cont->xp_len); - memcpy(pic->xpbase, cont->xp_ptr, sizeof(struct pic_proc *) * cont->xp_len); - pic->xp = pic->xpbase + cont->xp_offset; - pic->xpend = pic->xpbase + cont->xp_len; - - pic->ip = cont->ip; - - 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; - pic->arena_idx = cont->arena_idx; - - memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len); - - longjmp(tmp->jmp, 1); -} - -noreturn static pic_value -cont_call(pic_state *pic) -{ - struct pic_proc *proc; - size_t argc; - pic_value *argv; - struct pic_cont *cont; - - proc = pic_get_proc(pic); - pic_get_args(pic, "*", &argc, &argv); - - cont = pic_data_ptr(pic_attr_ref(pic, proc, "@@cont"))->data; - cont->results = pic_list_by_array(pic, argc, argv); - - /* execute guard handlers */ - pic_wind(pic, pic->wind, cont->wind); - - restore_cont(pic, cont); -} - -pic_value -pic_callcc(pic_state *pic, struct pic_proc *proc) -{ - struct pic_cont *cont; - - save_cont(pic, &cont); - if (setjmp(cont->jmp)) { - return pic_values_by_list(pic, cont->results); - } - else { - struct pic_proc *c; - struct pic_data *dat; - - c = pic_make_proc(pic, cont_call, ""); - - dat = pic_data_alloc(pic, &cont_type, cont); - - /* save the continuation object in proc */ - pic_attr_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) -{ - struct pic_cont *cont; - - save_cont(pic, &cont); - if (setjmp(cont->jmp)) { - return pic_values_by_list(pic, cont->results); - } - else { - struct pic_proc *c; - struct pic_data *dat; - - c = pic_make_proc(pic, cont_call, ""); - - dat = pic_data_alloc(pic, &cont_type, cont); - - /* save the continuation object in proc */ - pic_attr_set(pic, c, "@@cont", pic_obj_value(dat)); - - return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c))); - } -} - static pic_value pic_cont_callcc(pic_state *pic) { @@ -512,7 +245,7 @@ pic_cont_callcc(pic_state *pic) pic_get_args(pic, "l", &cb); - return pic_callcc_trampoline(pic, cb); + return pic_escape(pic, cb); } static pic_value diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 10c6913e..c0868f79 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -22,7 +22,6 @@ 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_callcc(pic_state *, struct pic_proc *); pic_value pic_escape(pic_state *, struct pic_proc *); #if defined(__cplusplus) From 08e64ec563737665a70d87ef436dc1727acf51bd Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 20 Sep 2014 21:01:55 +0900 Subject: [PATCH 159/232] update readme. --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index ce4188a0..1929c3b8 100644 --- a/README.md +++ b/README.md @@ -77,6 +77,10 @@ main(int argc, char *argv[]) All procedures and syntaces are exported from a single library named `(picrin base)`. The complete list is found at https://gist.github.com/wasabiz/344d802a2340d1f734b7 . +### call/cc + +Full continuation has many problems in embbeding into applications. By default, Benz's call/cc operator does not support continuation that can handle re-entering (it only supports escape continuations). To remove this restriction, please use an add-on provided from [Picrin Scheme's repository](https://github.com/picrin-scheme/picrin/tree/master/contrib/03.callcc). + ## Authors See https://github.com/picrin-scheme/benz and https://github.com/picrin-scheme/picrin for details. From 77c0a893ff7200b058ca2c8bc0c7e5f7f2acce60 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 21 Sep 2014 15:32:55 +0900 Subject: [PATCH 160/232] spill out string mutators --- include/picrin/string.h | 1 - string.c | 100 +++++----------------------------------- 2 files changed, 12 insertions(+), 89 deletions(-) diff --git a/include/picrin/string.h b/include/picrin/string.h index 325bec11..2701e162 100644 --- a/include/picrin/string.h +++ b/include/picrin/string.h @@ -23,7 +23,6 @@ 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); -void pic_str_set(pic_state *, pic_str *, size_t, char); pic_str *pic_strcat(pic_state *, pic_str *, pic_str *); pic_str *pic_substr(pic_state *, pic_str *, size_t, size_t); diff --git a/string.c b/string.c index fe5bf873..b53055f4 100644 --- a/string.c +++ b/string.c @@ -66,26 +66,6 @@ pic_str_ref(pic_state *pic, pic_str *str, size_t i) return (char)c; } -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) { - pic_errorf(pic, "index out of range %d", i); - } - - x = pic_substr(pic, str, 0, i); - y = pic_make_str_fill(pic, 1, c); - z = pic_substr(pic, str, i + 1, pic_strlen(str)); - - tmp = pic_strcat(pic, x, pic_strcat(pic, y, z)); - - XROPE_INCREF(tmp->rope); - XROPE_DECREF(str->rope); - str->rope = tmp->rope; -} - pic_str * pic_strcat(pic_state *pic, pic_str *a, pic_str *b) { @@ -306,19 +286,6 @@ pic_str_string_ref(pic_state *pic) return pic_char_value(pic_str_ref(pic, str, k)); } -static pic_value -pic_str_string_set(pic_state *pic) -{ - pic_str *str; - char c; - int k; - - pic_get_args(pic, "sic", &str, &k, &c); - - pic_str_set(pic, str, k, c); - return pic_none_value(); -} - #define DEFINE_STRING_CMP(name, op) \ static pic_value \ pic_str_string_##name(pic_state *pic) \ @@ -368,30 +335,6 @@ pic_str_string_copy(pic_state *pic) return pic_obj_value(pic_substr(pic, str, start, end)); } -static pic_value -pic_str_string_copy_ip(pic_state *pic) -{ - pic_str *to, *from; - int n, at, start, end; - - n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end); - - switch (n) { - case 3: - start = 0; - case 4: - end = pic_strlen(from); - } - if (to == from) { - from = pic_substr(pic, from, 0, end); - } - - while (start < end) { - pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++)); - } - return pic_none_value(); -} - static pic_value pic_str_string_append(pic_state *pic) { @@ -411,28 +354,6 @@ pic_str_string_append(pic_state *pic) return pic_obj_value(str); } -static pic_value -pic_str_string_fill_ip(pic_state *pic) -{ - pic_str *str; - char c; - int n, start, end; - - n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end); - - switch (n) { - case 2: - start = 0; - case 3: - end = pic_strlen(str); - } - - while (start < end) { - pic_str_set(pic, str, start++, c); - } - return pic_none_value(); -} - static pic_value pic_str_string_map(pic_state *pic) { @@ -512,15 +433,21 @@ pic_str_list_to_string(pic_state *pic) pic_get_args(pic, "o", &list); - str = pic_make_str_fill(pic, pic_length(pic, 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) { - pic_assert_type(pic, e, char); + pic_for_each (e, list) { + pic_assert_type(pic, e, char); - pic_str_set(pic, str, i++, pic_char(e)); + buf[i++] = pic_char(e); + } + + str = pic_make_str(pic, buf, i); + + return pic_obj_value(str); } - - return pic_obj_value(str); } static pic_value @@ -555,11 +482,8 @@ pic_init_str(pic_state *pic) pic_defun(pic, "make-string", pic_str_make_string); pic_defun(pic, "string-length", pic_str_string_length); pic_defun(pic, "string-ref", pic_str_string_ref); - pic_defun(pic, "string-set!", pic_str_string_set); pic_defun(pic, "string-copy", pic_str_string_copy); - pic_defun(pic, "string-copy!", pic_str_string_copy_ip); pic_defun(pic, "string-append", pic_str_string_append); - pic_defun(pic, "string-fill!", pic_str_string_fill_ip); pic_defun(pic, "string-map", pic_str_string_map); pic_defun(pic, "string-for-each", pic_str_string_for_each); pic_defun(pic, "list->string", pic_str_list_to_string); From 732ca8e36de496598291bcbf2dd926b585b6a91c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 21 Sep 2014 15:43:09 +0900 Subject: [PATCH 161/232] update readme --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index 1929c3b8..93efc012 100644 --- a/README.md +++ b/README.md @@ -81,6 +81,10 @@ All procedures and syntaces are exported from a single library named `(picrin ba Full continuation has many problems in embbeding into applications. By default, Benz's call/cc operator does not support continuation that can handle re-entering (it only supports escape continuations). To remove this restriction, please use an add-on provided from [Picrin Scheme's repository](https://github.com/picrin-scheme/picrin/tree/master/contrib/03.callcc). +### Strings + +Benz utilize rope data structure to implement string type. Thanks to the implementation, string-append is guaranteed to be done in a constant time (so do string-copy, when ascii-only mode is enabled). In return for that, strings in benz are immutable by default. It does not provide mutation API (string-set!, string-copy! and string-fill! in R7RS). This restriction can be also removed with an add-on in [Picrin Scheme's repository](https://github.com/picrin-scheme/picrin/tree/master/contrib/03.mutable-string). + ## Authors See https://github.com/picrin-scheme/benz and https://github.com/picrin-scheme/picrin for details. From 1c2af96340f026681b0391ad2383ee65155af341 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 21 Sep 2014 16:26:56 +0900 Subject: [PATCH 162/232] remove dictionary-map and dictionary-for-each --- dict.c | 42 ------------------------------------------ 1 file changed, 42 deletions(-) diff --git a/dict.c b/dict.c index 229b55ad..0746fbd9 100644 --- a/dict.c +++ b/dict.c @@ -216,46 +216,6 @@ pic_dict_dictionary_size(pic_state *pic) return pic_int_value(pic_dict_size(pic, dict)); } -static pic_value -pic_dict_dictionary_map(pic_state *pic) -{ - struct pic_proc *proc; - struct pic_dict *dict; - pic_value item, list = pic_nil_value(); - xh_entry *it; - - pic_get_args(pic, "ld", &proc, &dict); - - for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { - item = pic_cons(pic, xh_key(it, pic_value), xh_val(it, pic_value)); - pic_push(pic, pic_apply1(pic, proc, item), list); - } - - return pic_reverse(pic, list); -} - -static pic_value -pic_dict_dictionary_for_each(pic_state *pic) -{ - struct pic_proc *proc; - struct pic_dict *dict; - pic_value item; - xh_entry *it; - - pic_get_args(pic, "ld", &proc, &dict); - - for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { - int ai = pic_gc_arena_preserve(pic); - - item = pic_cons(pic, xh_key(it, pic_value), xh_val(it, pic_value)); - pic_apply1(pic, proc, item); - - pic_gc_arena_restore(pic, ai); - } - - return pic_none_value(); -} - static pic_value pic_dict_dictionary_to_alist(pic_state *pic) { @@ -334,8 +294,6 @@ pic_init_dict(pic_state *pic) 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); pic_defun(pic, "dictionary->alist", pic_dict_dictionary_to_alist); pic_defun(pic, "alist->dictionary", pic_dict_alist_to_dictionary); pic_defun(pic, "dictionary->plist", pic_dict_dictionary_to_plist); From 319db5fc9f20a82044ae1623a0fd9f226e204ae5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 21 Sep 2014 18:05:43 +0900 Subject: [PATCH 163/232] remove unused helper functions --- blob.c | 17 ----------------- include/picrin.h | 3 --- 2 files changed, 20 deletions(-) diff --git a/blob.c b/blob.c index a8f28c9b..d8fded8c 100644 --- a/blob.c +++ b/blob.c @@ -8,23 +8,6 @@ #include "picrin/blob.h" #include "picrin/pair.h" -char * -pic_strndup(pic_state *pic, const char *s, size_t n) -{ - char *r; - - r = pic_alloc(pic, n + 1); - memcpy(r, s, n); - r[n] = '\0'; - return r; -} - -char * -pic_strdup(pic_state *pic, const char *s) -{ - return pic_strndup(pic, s, strlen(s)); -} - struct pic_blob * pic_make_blob(pic_state *pic, size_t len) { diff --git a/include/picrin.h b/include/picrin.h index b00e451d..f418cf47 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -170,9 +170,6 @@ pic_sym pic_gensym(pic_state *, pic_sym); pic_sym pic_ungensym(pic_state *, pic_sym); bool pic_interned_p(pic_state *, pic_sym); -char *pic_strdup(pic_state *, const char *); -char *pic_strndup(pic_state *, const char *, size_t); - pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read_cstr(pic_state *, const char *); From 712be55bc3b86a363db289995fff129ade78c4a6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 21 Sep 2014 18:07:09 +0900 Subject: [PATCH 164/232] cosmetic changes --- include/picrin.h | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index f418cf47..b13713c5 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -155,6 +155,8 @@ void pic_add_feature(pic_state *, const char *); void pic_define(pic_state *, const char *, pic_value); void pic_define_noexport(pic_state *, const char *, pic_value); void pic_defun(pic_state *, const char *, pic_func_t); + +struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *); struct pic_proc *pic_get_proc(pic_state *); @@ -210,6 +212,7 @@ void pic_export(pic_state *, pic_sym); noreturn void pic_panic(pic_state *, const char *); 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 *); @@ -219,10 +222,6 @@ static inline void pic_warn(pic_state *pic, const char *msg) pic_warnf(pic, msg); } -const char *pic_errmsg(pic_state *); - -struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); - struct pic_port *pic_stdin(pic_state *); struct pic_port *pic_stdout(pic_state *); struct pic_port *pic_stderr(pic_state *); From 669f9b28def0058200193d43a345de6c229eb263 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 21 Sep 2014 18:19:13 +0900 Subject: [PATCH 165/232] add prototypes for eq? and eqv? --- include/picrin.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/include/picrin.h b/include/picrin.h index b13713c5..689cc678 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -162,6 +162,8 @@ void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *); struct pic_proc *pic_get_proc(pic_state *); int pic_get_args(pic_state *, const char *, ...); +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); From 951af56540ce995cf8526bf1671c5964ba06116b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 14:53:09 +0900 Subject: [PATCH 166/232] publish struct pic_escape --- cont.c | 17 ----------------- include/picrin/cont.h | 17 +++++++++++++++++ 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/cont.c b/cont.c index 8ee36b33..496503cc 100644 --- a/cont.c +++ b/cont.c @@ -57,23 +57,6 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st return val; } -struct pic_escape { - jmp_buf jmp; - - bool valid; - - struct pic_winder *wind; - - ptrdiff_t sp_offset; - ptrdiff_t ci_offset; - ptrdiff_t xp_offset; - int arena_idx; - - pic_code *ip; - - pic_value results; -}; - static int save_point(pic_state *pic, struct pic_escape *escape) { diff --git a/include/picrin/cont.h b/include/picrin/cont.h index c0868f79..f49d6595 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -9,6 +9,23 @@ extern "C" { #endif +struct pic_escape { + jmp_buf jmp; + + bool valid; + + struct pic_winder *wind; + + ptrdiff_t sp_offset; + ptrdiff_t ci_offset; + ptrdiff_t xp_offset; + int arena_idx; + + pic_code *ip; + + pic_value results; +}; + void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *); pic_value pic_dynamic_wind(pic_state *, struct pic_proc *, struct pic_proc *, struct pic_proc *); From 07f24db66f02c3e7e138dc323111fc5bde985567 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 14:57:49 +0900 Subject: [PATCH 167/232] add make_escape --- cont.c | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/cont.c b/cont.c index 496503cc..1066dd89 100644 --- a/cont.c +++ b/cont.c @@ -109,10 +109,26 @@ escape_call(pic_state *pic) load_point(pic, e->data); } +static struct pic_proc * +make_escape(pic_state *pic, struct pic_escape *escape) +{ + static const pic_data_type escape_type = { "escape", pic_free, NULL }; + struct pic_proc *cont; + struct pic_data *e; + + cont = pic_make_proc(pic, escape_call, ""); + + e = pic_data_alloc(pic, &escape_type, escape); + + /* save the escape continuation in proc */ + pic_attr_set(pic, cont, "@@escape", pic_obj_value(e)); + + return cont; +} + pic_value pic_escape(pic_state *pic, struct pic_proc *proc) { - static const pic_data_type escape_type = { "escape", pic_free, NULL }; struct pic_escape *escape; escape = pic_alloc(pic, sizeof(struct pic_escape)); @@ -121,18 +137,9 @@ pic_escape(pic_state *pic, struct pic_proc *proc) return pic_values_by_list(pic, escape->results); } else { - struct pic_proc *c; pic_value val; - struct pic_data *e; - c = pic_make_proc(pic, escape_call, ""); - - e = pic_data_alloc(pic, &escape_type, escape); - - /* save the escape continuation in proc */ - pic_attr_set(pic, c, "@@escape", pic_obj_value(e)); - - val = pic_apply1(pic, proc, pic_obj_value(c)); + val = pic_apply1(pic, proc, pic_obj_value(make_escape(pic, escape))); escape->valid = false; From c965f254cb05ca49ab32d18f37838cb50831ddf5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 15:33:21 +0900 Subject: [PATCH 168/232] missing validation flag change --- cont.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cont.c b/cont.c index 1066dd89..bc1a6c17 100644 --- a/cont.c +++ b/cont.c @@ -92,6 +92,8 @@ load_point(pic_state *pic, struct pic_escape *escape) pic->arena_idx = escape->arena_idx; pic->ip = escape->ip; + escape->valid = false; + longjmp(escape->jmp, 1); } From e38732995e14bd7e89f12a8a3a830213934f06e1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 15:34:46 +0900 Subject: [PATCH 169/232] publish continuation internal APIs --- cont.c | 18 +++++++++--------- include/picrin/cont.h | 5 +++++ 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/cont.c b/cont.c index bc1a6c17..2c109c67 100644 --- a/cont.c +++ b/cont.c @@ -57,8 +57,8 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st return val; } -static int -save_point(pic_state *pic, struct pic_escape *escape) +int +pic_save_point(pic_state *pic, struct pic_escape *escape) { escape->valid = true; @@ -75,8 +75,8 @@ save_point(pic_state *pic, struct pic_escape *escape) return setjmp(escape->jmp); } -noreturn static void -load_point(pic_state *pic, struct pic_escape *escape) +noreturn void +pic_load_point(pic_state *pic, struct pic_escape *escape) { if (! escape->valid) { pic_errorf(pic, "calling dead escape continuation"); @@ -108,11 +108,11 @@ escape_call(pic_state *pic) e = pic_data_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape")); - load_point(pic, e->data); + pic_load_point(pic, e->data); } -static struct pic_proc * -make_escape(pic_state *pic, struct pic_escape *escape) +struct pic_proc * +pic_make_cont(pic_state *pic, struct pic_escape *escape) { static const pic_data_type escape_type = { "escape", pic_free, NULL }; struct pic_proc *cont; @@ -135,13 +135,13 @@ pic_escape(pic_state *pic, struct pic_proc *proc) escape = pic_alloc(pic, sizeof(struct pic_escape)); - if (save_point(pic, escape)) { + if (pic_save_point(pic, escape)) { return pic_values_by_list(pic, escape->results); } else { pic_value val; - val = pic_apply1(pic, proc, pic_obj_value(make_escape(pic, escape))); + val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, escape))); escape->valid = false; diff --git a/include/picrin/cont.h b/include/picrin/cont.h index f49d6595..6fd6fda8 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -26,6 +26,11 @@ struct pic_escape { pic_value results; }; +int pic_save_point(pic_state *, struct pic_escape *); +noreturn void pic_load_point(pic_state *, struct pic_escape *); + +struct pic_proc *pic_make_cont(pic_state *, struct pic_escape *); + void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *); pic_value pic_dynamic_wind(pic_state *, struct pic_proc *, struct pic_proc *, struct pic_proc *); From c7c771c861ff656b96086e4f7c8cb230d5cd20e7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 15:35:00 +0900 Subject: [PATCH 170/232] refactor pic_push_try. use raw continuation API --- error.c | 54 ++++++++++++++++++++++++++---------------------------- 1 file changed, 26 insertions(+), 28 deletions(-) diff --git a/error.c b/error.c index 978ff962..aa2e8e42 100644 --- a/error.c +++ b/error.c @@ -85,39 +85,37 @@ native_exception_handler(pic_state *pic) UNREACHABLE(); } -static pic_value -native_push_try(pic_state *pic) -{ - struct pic_proc *cont, *handler; - size_t xp_len, xp_offset; - - pic_get_args(pic, "l", &cont); - - handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); - - pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont)); - - if (pic->xp >= pic->xpend) { - xp_len = (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; - - return pic_true_value(); -} - bool pic_push_try(pic_state *pic) { - pic_value val; + struct pic_escape *escape; - val = pic_escape(pic, pic_make_proc(pic, native_push_try, "(native-push-try)")); + escape = pic_alloc(pic, sizeof(struct pic_escape)); - return pic_test(val); + if (pic_save_point(pic, escape)) { + return false; + } else { + struct pic_proc *cont, *handler; + size_t xp_len, xp_offset; + + cont = pic_make_cont(pic, escape); + + handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); + + pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont)); + + if (pic->xp >= pic->xpend) { + xp_len = (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; + + return true; + } } void From 7c5fb70e735078e4dc9d61cf9bc631982e758bc9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 15:59:23 +0900 Subject: [PATCH 171/232] mark invalid flag --- error.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/error.c b/error.c index aa2e8e42..02ec75a6 100644 --- a/error.c +++ b/error.c @@ -10,6 +10,7 @@ #include "picrin/pair.h" #include "picrin/proc.h" #include "picrin/cont.h" +#include "picrin/data.h" #include "picrin/string.h" #include "picrin/error.h" @@ -121,7 +122,13 @@ pic_push_try(pic_state *pic) void pic_pop_try(pic_state *pic) { - --pic->xp; + struct pic_data *e; + + assert(pic->xp > pic->xpbase); + + e = pic_data_ptr(pic_attr_ref(pic, pic_proc_ptr(pic_attr_ref(pic, *--pic->xp, "@@escape")), "@@escape")); + + ((struct pic_escape *)e->data)->valid = false; } struct pic_error * From cb2157bbaee2fcded4feebaa46c10551426e10d7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 18:43:20 +0900 Subject: [PATCH 172/232] s/pic_make_cont/pic_make_econt/g --- cont.c | 4 ++-- error.c | 2 +- include/picrin/cont.h | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/cont.c b/cont.c index 2c109c67..214602e5 100644 --- a/cont.c +++ b/cont.c @@ -112,7 +112,7 @@ escape_call(pic_state *pic) } struct pic_proc * -pic_make_cont(pic_state *pic, struct pic_escape *escape) +pic_make_econt(pic_state *pic, struct pic_escape *escape) { static const pic_data_type escape_type = { "escape", pic_free, NULL }; struct pic_proc *cont; @@ -141,7 +141,7 @@ pic_escape(pic_state *pic, struct pic_proc *proc) else { pic_value val; - val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, escape))); + val = pic_apply1(pic, proc, pic_obj_value(pic_make_econt(pic, escape))); escape->valid = false; diff --git a/error.c b/error.c index 02ec75a6..92aa4710 100644 --- a/error.c +++ b/error.c @@ -99,7 +99,7 @@ pic_push_try(pic_state *pic) struct pic_proc *cont, *handler; size_t xp_len, xp_offset; - cont = pic_make_cont(pic, escape); + cont = pic_make_econt(pic, escape); handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 6fd6fda8..fd7bfea4 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -29,7 +29,7 @@ struct pic_escape { int pic_save_point(pic_state *, struct pic_escape *); noreturn void pic_load_point(pic_state *, struct pic_escape *); -struct pic_proc *pic_make_cont(pic_state *, struct pic_escape *); +struct pic_proc *pic_make_econt(pic_state *, struct pic_escape *); void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *); pic_value pic_dynamic_wind(pic_state *, struct pic_proc *, struct pic_proc *, struct pic_proc *); From d6b2fe05ceed53ce96e1db14017e097749d3e1a7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 19:24:02 +0900 Subject: [PATCH 173/232] add many many assertions (pic_pop_try) --- error.c | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/error.c b/error.c index 92aa4710..be1e2337 100644 --- a/error.c +++ b/error.c @@ -122,13 +122,21 @@ pic_push_try(pic_state *pic) void pic_pop_try(pic_state *pic) { - struct pic_data *e; + pic_value cont, escape; assert(pic->xp > pic->xpbase); - e = pic_data_ptr(pic_attr_ref(pic, pic_proc_ptr(pic_attr_ref(pic, *--pic->xp, "@@escape")), "@@escape")); + cont = pic_attr_ref(pic, *--pic->xp, "@@escape"); - ((struct pic_escape *)e->data)->valid = false; + assert(pic_proc_p(cont)); + + escape = pic_attr_ref(pic, pic_proc_ptr(cont), "@@escape"); + + assert(pic_data_p(escape)); + + ((struct pic_escape *)pic_data_ptr(escape)->data)->valid = false; + + puts("pop_try done;"); } struct pic_error * From 44c1debbbeae665ac118c34883d25b14e32cddff Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 19:24:19 +0900 Subject: [PATCH 174/232] don't do pop_try when an error was raised --- include/picrin/error.h | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/include/picrin/error.h b/include/picrin/error.h index 5be65502..151cef12 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -29,8 +29,7 @@ struct pic_error *pic_make_error(pic_state *, pic_sym, const char *, pic_list); do #define pic_catch \ while (pic_pop_try(pic), 0); \ - else \ - if (pic_pop_try(pic), 1) + else bool pic_push_try(pic_state *); void pic_pop_try(pic_state *); From d6104b8b25860c78e7719066e898a29e9fabc26a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 20:01:21 +0900 Subject: [PATCH 175/232] add noreturn mark --- error.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/error.c b/error.c index be1e2337..e5dfd340 100644 --- a/error.c +++ b/error.c @@ -69,7 +69,7 @@ pic_errmsg(pic_state *pic) return pic_str_cstr(str); } -static pic_value +noreturn static pic_value native_exception_handler(pic_state *pic) { pic_value err; From eb1e01d000dbdc607a2dc210cc737a1e7dbde4b6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 20:06:14 +0900 Subject: [PATCH 176/232] don't setjmp in pic_save_point --- cont.c | 10 ++++------ error.c | 8 +++++--- include/picrin/cont.h | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/cont.c b/cont.c index 214602e5..a560fa72 100644 --- a/cont.c +++ b/cont.c @@ -57,7 +57,7 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st return val; } -int +void pic_save_point(pic_state *pic, struct pic_escape *escape) { escape->valid = true; @@ -71,8 +71,6 @@ pic_save_point(pic_state *pic, struct pic_escape *escape) escape->ip = pic->ip; escape->results = pic_undef_value(); - - return setjmp(escape->jmp); } noreturn void @@ -131,11 +129,11 @@ pic_make_econt(pic_state *pic, struct pic_escape *escape) pic_value pic_escape(pic_state *pic, struct pic_proc *proc) { - struct pic_escape *escape; + struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape)); - escape = pic_alloc(pic, sizeof(struct pic_escape)); + pic_save_point(pic, escape); - if (pic_save_point(pic, escape)) { + if (setjmp(escape->jmp)) { return pic_values_by_list(pic, escape->results); } else { diff --git a/error.c b/error.c index e5dfd340..a0c811d2 100644 --- a/error.c +++ b/error.c @@ -89,11 +89,13 @@ native_exception_handler(pic_state *pic) bool pic_push_try(pic_state *pic) { - struct pic_escape *escape; + struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape)); - escape = pic_alloc(pic, sizeof(struct pic_escape)); + pic_save_point(pic, escape); + + if (setjmp(escape->jmp)) { + puts("escaping"); - if (pic_save_point(pic, escape)) { return false; } else { struct pic_proc *cont, *handler; diff --git a/include/picrin/cont.h b/include/picrin/cont.h index fd7bfea4..0b29cfda 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -26,7 +26,7 @@ struct pic_escape { pic_value results; }; -int pic_save_point(pic_state *, struct pic_escape *); +void pic_save_point(pic_state *, struct pic_escape *); noreturn void pic_load_point(pic_state *, struct pic_escape *); struct pic_proc *pic_make_econt(pic_state *, struct pic_escape *); From d6c6427ff77faf93d2168ff09eac95aebb80769f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 20:21:28 +0900 Subject: [PATCH 177/232] don't setjmp in pic_push_try --- error.c | 44 ++++++++++++++---------------------------- include/picrin/error.h | 18 ++++++++++++----- 2 files changed, 28 insertions(+), 34 deletions(-) diff --git a/error.c b/error.c index a0c811d2..90d74572 100644 --- a/error.c +++ b/error.c @@ -86,39 +86,27 @@ native_exception_handler(pic_state *pic) UNREACHABLE(); } -bool -pic_push_try(pic_state *pic) +void +pic_push_try(pic_state *pic, struct pic_escape *escape) { - struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape)); + struct pic_proc *cont, *handler; + size_t xp_len, xp_offset; - pic_save_point(pic, escape); + cont = pic_make_econt(pic, escape); - if (setjmp(escape->jmp)) { - puts("escaping"); + handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); - return false; - } else { - struct pic_proc *cont, *handler; - size_t xp_len, xp_offset; + pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont)); - cont = pic_make_econt(pic, escape); - - handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); - - pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont)); - - if (pic->xp >= pic->xpend) { - xp_len = (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; - - return true; + if (pic->xp >= pic->xpend) { + xp_len = (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; } void @@ -137,8 +125,6 @@ pic_pop_try(pic_state *pic) assert(pic_data_p(escape)); ((struct pic_escape *)pic_data_ptr(escape)->data)->valid = false; - - puts("pop_try done;"); } struct pic_error * diff --git a/include/picrin/error.h b/include/picrin/error.h index 151cef12..784b95f8 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -9,6 +9,8 @@ extern "C" { #endif +#include "picrin/cont.h" + struct pic_error { PIC_OBJECT_HEADER pic_sym type; @@ -25,13 +27,19 @@ struct pic_error *pic_make_error(pic_state *, pic_sym, const char *, pic_list); /* do not return from try block! */ #define pic_try \ - if (pic_push_try(pic)) \ + pic_try_(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 (pic_pop_try(pic), 0); \ - else +#define pic_catch \ + while (0); \ + pic_pop_try(pic); \ + } else -bool pic_push_try(pic_state *); +void pic_push_try(pic_state *, struct pic_escape *); void pic_pop_try(pic_state *); pic_value pic_raise_continuable(pic_state *, pic_value); From a6d2491338ed4467077b21bbfd3bf2e5c2ab3ffc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Sep 2014 20:27:16 +0900 Subject: [PATCH 178/232] don't perform longjmp in pic_load_point (for the symmetry) --- cont.c | 6 +++--- include/picrin/cont.h | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/cont.c b/cont.c index a560fa72..56e6263e 100644 --- a/cont.c +++ b/cont.c @@ -73,7 +73,7 @@ pic_save_point(pic_state *pic, struct pic_escape *escape) escape->results = pic_undef_value(); } -noreturn void +void pic_load_point(pic_state *pic, struct pic_escape *escape) { if (! escape->valid) { @@ -91,8 +91,6 @@ pic_load_point(pic_state *pic, struct pic_escape *escape) pic->ip = escape->ip; escape->valid = false; - - longjmp(escape->jmp, 1); } noreturn static pic_value @@ -107,6 +105,8 @@ escape_call(pic_state *pic) e = pic_data_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape")); pic_load_point(pic, e->data); + + longjmp(((struct pic_escape *)e->data)->jmp, 1); } struct pic_proc * diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 0b29cfda..3e948f73 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -27,7 +27,7 @@ struct pic_escape { }; void pic_save_point(pic_state *, struct pic_escape *); -noreturn void pic_load_point(pic_state *, struct pic_escape *); +void pic_load_point(pic_state *, struct pic_escape *); struct pic_proc *pic_make_econt(pic_state *, struct pic_escape *); From 77d4196b067f3e43e9b8f1cb2ad82c8e9ed3f399 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Sep 2014 09:44:21 +0900 Subject: [PATCH 179/232] generalized attribute --- attr.c | 50 +++++++++++++++++++++++++++++++++++++++++++ cont.c | 4 ++-- error.c | 8 +++---- gc.c | 11 ++++++---- include/picrin.h | 5 +++++ include/picrin/proc.h | 5 ----- init.c | 2 ++ proc.c | 36 ------------------------------- state.c | 6 ++++++ var.c | 10 ++++----- 10 files changed, 81 insertions(+), 56 deletions(-) create mode 100644 attr.c diff --git a/attr.c b/attr.c new file mode 100644 index 00000000..e005bec2 --- /dev/null +++ b/attr.c @@ -0,0 +1,50 @@ +#include "picrin.h" +#include "picrin/dict.h" + +struct pic_dict * +pic_attr(pic_state *pic, pic_value obj) +{ + xh_entry *e; + + if (pic_vtype(obj) != PIC_VTYPE_HEAP) { + pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj); + } + + e = xh_get_ptr(&pic->attrs, pic_ptr(obj)); + if (e == NULL) { + struct pic_dict *dict = pic_make_dict(pic); + + e = xh_put_ptr(&pic->attrs, pic_ptr(obj), &dict); + + assert(dict == xh_val(e, struct pic_dict *)); + } + return xh_val(e, struct pic_dict *); +} + +pic_value +pic_attr_ref(pic_state *pic, pic_value obj, const char *key) +{ + return pic_dict_ref(pic, pic_attr(pic, obj), pic_sym_value(pic_intern_cstr(pic, key))); +} + +void +pic_attr_set(pic_state *pic, pic_value obj, const char *key, pic_value v) +{ + pic_dict_set(pic, pic_attr(pic, obj), pic_sym_value(pic_intern_cstr(pic, key)), v); +} + +static pic_value +pic_attr_attribute(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_obj_value(pic_attr(pic, obj)); +} + +void +pic_init_attr(pic_state *pic) +{ + pic_defun(pic, "attribute", pic_attr_attribute); +} diff --git a/cont.c b/cont.c index 56e6263e..f010f532 100644 --- a/cont.c +++ b/cont.c @@ -102,7 +102,7 @@ escape_call(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - e = pic_data_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape")); + e = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape")); pic_load_point(pic, e->data); @@ -121,7 +121,7 @@ pic_make_econt(pic_state *pic, struct pic_escape *escape) e = pic_data_alloc(pic, &escape_type, escape); /* save the escape continuation in proc */ - pic_attr_set(pic, cont, "@@escape", pic_obj_value(e)); + pic_attr_set(pic, pic_obj_value(cont), "@@escape", pic_obj_value(e)); return cont; } diff --git a/error.c b/error.c index 90d74572..b25cbb42 100644 --- a/error.c +++ b/error.c @@ -79,7 +79,7 @@ native_exception_handler(pic_state *pic) pic->err = err; - cont = pic_proc_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape")); + cont = pic_proc_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape")); pic_apply1(pic, cont, pic_false_value()); @@ -96,7 +96,7 @@ pic_push_try(pic_state *pic, struct pic_escape *escape) handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); - pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont)); + pic_attr_set(pic, pic_obj_value(handler), "@@escape", pic_obj_value(cont)); if (pic->xp >= pic->xpend) { xp_len = (pic->xpend - pic->xpbase) * 2; @@ -116,11 +116,11 @@ pic_pop_try(pic_state *pic) assert(pic->xp > pic->xpbase); - cont = pic_attr_ref(pic, *--pic->xp, "@@escape"); + cont = pic_attr_ref(pic, pic_obj_value(*--pic->xp), "@@escape"); assert(pic_proc_p(cont)); - escape = pic_attr_ref(pic, pic_proc_ptr(cont), "@@escape"); + escape = pic_attr_ref(pic, cont, "@@escape"); assert(pic_data_p(escape)); diff --git a/gc.c b/gc.c index ed0ad7f8..c89ff0e5 100644 --- a/gc.c +++ b/gc.c @@ -381,9 +381,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) if (proc->env) { gc_mark_object(pic, (struct pic_object *)proc->env); } - if (proc->attr) { - gc_mark_object(pic, (struct pic_object *)proc->attr); - } if (pic_proc_irep_p(proc)) { gc_mark_object(pic, (struct pic_object *)proc->u.irep); } @@ -562,7 +559,7 @@ gc_mark_phase(pic_state *pic) } /* macro objects */ - for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) { + for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) { gc_mark_object(pic, xh_val(it, struct pic_object *)); } @@ -588,6 +585,12 @@ gc_mark_phase(pic_state *pic) if (pic->xSTDERR) { gc_mark_object(pic, (struct pic_object *)pic->xSTDERR); } + + /* attributes */ + for (it = xh_begin(&pic->attrs); it != NULL; it = xh_next(it)) { + gc_mark_object(pic, xh_key(it, struct pic_object *)); + gc_mark_object(pic, (struct pic_object *)xh_val(it, struct pic_dict *)); + } } static void diff --git a/include/picrin.h b/include/picrin.h index 689cc678..442e06a0 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -111,6 +111,7 @@ typedef struct { xhash globals; xhash macros; pic_value libs; + xhash attrs; struct pic_reader *reader; @@ -224,6 +225,10 @@ static inline void pic_warn(pic_state *pic, const char *msg) pic_warnf(pic, msg); } +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); + struct pic_port *pic_stdin(pic_state *); struct pic_port *pic_stdout(pic_state *); struct pic_port *pic_stderr(pic_state *); diff --git a/include/picrin/proc.h b/include/picrin/proc.h index bf5dda36..e64cd6fc 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -31,7 +31,6 @@ struct pic_proc { struct pic_irep *irep; } u; struct pic_env *env; - struct pic_dict *attr; }; #define PIC_PROC_KIND_FUNC 1 @@ -51,10 +50,6 @@ struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_e pic_sym pic_proc_name(struct pic_proc *); -struct pic_dict *pic_attr(pic_state *, struct pic_proc *); -pic_value pic_attr_ref(pic_state *, struct pic_proc *, const char *); -void pic_attr_set(pic_state *, struct pic_proc *, const char *, pic_value); - #if defined(__cplusplus) } #endif diff --git a/init.c b/init.c index 33c4e084..06e97ca2 100644 --- a/init.c +++ b/init.c @@ -38,6 +38,7 @@ 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[]; @@ -138,6 +139,7 @@ pic_init_core(pic_state *pic) 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); } diff --git a/proc.c b/proc.c index 9702819c..210f157d 100644 --- a/proc.c +++ b/proc.c @@ -6,7 +6,6 @@ #include "picrin/pair.h" #include "picrin/proc.h" #include "picrin/irep.h" -#include "picrin/dict.h" struct pic_proc * pic_make_proc(pic_state *pic, pic_func_t func, const char *name) @@ -20,7 +19,6 @@ pic_make_proc(pic_state *pic, pic_func_t func, const char *name) proc->u.func.f = func; proc->u.func.name = pic_intern_cstr(pic, name); proc->env = NULL; - proc->attr = NULL; return proc; } @@ -33,7 +31,6 @@ pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env) proc->kind = PIC_PROC_KIND_IREP; proc->u.irep = irep; proc->env = env; - proc->attr = NULL; return proc; } @@ -49,27 +46,6 @@ pic_proc_name(struct pic_proc *proc) UNREACHABLE(); } -struct pic_dict * -pic_attr(pic_state *pic, struct pic_proc *proc) -{ - if (proc->attr == NULL) { - proc->attr = pic_make_dict(pic); - } - return proc->attr; -} - -pic_value -pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key) -{ - return pic_dict_ref(pic, pic_attr(pic, proc), pic_sym_value(pic_intern_cstr(pic, key))); -} - -void -pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v) -{ - pic_dict_set(pic, pic_attr(pic, proc), pic_sym_value(pic_intern_cstr(pic, key)), v); -} - static pic_value pic_proc_proc_p(pic_state *pic) { @@ -102,21 +78,9 @@ pic_proc_apply(pic_state *pic) return pic_apply_trampoline(pic, proc, arg_list); } -static pic_value -pic_proc_attribute(pic_state *pic) -{ - struct pic_proc *proc; - - pic_get_args(pic, "l", &proc); - - return pic_obj_value(pic_attr(pic, proc)); -} - void pic_init_proc(pic_state *pic) { pic_defun(pic, "procedure?", pic_proc_proc_p); pic_defun(pic, "apply", pic_proc_apply); - - pic_defun(pic, "attribute", pic_proc_attribute); } diff --git a/state.c b/state.c index e61aef44..688e4a6f 100644 --- a/state.c +++ b/state.c @@ -61,6 +61,9 @@ pic_open(int argc, char *argv[], char **envp) /* macros */ xh_init_int(&pic->macros, sizeof(struct pic_macro *)); + /* attributes */ + xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *)); + /* features */ pic->features = pic_nil_value(); @@ -195,7 +198,9 @@ pic_close(pic_state *pic) 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->features = pic_nil_value(); pic->libs = pic_nil_value(); @@ -219,6 +224,7 @@ pic_close(pic_state *pic) xh_destroy(&pic->syms); xh_destroy(&pic->globals); xh_destroy(&pic->macros); + xh_destroy(&pic->attrs); /* free GC arena */ free(pic->arena); diff --git a/var.c b/var.c index ce74d104..45aae9b0 100644 --- a/var.c +++ b/var.c @@ -43,7 +43,7 @@ var_call(pic_state *pic) box = var_lookup(pic, pic_obj_value(self)); if (! pic_test(box)) { - box = pic_attr_ref(pic, self, "@@box"); + box = pic_attr_ref(pic, pic_obj_value(self), "@@box"); } switch (n) { @@ -51,7 +51,7 @@ var_call(pic_state *pic) return pic_car(pic, box); case 1: - conv = pic_attr_ref(pic, self, "@@converter"); + conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter"); if (pic_test(conv)) { pic_assert_type(pic, conv, proc); @@ -64,7 +64,7 @@ var_call(pic_state *pic) case 2: assert(pic_false_p(tmp)); - conv = pic_attr_ref(pic, self, "@@converter"); + conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter"); if (pic_test(conv)) { pic_assert_type(pic, conv, proc); @@ -82,8 +82,8 @@ 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, var, "@@box", pic_list1(pic, init)); - pic_attr_set(pic, var, "@@converter", conv ? pic_obj_value(conv) : pic_false_value()); + pic_attr_set(pic, pic_obj_value(var), "@@box", pic_list1(pic, init)); + pic_attr_set(pic, pic_obj_value(var), "@@converter", conv ? pic_obj_value(conv) : pic_false_value()); return var; } From c7ee2bb88f9f914061c6e91901c68673d84b0af6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Sep 2014 12:12:52 +0900 Subject: [PATCH 180/232] let pic->attrs be weak-map --- gc.c | 38 ++++++++++++++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/gc.c b/gc.c index c89ff0e5..6a53a361 100644 --- a/gc.c +++ b/gc.c @@ -327,6 +327,16 @@ gc_is_marked(union header *p) return p->s.mark == PIC_GC_MARK; } +static bool +gc_obj_is_marked(struct pic_object *obj) +{ + union header *p; + + p = ((union header *)obj) - 1; + + return gc_is_marked(p); +} + static void gc_unmark(union header *p) { @@ -525,6 +535,7 @@ gc_mark_phase(pic_state *pic) struct pic_proc **xhandler; size_t j; xh_entry *it; + struct pic_object *obj; /* winder */ if (pic->wind) { @@ -587,10 +598,19 @@ gc_mark_phase(pic_state *pic) } /* attributes */ - for (it = xh_begin(&pic->attrs); it != NULL; it = xh_next(it)) { - gc_mark_object(pic, xh_key(it, struct pic_object *)); - gc_mark_object(pic, (struct pic_object *)xh_val(it, struct pic_dict *)); - } + do { + j = 0; + + 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); + ++j; + } + } + } + } while (j > 0); } static void @@ -733,6 +753,16 @@ static void 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) { + 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 *)); + } + } + } while (it != NULL); while (page) { gc_sweep_page(pic, page); From d33a98cd412f41005e0aa9ef99aa7d37ea7ff806 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Sep 2014 12:17:06 +0900 Subject: [PATCH 181/232] add single line comments about attribute and dictionary --- README.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/README.md b/README.md index 93efc012..81722f44 100644 --- a/README.md +++ b/README.md @@ -85,6 +85,14 @@ Full continuation has many problems in embbeding into applications. By default, Benz utilize rope data structure to implement string type. Thanks to the implementation, string-append is guaranteed to be done in a constant time (so do string-copy, when ascii-only mode is enabled). In return for that, strings in benz are immutable by default. It does not provide mutation API (string-set!, string-copy! and string-fill! in R7RS). This restriction can be also removed with an add-on in [Picrin Scheme's repository](https://github.com/picrin-scheme/picrin/tree/master/contrib/03.mutable-string). +### Dictionaries + +Dictionary is a hash table object. Its equivalence is tested with equal? procedure. + +### Attribute + +Benz has an facility to get or set metadata to any heap object. + ## Authors See https://github.com/picrin-scheme/benz and https://github.com/picrin-scheme/picrin for details. From 1be24ae9d421bd33a01743bea2d28bc45d2bdeaf Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 12:25:53 +0900 Subject: [PATCH 182/232] suppress warnings from xvect.h and xhash.h --- include/picrin/xhash.h | 4 ++-- include/picrin/xvect.h | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/include/picrin/xhash.h b/include/picrin/xhash.h index b43884df..1d3596ca 100644 --- a/include/picrin/xhash.h +++ b/include/picrin/xhash.h @@ -21,7 +21,7 @@ extern "C" { #define XHASH_RESIZE_RATIO 0.75 #define XHASH_ALIGNMENT 3 /* quad word alignment */ -#define XHASH_MASK (~((1 << XHASH_ALIGNMENT) - 1)) +#define XHASH_MASK (~(size_t)((1 << XHASH_ALIGNMENT) - 1)) #define XHASH_ALIGN(i) ((((i) - 1) & XHASH_MASK) + (1 << XHASH_ALIGNMENT)) typedef struct xh_entry { @@ -325,7 +325,7 @@ xh_ptr_hash(const void *key, void *data) { (void)data; - return (size_t)*(const void **)key; + return (int)(size_t)*(const void **)key; } static inline int diff --git a/include/picrin/xvect.h b/include/picrin/xvect.h index b98886e9..3701205e 100644 --- a/include/picrin/xvect.h +++ b/include/picrin/xvect.h @@ -45,7 +45,7 @@ xv_init(xvect *x, size_t width) x->data = NULL; x->width = width; x->size = 0; - x->mask = -1; + x->mask = (size_t)-1; x->head = 0; x->tail = 0; } From d029e003d6518a9a25f519b6bd2a87c2afb00790 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 13:50:27 +0900 Subject: [PATCH 183/232] update xfile.h (suppress warnings) --- include/picrin/xfile.h | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/include/picrin/xfile.h b/include/picrin/xfile.h index 15834184..4db6f836 100644 --- a/include/picrin/xfile.h +++ b/include/picrin/xfile.h @@ -111,7 +111,7 @@ xf_file_read(void *cookie, char *ptr, int size) FILE *file = cookie; int r; - r = fread(ptr, 1, size, file); + r = (int)fread(ptr, 1, (size_t)size, file); if (r < size && ferror(file)) { return -1; } @@ -127,7 +127,7 @@ xf_file_write(void *cookie, const char *ptr, int size) FILE *file = cookie; int r; - r = fwrite(ptr, 1, size, file); + r = (int)fwrite(ptr, 1, (size_t)size, file); if (r < size) { return -1; } @@ -212,8 +212,8 @@ xf_mem_read(void *cookie, char *ptr, int size) mem = (struct xf_membuf *)cookie; - if (size > mem->end - mem->pos) - size = mem->end - mem->pos; + 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; @@ -228,7 +228,7 @@ xf_mem_write(void *cookie, const char *ptr, int size) if (mem->pos + size >= mem->capa) { mem->capa = (mem->pos + size) * 2; - mem->buf = realloc(mem->buf, mem->capa); + mem->buf = realloc(mem->buf, (size_t)mem->capa); } memcpy(mem->buf + mem->pos, ptr, size); mem->pos += size; @@ -344,12 +344,12 @@ xfread(void *ptr, size_t block, size_t nitems, xFILE *file) for (i = 0; i < nitems; ++i) { offset = 0; if (file->ungot != -1 && block > 0) { - buf[0] = file->ungot; + buf[0] = (char)file->ungot; offset += 1; file->ungot = -1; } while (offset < block) { - n = file->vtable.read(file->vtable.cookie, buf + offset, block - offset); + n = file->vtable.read(file->vtable.cookie, buf + offset, (int)(block - offset)); if (n < 0) { file->flags |= XF_ERR; goto exit; @@ -358,7 +358,7 @@ xfread(void *ptr, size_t block, size_t nitems, xFILE *file) file->flags |= XF_EOF; goto exit; } - offset += n; + offset += (unsigned)n; } memcpy(dst, buf, block); dst += block; @@ -378,12 +378,12 @@ xfwrite(const void *ptr, size_t block, size_t nitems, xFILE *file) for (i = 0; i < nitems; ++i) { offset = 0; while (offset < block) { - n = file->vtable.write(file->vtable.cookie, dst + offset, block - offset); + n = file->vtable.write(file->vtable.cookie, dst + offset, (int)(block - offset)); if (n < 0) { file->flags |= XF_ERR; goto exit; } - offset += n; + offset += (unsigned)n; } dst += block; } @@ -458,7 +458,7 @@ xfgets(char *str, int size, xFILE *file) if ((c = xfgetc(file)) == EOF) { break; } - str[i] = c; + str[i] = (char)c; } if (i == 0 && c == EOF) { return NULL; @@ -492,7 +492,7 @@ xfputc(int c, xFILE *file) { char buf[1]; - buf[0] = c; + buf[0] = (char)c; xfwrite(buf, 1, 1, file); if (xferror(file)) { @@ -516,7 +516,7 @@ xputchar(int c) static inline int xfputs(const char *str, xFILE *file) { - int len; + size_t len; len = strlen(str); xfwrite(str, len, 1, file); @@ -573,7 +573,7 @@ xvfprintf(xFILE *stream, const char *fmt, va_list ap) } va_end(ap2); - return sizeof buf; + return (int)(sizeof buf); } } From 1949ebddf9429d6225465170a85a6028984d2d74 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 13:57:36 +0900 Subject: [PATCH 184/232] use UNREAHCABLE for pic_vtype --- include/picrin/value.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/include/picrin/value.h b/include/picrin/value.h index 9b1841d7..aacd935d 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -215,9 +215,9 @@ pic_type(pic_value v) return PIC_TT_EOF; case PIC_VTYPE_HEAP: return ((struct pic_object *)pic_ptr(v))->tt; - default: - return -1; /* logic flaw */ } + + UNREACHABLE(); } static inline const char * From 46f79c08946d7eae6ce24b09592c7e292c23a85e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 14:04:52 +0900 Subject: [PATCH 185/232] the contents of blob object must be a chunk of unsigned char --- blob.c | 12 ++++++------ include/picrin/blob.h | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/blob.c b/blob.c index d8fded8c..d98187eb 100644 --- a/blob.c +++ b/blob.c @@ -35,7 +35,7 @@ pic_blob_bytevector(pic_state *pic) pic_value *argv; size_t argc, i; pic_blob *blob; - char *data; + unsigned char *data; pic_get_args(pic, "*", &argc, &argv); @@ -50,7 +50,7 @@ pic_blob_bytevector(pic_state *pic) pic_errorf(pic, "byte out of range"); } - *data++ = pic_int(argv[i]); + *data++ = (unsigned char)pic_int(argv[i]); } return pic_obj_value(blob); @@ -69,7 +69,7 @@ pic_blob_make_bytevector(pic_state *pic) blob = pic_make_blob(pic, k); for (i = 0; i < k; ++i) { - blob->data[i] = b; + blob->data[i] = (unsigned char)b; } return pic_obj_value(blob); @@ -107,7 +107,7 @@ pic_blob_bytevector_u8_set(pic_state *pic) if (v < 0 || v > 255) pic_errorf(pic, "byte out of range"); - bv->data[k] = v; + bv->data[k] = (unsigned char)v; return pic_none_value(); } @@ -197,7 +197,7 @@ static pic_value pic_blob_list_to_bytevector(pic_state *pic) { pic_blob *blob; - char *data; + unsigned char *data; pic_value list, e; pic_get_args(pic, "o", &list); @@ -212,7 +212,7 @@ pic_blob_list_to_bytevector(pic_state *pic) if (pic_int(e) < 0 || pic_int(e) > 255) pic_errorf(pic, "byte out of range"); - *data++ = pic_int(e); + *data++ = (unsigned char)pic_int(e); } return pic_obj_value(blob); } diff --git a/include/picrin/blob.h b/include/picrin/blob.h index 29a285e9..442c8a52 100644 --- a/include/picrin/blob.h +++ b/include/picrin/blob.h @@ -11,7 +11,7 @@ extern "C" { struct pic_blob { PIC_OBJECT_HEADER - char *data; + unsigned char *data; size_t len; }; From ed354867a954013acf9077ab15b572665220822a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 14:13:17 +0900 Subject: [PATCH 186/232] suppress warnings of implicit size_t <-> int conversion (blob.c) --- blob.c | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/blob.c b/blob.c index d98187eb..e927f4ff 100644 --- a/blob.c +++ b/blob.c @@ -67,7 +67,10 @@ pic_blob_make_bytevector(pic_state *pic) if (b < 0 || b > 255) pic_errorf(pic, "byte out of range"); - blob = pic_make_blob(pic, k); + if (k < 0) + pic_errorf(pic, "make-bytevector: cannot create a bytevector of length %d", k); + + blob = pic_make_blob(pic, (size_t)k); for (i = 0; i < k; ++i) { blob->data[i] = (unsigned char)b; } @@ -82,7 +85,7 @@ pic_blob_bytevector_length(pic_state *pic) pic_get_args(pic, "b", &bv); - return pic_int_value(bv->len); + return pic_int_value((int)bv->len); } static pic_value @@ -123,7 +126,7 @@ pic_blob_bytevector_copy_i(pic_state *pic) case 3: start = 0; case 4: - end = from->len; + end = (int)from->len; } if (to == from && (start <= at && at < end)) { @@ -146,7 +149,7 @@ static pic_value pic_blob_bytevector_copy(pic_state *pic) { pic_blob *from, *to; - int n, start, end, i = 0; + int n, start, end, k, i = 0; n = pic_get_args(pic, "b|ii", &from, &start, &end); @@ -154,10 +157,15 @@ pic_blob_bytevector_copy(pic_state *pic) case 1: start = 0; case 2: - end = from->len; + end = (int)from->len; } - to = pic_make_blob(pic, end - start); + k = end - start; + + if (k < 0) + pic_errorf(pic, "make-bytevector: cannot create a bytevector of length %d", k); + + to = pic_make_blob(pic, (size_t)k); while (start < end) { to->data[i++] = from->data[start++]; } @@ -202,7 +210,7 @@ pic_blob_list_to_bytevector(pic_state *pic) pic_get_args(pic, "o", &list); - blob = pic_make_blob(pic, pic_length(pic, list)); + blob = pic_make_blob(pic, (size_t)pic_length(pic, list)); data = blob->data; @@ -230,7 +238,7 @@ pic_blob_bytevector_to_list(pic_state *pic) case 1: start = 0; case 2: - end = blob->len; + end = (int)blob->len; } list = pic_nil_value(); From 32fa44db917e21c3c4dd07b1b9bf2825e2ab147e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 14:23:47 +0900 Subject: [PATCH 187/232] integer->char: assure given integer range --- char.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/char.c b/char.c index a460fb2b..98eed6f7 100644 --- a/char.c +++ b/char.c @@ -31,7 +31,11 @@ pic_char_integer_to_char(pic_state *pic) pic_get_args(pic, "i", &i); - return pic_char_value(i); + if (i < 0 || i > 127) { + pic_errorf(pic, "integer->char: integer out of char range: %d", i); + } + + return pic_char_value((char)i); } #define DEFINE_CHAR_CMP(op, name) \ From 96d31446bd345c74382b16ccba7e6e535cd84be4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 14:33:58 +0900 Subject: [PATCH 188/232] arena_idx in struct pic_cont did not match its type with pic_state's one --- include/picrin/cont.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 3e948f73..645e6d9c 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -19,7 +19,7 @@ struct pic_escape { ptrdiff_t sp_offset; ptrdiff_t ci_offset; ptrdiff_t xp_offset; - int arena_idx; + size_t arena_idx; pic_code *ip; From 44133ce6938e3a78c3a5bf795167d16f623dff5e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 14:35:05 +0900 Subject: [PATCH 189/232] remove redundant semicolon --- include/picrin/data.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/picrin/data.h b/include/picrin/data.h index 79b633a5..fec4cd7d 100644 --- a/include/picrin/data.h +++ b/include/picrin/data.h @@ -16,7 +16,7 @@ typedef struct { } pic_data_type; struct pic_data { - PIC_OBJECT_HEADER; + PIC_OBJECT_HEADER const pic_data_type *type; xhash storage; /* const char * to pic_value table */ void *data; From f8e90917741f3a09805cc50c7106f0b5a2cb3178 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 14:38:05 +0900 Subject: [PATCH 190/232] internal representation of floating point number is not float type but double --- write.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/write.c b/write.c index 752964a1..fb01addc 100644 --- a/write.c +++ b/write.c @@ -211,7 +211,7 @@ write_core(struct writer_control *p, pic_value obj) size_t i; xh_entry *e, *it; int c; - float f; + double f; /* shared objects */ if (pic_vtype(obj) == PIC_VTYPE_HEAP From d58e7d470fa23c88ad199c4becd366b3b2387c04 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 14:42:50 +0900 Subject: [PATCH 191/232] pic_sym is now just an alias of int --- include/picrin/value.h | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/include/picrin/value.h b/include/picrin/value.h index aacd935d..37dd58c0 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -10,10 +10,10 @@ extern "C" { #endif /** - * pic_sym is just an alias of uint32_t. + * pic_sym is just an alias of int. */ -typedef uint32_t pic_sym; +typedef int pic_sym; /** * `undef` values never seen from user-end: that is, @@ -71,7 +71,14 @@ pic_int(pic_value v) return u.i; } -#define pic_sym(v) ((v) & 0xfffffffful) +static inline int +pic_sym(pic_value v) +{ + union { int i; unsigned u; } u; + u.u = v & 0xfffffffful; + return u.i; +} + #define pic_char(v) ((v) & 0xfffffffful) #else @@ -357,10 +364,13 @@ pic_int_value(int i) 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 |= sym; + v |= u.u; return v; } From 71f67cf771213fa40f50eb7fe257cff10f94c3a9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 15:11:36 +0900 Subject: [PATCH 192/232] simplify some mathematical functions implementations --- number.c | 33 ++++++++++++++++++++------------- 1 file changed, 20 insertions(+), 13 deletions(-) diff --git a/number.c b/number.c index 4c13df35..2ed93a79 100644 --- a/number.c +++ b/number.c @@ -271,7 +271,7 @@ pic_number_abs(pic_state *pic) pic_get_args(pic, "F", &f, &e); if (e) { - return pic_int_value(fabs(f)); + return pic_int_value(abs((int)f)); } else { return pic_float_value(fabs(f)); @@ -283,17 +283,23 @@ pic_number_floor2(pic_state *pic) { int i, j; bool e1, e2; - double q, r; pic_get_args(pic, "II", &i, &e1, &j, &e2); - q = floor((double)i/j); - r = i - j * q; - if (e1 && e2) { - return pic_values2(pic, pic_int_value(q), pic_int_value(r)); + int k; + + 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)); } else { + double q, r; + + q = floor((double)i/j); + r = i - j * q; return pic_values2(pic, pic_float_value(q), pic_float_value(r)); } } @@ -303,17 +309,18 @@ pic_number_trunc2(pic_state *pic) { int i, j; bool e1, e2; - double q, r; pic_get_args(pic, "II", &i, &e1, &j, &e2); - q = trunc((double)i/j); - r = i - j * q; - if (e1 && e2) { - return pic_values2(pic, pic_int_value(q), pic_int_value(r)); + return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j)); } else { + double q, r; + + q = trunc((double)i/j); + r = i - j * q; + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); } } @@ -516,7 +523,7 @@ pic_number_exact(pic_state *pic) pic_get_args(pic, "f", &f); - return pic_int_value((int)round(f)); + return pic_int_value((int)(round(f))); } static pic_value @@ -564,7 +571,7 @@ pic_number_string_to_number(pic_state *pic) num = strtol(str, &eptr, radix); if (*eptr == '\0') { return pic_valid_int(num) - ? pic_int_value(num) + ? pic_int_value((int)num) : pic_float_value(num); } From 4e5e3f4fae3d96d7977c8fc873441416b67ed0e6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 15:14:30 +0900 Subject: [PATCH 193/232] return value from pic_get_args is of int type --- var.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var.c b/var.c index 45aae9b0..ea9cbff5 100644 --- a/var.c +++ b/var.c @@ -37,7 +37,7 @@ var_call(pic_state *pic) { struct pic_proc *self = pic_get_proc(pic); pic_value val, tmp, box, conv; - size_t n; + int n; n = pic_get_args(pic, "|oo", &val, &tmp); From 781bd19d89e2aa0a2b241ffd095c8bdd4d9d610c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 15:14:43 +0900 Subject: [PATCH 194/232] clock_t can be cast to int type --- time.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/time.c b/time.c index 43d770b3..a0a1ffb6 100644 --- a/time.c +++ b/time.c @@ -27,7 +27,7 @@ pic_current_jiffy(pic_state *pic) pic_get_args(pic, ""); c = clock(); - return pic_int_value(c); + return pic_int_value((int)c); } static pic_value From 136680e8d290cee56e82cc31f61221df701cb2be Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 15:59:28 +0900 Subject: [PATCH 195/232] supporess maybe-uninitialized warning --- gc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gc.c b/gc.c index 6a53a361..7768f8b9 100644 --- a/gc.c +++ b/gc.c @@ -706,7 +706,7 @@ gc_sweep_page(pic_state *pic, struct heap_page *page) #else static union header *NIL = NULL; #endif - union header *bp, *p, *s = NIL, *t; + union header *bp, *p, *s = NIL, *t = NIL; #if GC_DEBUG int c = 0; From 68a900ee945f500bb23f6f21d77a71990be65eca Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 16:13:53 +0900 Subject: [PATCH 196/232] refactor port.c. strict type casts. --- port.c | 45 ++++++++++++++++++++++++++++----------------- 1 file changed, 28 insertions(+), 17 deletions(-) diff --git a/port.c b/port.c index 558a81b6..5cbcb1b8 100644 --- a/port.c +++ b/port.c @@ -87,12 +87,12 @@ pic_open_output_string(pic_state *pic) struct pic_string * pic_get_output_string(pic_state *pic, struct pic_port *port) { - long size; + size_t size; char *buf; /* get endpos */ xfflush(port->file); - size = xftell(port->file); + size = (size_t)xftell(port->file); xrewind(port->file); /* copy to buf */ @@ -347,7 +347,7 @@ pic_port_get_output_bytevector(pic_state *pic) { struct pic_port *port = pic_stdout(pic); pic_blob *blob; - long endpos; + size_t size; pic_get_args(pic, "|p", &port); @@ -355,12 +355,12 @@ pic_port_get_output_bytevector(pic_state *pic) /* get endpos */ xfflush(port->file); - endpos = xftell(port->file); + size = (size_t)xftell(port->file); xrewind(port->file); /* copy to buf */ - blob = pic_make_blob(pic, endpos); - xfread(blob->data, 1, endpos, port->file); + blob = pic_make_blob(pic, size); + xfread(blob->data, 1, size, port->file); return pic_obj_value(blob); } @@ -521,16 +521,21 @@ pic_port_read_blob(pic_state *pic) { struct pic_port *port = pic_stdin(pic); pic_blob *blob; - int k, i; + int k; + size_t i; - pic_get_args(pic, "i|p", &k, &port); + pic_get_args(pic, "i|p", &k, &port); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector"); - blob = pic_make_blob(pic, k); + if (k < 0) { + pic_errorf(pic, "read-bytevector: index must be non-negative %d", k); + } - i = xfread(blob->data, sizeof(char), k, port->file); - if ( i == 0 ) { + blob = pic_make_blob(pic, (size_t)k); + + i = xfread(blob->data, sizeof(char), (size_t)k, port->file); + if (i == 0) { return pic_eof_object(); } else { @@ -545,8 +550,9 @@ pic_port_read_blob_ip(pic_state *pic) { struct pic_port *port; struct pic_blob *bv; - int i, n, start, end, len; + int n, start, end; char *buf; + size_t i, len; n = pic_get_args(pic, "b|pii", &bv, &port, &start, &end); switch (n) { @@ -555,22 +561,27 @@ pic_port_read_blob_ip(pic_state *pic) case 2: start = 0; case 3: - end = bv->len; + end = (int)bv->len; } assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!"); - len = end - start; + + if (end - start < 0) { + pic_errorf(pic, "read-bytevector!: end index must be greater than or equal to start index"); + } + + len = (size_t)(end - start); buf = pic_calloc(pic, len, sizeof(char)); i = xfread(buf, sizeof(char), len, port->file); memcpy(bv->data + start, buf, i); pic_free(pic, buf); - if ( i == 0) { + if (i == 0) { return pic_eof_object(); } else { - return pic_int_value(i); + return pic_int_value((int)i); } } @@ -654,7 +665,7 @@ pic_port_write_blob(pic_state *pic) case 2: start = 0; case 3: - end = blob->len; + end = (int)blob->len; } assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector"); From f214cbf97404a1291375759e4f4dcb72abaf2719 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 16:27:19 +0900 Subject: [PATCH 197/232] refactor dict.c stritc type casts --- dict.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dict.c b/dict.c index 0746fbd9..13200c08 100644 --- a/dict.c +++ b/dict.c @@ -35,7 +35,7 @@ xh_value_hash(const void *key, void *data) break; } - return hash + pic_vtype(val); + return hash + (int)pic_vtype(val); } static int @@ -213,7 +213,7 @@ pic_dict_dictionary_size(pic_state *pic) pic_get_args(pic, "d", &dict); - return pic_int_value(pic_dict_size(pic, dict)); + return pic_int_value((int)pic_dict_size(pic, dict)); } static pic_value From 0a23eb4f11d9e118bbabcf6e992f68d268212c79 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 16:33:46 +0900 Subject: [PATCH 198/232] change int to size_t --- symbol.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/symbol.c b/symbol.c index c15a967d..0cbbf78a 100644 --- a/symbol.c +++ b/symbol.c @@ -57,7 +57,7 @@ pic_gensym(pic_state *pic, pic_sym base) } len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid); - str = pic_alloc(pic, len + 1); + 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 */ From de362c8f37340cf0f2c6e93b8339498a623b54a7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 16:47:23 +0900 Subject: [PATCH 199/232] strict error check on vector manipulation --- vector.c | 56 ++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 38 insertions(+), 18 deletions(-) diff --git a/vector.c b/vector.c index 2a3099f7..775895d3 100644 --- a/vector.c +++ b/vector.c @@ -26,11 +26,11 @@ struct pic_vector * pic_make_vec_from_list(pic_state *pic, pic_value data) { struct pic_vector *vec; - size_t i, len; + int len, i; len = pic_length(pic, data); - vec = pic_make_vec(pic, len); + vec = pic_make_vec(pic, (size_t)len); for (i = 0; i < len; ++i) { vec->data[i] = pic_car(pic, data); data = pic_cdr(pic, data); @@ -77,7 +77,11 @@ pic_vec_make_vector(pic_state *pic) n = pic_get_args(pic, "i|o", &k, &v); - vec = pic_make_vec(pic, k); + if (k < 0) { + pic_errorf(pic, "make-vector: vector length must be non-negative"); + } + + vec = pic_make_vec(pic, (size_t)k); if (n == 2) { for (i = 0; i < (size_t)k; ++i) { vec->data[i] = v; @@ -93,7 +97,7 @@ pic_vec_vector_length(pic_state *pic) pic_get_args(pic, "v", &v); - return pic_int_value(v->len); + return pic_int_value((int)v->len); } static pic_value @@ -138,7 +142,7 @@ pic_vec_vector_copy_i(pic_state *pic) case 3: start = 0; case 4: - end = from->len; + end = (int)from->len; } if (to == from && (start <= at && at < end)) { @@ -169,10 +173,14 @@ pic_vec_vector_copy(pic_state *pic) case 1: start = 0; case 2: - end = vec->len; + end = (int)vec->len; } - to = pic_make_vec(pic, end - start); + if (end - start < 0) { + pic_errorf(pic, "vector-copy: end index must not be less than start index"); + } + + to = pic_make_vec(pic, (size_t)(end - start)); while (start < end) { to->data[i++] = vec->data[start++]; } @@ -221,7 +229,7 @@ pic_vec_vector_fill_i(pic_state *pic) case 2: start = 0; case 3: - end = vec->len; + end = (int)vec->len; } while (start < end) { @@ -300,7 +308,7 @@ pic_vec_list_to_vector(pic_state *pic) pic_get_args(pic, "o", &list); - vec = pic_make_vec(pic, pic_length(pic, list)); + vec = pic_make_vec(pic, (size_t)pic_length(pic, list)); data = vec->data; @@ -323,7 +331,7 @@ pic_vec_vector_to_list(pic_state *pic) case 1: start = 0; case 2: - end = vec->len; + end = (int)vec->len; } list = pic_nil_value(); @@ -348,10 +356,14 @@ pic_vec_vector_to_string(pic_state *pic) case 1: start = 0; case 2: - end = vec->len; + end = (int)vec->len; } - buf = pic_alloc(pic, end - start); + if (end - start < 0) { + pic_errorf(pic, "vector->string: end index must not be less than start index"); + } + + buf = pic_alloc(pic, (size_t)(end - start)); for (i = start; i < end; ++i) { pic_assert_type(pic, vec->data[i], char); @@ -359,7 +371,7 @@ pic_vec_vector_to_string(pic_state *pic) buf[i - start] = pic_char(vec->data[i]); } - str = pic_make_str(pic, buf, end - start); + str = pic_make_str(pic, buf, (size_t)(end - start)); pic_free(pic, buf); return pic_obj_value(str); @@ -369,7 +381,8 @@ static pic_value pic_vec_string_to_vector(pic_state *pic) { pic_str *str; - int n, start, end, i; + int n, start, end; + size_t i; pic_vec *vec; n = pic_get_args(pic, "s|ii", &str, &start, &end); @@ -378,13 +391,20 @@ pic_vec_string_to_vector(pic_state *pic) case 1: start = 0; case 2: - end = pic_strlen(str); + end = (int)pic_strlen(str); } - vec = pic_make_vec(pic, end - start); + if (start < 0) { + pic_errorf(pic, "string->vector: index must non-negative"); + } + if (end - start < 0) { + pic_errorf(pic, "string->vector: end index must not be less than start index"); + } - for (i = start; i < end; ++i) { - vec->data[i - start] = pic_char_value(pic_str_ref(pic, str, i)); + vec = pic_make_vec(pic, (size_t)(end - start)); + + for (i = 0; i < (size_t)(end - start); ++i) { + vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + (size_t)start)); } return pic_obj_value(vec); } From a75ff9f2b0790d3398f969cc3a4079b69f10967a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 17:04:20 +0900 Subject: [PATCH 200/232] argc should be int --- blob.c | 5 +++-- bool.c | 2 +- char.c | 3 +-- cont.c | 4 ++-- dict.c | 2 +- error.c | 4 ++-- lib.c | 8 ++++---- number.c | 9 +++------ pair.c | 10 ++++------ proc.c | 2 +- string.c | 14 +++++++------- symbol.c | 2 +- vector.c | 12 +++++++----- vm.c | 4 ++-- 14 files changed, 39 insertions(+), 42 deletions(-) diff --git a/blob.c b/blob.c index e927f4ff..d87afc83 100644 --- a/blob.c +++ b/blob.c @@ -33,7 +33,7 @@ static pic_value pic_blob_bytevector(pic_state *pic) { pic_value *argv; - size_t argc, i; + int argc, i; pic_blob *blob; unsigned char *data; @@ -176,7 +176,8 @@ pic_blob_bytevector_copy(pic_state *pic) static pic_value pic_blob_bytevector_append(pic_state *pic) { - size_t argc, i, j, len; + size_t j, len; + int argc, i; pic_value *argv; pic_blob *blob; diff --git a/bool.c b/bool.c index 8f8c75f1..ff5528e9 100644 --- a/bool.c +++ b/bool.c @@ -172,7 +172,7 @@ pic_bool_boolean_p(pic_state *pic) static pic_value pic_bool_boolean_eq_p(pic_state *pic) { - size_t argc, i; + int argc, i; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); diff --git a/char.c b/char.c index 98eed6f7..f08fcdd0 100644 --- a/char.c +++ b/char.c @@ -42,9 +42,8 @@ pic_char_integer_to_char(pic_state *pic) static pic_value \ pic_char_##name##_p(pic_state *pic) \ { \ - size_t argc; \ + int argc, i; \ pic_value *argv; \ - size_t i; \ char c, d; \ \ pic_get_args(pic, "cc*", &c, &d, &argc, &argv); \ diff --git a/cont.c b/cont.c index f010f532..39ec7861 100644 --- a/cont.c +++ b/cont.c @@ -96,7 +96,7 @@ pic_load_point(pic_state *pic, struct pic_escape *escape) noreturn static pic_value escape_call(pic_state *pic) { - size_t argc; + int argc; pic_value *argv; struct pic_data *e; @@ -251,7 +251,7 @@ pic_cont_dynamic_wind(pic_state *pic) static pic_value pic_cont_values(pic_state *pic) { - size_t argc; + int argc; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); diff --git a/dict.c b/dict.c index 13200c08..2a8fcd41 100644 --- a/dict.c +++ b/dict.c @@ -142,7 +142,7 @@ pic_dict_dictionary(pic_state *pic) { struct pic_dict *dict; pic_value *argv; - size_t argc, i; + int argc, i; pic_get_args(pic, "*", &argc, &argv); diff --git a/error.c b/error.c index b25cbb42..568e523b 100644 --- a/error.c +++ b/error.c @@ -243,7 +243,7 @@ noreturn static pic_value pic_error_error(pic_state *pic) { const char *str; - size_t argc; + int argc; pic_value *argv; pic_get_args(pic, "z*", &str, &argc, &argv); @@ -257,7 +257,7 @@ pic_error_make_error_object(pic_state *pic) struct pic_error *e; pic_sym type; pic_str *msg; - size_t argc; + int argc; pic_value *argv; pic_get_args(pic, "ms*", &type, &msg, &argc, &argv); diff --git a/lib.c b/lib.c index 37cba2bd..cd760f18 100644 --- a/lib.c +++ b/lib.c @@ -253,7 +253,7 @@ static pic_value pic_lib_condexpand(pic_state *pic) { pic_value *clauses; - size_t argc, i; + int argc, i; pic_get_args(pic, "*", &argc, &clauses); @@ -269,7 +269,7 @@ pic_lib_condexpand(pic_state *pic) static pic_value pic_lib_import(pic_state *pic) { - size_t argc, i; + int argc, i; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); @@ -284,7 +284,7 @@ pic_lib_import(pic_state *pic) static pic_value pic_lib_export(pic_state *pic) { - size_t argc, i; + int argc, i; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); @@ -300,7 +300,7 @@ static pic_value pic_lib_define_library(pic_state *pic) { struct pic_lib *prev = pic->lib; - size_t argc, i; + int argc, i; pic_value spec, *argv; pic_get_args(pic, "o*", &spec, &argc, &argv); diff --git a/number.c b/number.c index 2ed93a79..c72f58ca 100644 --- a/number.c +++ b/number.c @@ -162,9 +162,8 @@ pic_number_nan_p(pic_state *pic) static pic_value \ pic_number_##name(pic_state *pic) \ { \ - size_t argc; \ + int argc, i; \ pic_value *argv; \ - size_t i; \ double f,g; \ \ pic_get_args(pic, "ff*", &f, &g, &argc, &argv); \ @@ -198,9 +197,8 @@ DEFINE_ARITH_CMP(>=, ge) static pic_value \ pic_number_##name(pic_state *pic) \ { \ - size_t argc; \ + int argc, i; \ pic_value *argv; \ - size_t i; \ double f; \ bool e = true; \ \ @@ -230,9 +228,8 @@ DEFINE_ARITH_OP(*, mul, 1) static pic_value \ pic_number_##name(pic_state *pic) \ { \ - size_t argc; \ + int argc, i; \ pic_value *argv; \ - size_t i; \ double f; \ bool e; \ \ diff --git a/pair.c b/pair.c index ee2263c7..b6def852 100644 --- a/pair.c +++ b/pair.c @@ -544,7 +544,7 @@ pic_pair_make_list(pic_state *pic) static pic_value pic_pair_list(pic_state *pic) { - size_t argc; + int argc; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); @@ -565,7 +565,7 @@ pic_pair_length(pic_state *pic) static pic_value pic_pair_append(pic_state *pic) { - size_t argc; + int argc; pic_value *args, list; pic_get_args(pic, "*", &argc, &args); @@ -641,9 +641,8 @@ static pic_value pic_pair_map(pic_state *pic) { struct pic_proc *proc; - size_t argc; + int argc, i; pic_value *args; - int i; pic_value cars, ret; pic_get_args(pic, "l*", &proc, &argc, &args); @@ -670,9 +669,8 @@ static pic_value pic_pair_for_each(pic_state *pic) { struct pic_proc *proc; - size_t argc; + int argc, i; pic_value *args; - int i; pic_value cars; pic_get_args(pic, "l*", &proc, &argc, &args); diff --git a/proc.c b/proc.c index 210f157d..0d67ddd7 100644 --- a/proc.c +++ b/proc.c @@ -61,7 +61,7 @@ pic_proc_apply(pic_state *pic) { struct pic_proc *proc; pic_value *args; - size_t argc; + int argc; pic_value arg_list; pic_get_args(pic, "l*", &proc, &argc, &args); diff --git a/string.c b/string.c index b53055f4..2372ea31 100644 --- a/string.c +++ b/string.c @@ -233,11 +233,10 @@ pic_str_string_p(pic_state *pic) static pic_value pic_str_string(pic_state *pic) { - size_t argc; + int argc, i; pic_value *argv; pic_str *str; char *buf; - size_t i; pic_get_args(pic, "*", &argc, &argv); @@ -290,9 +289,8 @@ pic_str_string_ref(pic_state *pic) static pic_value \ pic_str_string_##name(pic_state *pic) \ { \ - size_t argc; \ + int argc, i; \ pic_value *argv; \ - size_t i; \ \ pic_get_args(pic, "*", &argc, &argv); \ \ @@ -338,7 +336,7 @@ pic_str_string_copy(pic_state *pic) static pic_value pic_str_string_append(pic_state *pic) { - size_t argc, i; + int argc, i; pic_value *argv; pic_str *str; @@ -358,8 +356,9 @@ static pic_value pic_str_string_map(pic_state *pic) { struct pic_proc *proc; - size_t argc, i, len, j; + int argc, i; pic_value *argv, vals, val; + size_t len, j; pic_get_args(pic, "l*", &proc, &argc, &argv); @@ -396,7 +395,8 @@ static pic_value pic_str_string_for_each(pic_state *pic) { struct pic_proc *proc; - size_t argc, i, len, j; + int argc, i; + size_t len, j; pic_value *argv, vals, val; pic_get_args(pic, "l*", &proc, &argc, &argv); diff --git a/symbol.c b/symbol.c index 0cbbf78a..d6feab13 100644 --- a/symbol.c +++ b/symbol.c @@ -108,7 +108,7 @@ pic_symbol_symbol_p(pic_state *pic) static pic_value pic_symbol_symbol_eq_p(pic_state *pic) { - size_t argc, i; + int argc, i; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); diff --git a/vector.c b/vector.c index 775895d3..4378e66c 100644 --- a/vector.c +++ b/vector.c @@ -51,10 +51,9 @@ pic_vec_vector_p(pic_state *pic) static pic_value pic_vec_vector(pic_state *pic) { - size_t argc; + int argc, i; pic_value *argv; pic_vec *vec; - size_t i; pic_get_args(pic, "*", &argc, &argv); @@ -191,8 +190,9 @@ pic_vec_vector_copy(pic_state *pic) static pic_value pic_vec_vector_append(pic_state *pic) { - size_t argc, i, j, len; + int argc, i; pic_value *argv; + size_t j, len; pic_vec *vec; pic_get_args(pic, "*", &argc, &argv); @@ -243,8 +243,9 @@ static pic_value pic_vec_vector_map(pic_state *pic) { struct pic_proc *proc; - size_t argc, i, len, j; + int argc, i; pic_value *argv, vals; + size_t len, j; pic_vec *vec; pic_get_args(pic, "l*", &proc, &argc, &argv); @@ -275,8 +276,9 @@ static pic_value pic_vec_vector_for_each(pic_state *pic) { struct pic_proc *proc; - size_t argc, i, len, j; + int argc, i; pic_value *argv, vals; + size_t len, j; pic_get_args(pic, "l*", &proc, &argc, &argv); diff --git a/vm.c b/vm.c index 92af1ce7..a996742e 100644 --- a/vm.c +++ b/vm.c @@ -386,10 +386,10 @@ pic_get_args(pic_state *pic, const char *format, ...) } } if ('*' == c) { - size_t *n; + int *n; pic_value **argv; - n = va_arg(ap, size_t *); + n = va_arg(ap, int *); argv = va_arg(ap, pic_value **); if (i <= argc) { *n = argc - i; From 7ab9708ed067588ca7451ae93703e82bf421fa12 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 17:09:52 +0900 Subject: [PATCH 201/232] passing array with a pair of int and pic_value * --- cont.c | 14 +++++++------- include/picrin/cont.h | 4 ++-- include/picrin/pair.h | 2 +- pair.c | 2 +- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/cont.c b/cont.c index 39ec7861..4b980e4a 100644 --- a/cont.c +++ b/cont.c @@ -184,9 +184,9 @@ pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_ } pic_value -pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv) +pic_values_by_array(pic_state *pic, int argc, pic_value *argv) { - size_t i; + int i; for (i = 0; i < argc; ++i) { pic->sp[i] = argv[i]; @@ -200,7 +200,7 @@ pic_value pic_values_by_list(pic_state *pic, pic_value list) { pic_value v; - size_t i; + int i; i = 0; pic_for_each (v, list) { @@ -211,11 +211,11 @@ pic_values_by_list(pic_state *pic, pic_value list) return pic_nil_p(list) ? pic_none_value() : pic->sp[0]; } -size_t -pic_receive(pic_state *pic, size_t n, pic_value *argv) +int +pic_receive(pic_state *pic, int n, pic_value *argv) { pic_callinfo *ci; - size_t i, retc; + int i, retc; /* take info from discarded frame */ ci = pic->ci + 1; @@ -263,7 +263,7 @@ static pic_value pic_cont_call_with_values(pic_state *pic) { struct pic_proc *producer, *consumer; - size_t argc; + int argc; pic_value args[256]; pic_get_args(pic, "ll", &producer, &consumer); diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 645e6d9c..01e86e11 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -40,9 +40,9 @@ pic_value pic_values2(pic_state *, pic_value, pic_value); pic_value pic_values3(pic_state *, pic_value, pic_value, pic_value); pic_value pic_values4(pic_state *, pic_value, pic_value, pic_value, pic_value); pic_value pic_values5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_values_by_array(pic_state *, size_t, pic_value *); +pic_value pic_values_by_array(pic_state *, int, pic_value *); pic_value pic_values_by_list(pic_state *, pic_value); -size_t pic_receive(pic_state *, size_t, pic_value *); +int pic_receive(pic_state *, int, pic_value *); pic_value pic_escape(pic_state *, struct pic_proc *); diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 16c61863..49e3f73f 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -56,7 +56,7 @@ pic_value pic_list4(pic_state *, pic_value, pic_value, pic_value, pic_value); pic_value pic_list5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); pic_value pic_list6(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list_by_array(pic_state *, size_t, pic_value *); +pic_value pic_list_by_array(pic_state *, int, pic_value *); pic_value pic_make_list(pic_state *, int, pic_value); #define pic_for_each(var, list) \ diff --git a/pair.c b/pair.c index b6def852..6a9687d8 100644 --- a/pair.c +++ b/pair.c @@ -160,7 +160,7 @@ pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_va } pic_value -pic_list_by_array(pic_state *pic, size_t c, pic_value *vs) +pic_list_by_array(pic_state *pic, int c, pic_value *vs) { pic_value v; From 7b0ec3adde85bbaab2350493248f5a4aaad63eab Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 17:13:17 +0900 Subject: [PATCH 202/232] adjustment. amending for argc type change --- blob.c | 2 +- vector.c | 12 +++++------- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/blob.c b/blob.c index d87afc83..da3907c3 100644 --- a/blob.c +++ b/blob.c @@ -39,7 +39,7 @@ pic_blob_bytevector(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - blob = pic_make_blob(pic, argc); + blob = pic_make_blob(pic, (size_t)argc); data = blob->data; diff --git a/vector.c b/vector.c index 4378e66c..6ae7f136 100644 --- a/vector.c +++ b/vector.c @@ -57,7 +57,7 @@ pic_vec_vector(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - vec = pic_make_vec(pic, argc); + vec = pic_make_vec(pic, (size_t)argc); for (i = 0; i < argc; ++i) { vec->data[i] = argv[i]; @@ -243,14 +243,13 @@ static pic_value pic_vec_vector_map(pic_state *pic) { struct pic_proc *proc; - int argc, i; + int argc, i, len, j; pic_value *argv, vals; - size_t len, j; pic_vec *vec; pic_get_args(pic, "l*", &proc, &argc, &argv); - len = SIZE_MAX; + len = INT_MAX; for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], vec); @@ -276,13 +275,12 @@ static pic_value pic_vec_vector_for_each(pic_state *pic) { struct pic_proc *proc; - int argc, i; + int argc, i, len, j; pic_value *argv, vals; - size_t len, j; pic_get_args(pic, "l*", &proc, &argc, &argv); - len = SIZE_MAX; + len = INT_MAX; for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], vec); From cb54f0e065db793256340be80ddaff8824cbdec9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 17:36:00 +0900 Subject: [PATCH 203/232] int and size_t --- codegen.c | 11 +++++------ vector.c | 14 ++++++++------ 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/codegen.c b/codegen.c index 55bb8587..050f18c2 100644 --- a/codegen.c +++ b/codegen.c @@ -490,7 +490,6 @@ analyze_if(analyze_state *state, pic_value obj, bool tailpos) switch (pic_length(pic, obj)) { default: pic_errorf(pic, "syntax error"); - break; case 4: if_false = pic_list_ref(pic, obj, 3); FALLTHROUGH; @@ -956,7 +955,7 @@ create_activation(codegen_context *cxt) if ((n = xh_val(xh_get_int(®s, *var), size_t)) <= 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 = n; + cxt->code[cxt->clen].u.i = (int)n; cxt->clen++; } else { /* otherwise, just extend the stack */ @@ -1030,9 +1029,9 @@ 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 = xv_size(&state->cxt->args) + 1; - irep->localc = xv_size(&state->cxt->locals); - irep->capturec = 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); @@ -1067,7 +1066,7 @@ index_capture(codegen_state *state, pic_sym sym, int depth) for (i = 0; i < xv_size(&cxt->captures); ++i) { var = xv_get(&cxt->captures, i); if (*var == sym) - return i; + return (int)i; } return -1; } diff --git a/vector.c b/vector.c index 6ae7f136..ba0dc7c8 100644 --- a/vector.c +++ b/vector.c @@ -243,14 +243,15 @@ static pic_value pic_vec_vector_map(pic_state *pic) { struct pic_proc *proc; - int argc, i, len, j; + int argc; + size_t i, len, j; pic_value *argv, vals; pic_vec *vec; pic_get_args(pic, "l*", &proc, &argc, &argv); len = INT_MAX; - for (i = 0; i < argc; ++i) { + for (i = 0; i < (size_t)argc; ++i) { pic_assert_type(pic, argv[i], vec); len = len < pic_vec_ptr(argv[i])->len @@ -262,7 +263,7 @@ pic_vec_vector_map(pic_state *pic) for (i = 0; i < len; ++i) { vals = pic_nil_value(); - for (j = 0; j < argc; ++j) { + for (j = 0; j < (size_t)argc; ++j) { pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); } vec->data[i] = pic_apply(pic, proc, vals); @@ -275,13 +276,14 @@ static pic_value pic_vec_vector_for_each(pic_state *pic) { struct pic_proc *proc; - int argc, i, len, j; + int argc; + size_t i, len, j; pic_value *argv, vals; pic_get_args(pic, "l*", &proc, &argc, &argv); len = INT_MAX; - for (i = 0; i < argc; ++i) { + for (i = 0; i < (size_t)argc; ++i) { pic_assert_type(pic, argv[i], vec); len = len < pic_vec_ptr(argv[i])->len @@ -291,7 +293,7 @@ pic_vec_vector_for_each(pic_state *pic) for (i = 0; i < len; ++i) { vals = pic_nil_value(); - for (j = 0; j < argc; ++j) { + for (j = 0; j < (size_t)argc; ++j) { pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); } pic_apply(pic, proc, vals); From 315c17c8d41a53c832d2e883cb578dff39dbeb12 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 17:36:27 +0900 Subject: [PATCH 204/232] move stack overflow checker --- vm.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/vm.c b/vm.c index a996742e..58e5967f 100644 --- a/vm.c +++ b/vm.c @@ -581,7 +581,7 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2 # define VM_LOOP_END } } #endif -#define PUSH(v) ((pic->sp >= pic->stend) ? abort() : (*pic->sp++ = (v))) +#define PUSH(v) (*pic->sp++ = (v)) #define POP() (*--pic->sp) #define PUSHCI() (++pic->ci) @@ -843,6 +843,10 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) VM_CALL_PRINT; + if (pic->sp >= pic->stend) { + pic_panic(pic, "VM stack overflow"); + } + ci = PUSHCI(); ci->argc = c.u.i; ci->retc = 1; From 490472af2f662f51fe7918e1d907804b999f8d49 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 17:36:47 +0900 Subject: [PATCH 205/232] resolve VM's varaible shadows --- vm.c | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/vm.c b/vm.c index 58e5967f..1eac9f91 100644 --- a/vm.c +++ b/vm.c @@ -650,11 +650,10 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2 #endif pic_value -pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) +pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) { pic_code c; size_t ai = pic_gc_arena_preserve(pic); - size_t argc, i; pic_code boot[2]; #if PIC_DIRECT_THREADED_VM @@ -674,26 +673,29 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) pic_callinfo *cibase; #endif - if (! pic_list_p(argv)) { + if (! pic_list_p(args)) { pic_errorf(pic, "argv must be a proper list"); } + else { + int argc, i; - argc = pic_length(pic, argv) + 1; + argc = pic_length(pic, args) + 1; - VM_BOOT_PRINT; + VM_BOOT_PRINT; - PUSH(pic_obj_value(proc)); - for (i = 1; i < argc; ++i) { - PUSH(pic_car(pic, argv)); - argv = pic_cdr(pic, argv); + PUSH(pic_obj_value(proc)); + for (i = 1; i < argc; ++i) { + PUSH(pic_car(pic, args)); + args = pic_cdr(pic, args); + } + + /* boot! */ + boot[0].insn = OP_CALL; + boot[0].u.i = argc; + boot[1].insn = OP_STOP; + pic->ip = boot; } - /* boot! */ - boot[0].insn = OP_CALL; - boot[0].u.i = argc; - boot[1].insn = OP_STOP; - pic->ip = boot; - VM_LOOP { CASE(OP_NOP) { NEXT; @@ -827,7 +829,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) CASE(OP_CALL) { pic_value x, v; pic_callinfo *ci; - struct pic_proc *proc; if (c.u.i == -1) { pic->sp += pic->ci[1].retc - 1; @@ -958,7 +959,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) CASE(OP_LAMBDA) { pic_value self; struct pic_irep *irep; - struct pic_proc *proc; self = pic->ci->fp[0]; if (! pic_proc_p(self)) { From 5cfa89ba2344cf949ba7f4614438250e60a9a3c7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 17:38:58 +0900 Subject: [PATCH 206/232] starndard style initializer --- vm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm.c b/vm.c index 1eac9f91..832fb2ce 100644 --- a/vm.c +++ b/vm.c @@ -1094,7 +1094,7 @@ pic_value pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) { static const pic_code iseq[2] = { - { OP_NOP, {} }, + { OP_NOP, { .i = 0 } }, { OP_TAILCALL, { .i = -1 } } }; From 36328c154b918d36a18c97db61690b8462ab649d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 17:39:11 +0900 Subject: [PATCH 207/232] more fix on misc functions in vm.c --- vm.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vm.c b/vm.c index 832fb2ce..7cc84d96 100644 --- a/vm.c +++ b/vm.c @@ -280,14 +280,14 @@ pic_get_args(pic_state *pic, const char *format, ...) break; } case 'c': { - char *c; + char *k; pic_value v; - c = va_arg(ap, char *); + k = va_arg(ap, char *); if (i < argc) { v = GET_OPERAND(pic,i); if (pic_char_p(v)) { - *c = pic_char(v); + *k = pic_char(v); } else { pic_errorf(pic, "pic_get_args: expected char, but got ~s", v); @@ -488,7 +488,7 @@ vm_push_env(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) * ci->regc, PIC_TT_ENV); + 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; From 9906865932edbaf4cddac6127bb83070bce9aef9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 23:24:17 +0900 Subject: [PATCH 208/232] explicit int to size_t cast --- codegen.c | 6 +++--- string.c | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/codegen.c b/codegen.c index 050f18c2..fec7ad43 100644 --- a/codegen.c +++ b/codegen.c @@ -1075,17 +1075,17 @@ static int index_local(codegen_state *state, pic_sym sym) { codegen_context *cxt = state->cxt; - size_t i, offset; + int i, offset; pic_sym *var; offset = 1; - for (i = 0; i < xv_size(&cxt->args); ++i) { + for (i = 0; i < (int)xv_size(&cxt->args); ++i) { var = xv_get(&cxt->args, i); if (*var == sym) return i + offset; } offset += i; - for (i = 0; i < xv_size(&cxt->locals); ++i) { + for (i = 0; i < (int)xv_size(&cxt->locals); ++i) { var = xv_get(&cxt->locals, i); if (*var == sym) return i + offset; diff --git a/string.c b/string.c index 2372ea31..3bad3daf 100644 --- a/string.c +++ b/string.c @@ -463,7 +463,7 @@ pic_str_string_to_list(pic_state *pic) case 1: start = 0; case 2: - end = pic_strlen(str); + end = (int)pic_strlen(str); } list = pic_nil_value(); From f8a32d7d60ff18b7e7851b6b40d23d3f2c64be4d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Sep 2014 23:24:26 +0900 Subject: [PATCH 209/232] use ptrdiff to extend exception handler stack --- error.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/error.c b/error.c index 568e523b..0f3ac651 100644 --- a/error.c +++ b/error.c @@ -90,7 +90,8 @@ void pic_push_try(pic_state *pic, struct pic_escape *escape) { struct pic_proc *cont, *handler; - size_t xp_len, xp_offset; + size_t xp_len; + ptrdiff_t xp_offset; cont = pic_make_econt(pic, escape); @@ -99,7 +100,7 @@ pic_push_try(pic_state *pic, struct pic_escape *escape) pic_attr_set(pic, pic_obj_value(handler), "@@escape", pic_obj_value(cont)); if (pic->xp >= pic->xpend) { - xp_len = (pic->xpend - pic->xpbase) * 2; + 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; @@ -198,12 +199,13 @@ pic_error_with_exception_handler(pic_state *pic) { struct pic_proc *handler, *thunk; pic_value val; - size_t xp_len, xp_offset; + size_t xp_len; + ptrdiff_t xp_offset; pic_get_args(pic, "ll", &handler, &thunk); if (pic->xp >= pic->xpend) { - xp_len = (pic->xpend - pic->xpbase) * 2; + 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; From 7350f7e71e10b7813b88be1e6360bbad148bc028 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 17:18:11 +0900 Subject: [PATCH 210/232] int to size_t conversion --- codegen.c | 26 +++++++++++++------------- include/picrin/irep.h | 4 ++-- string.c | 4 ++-- symbol.c | 2 +- system.c | 2 +- 5 files changed, 19 insertions(+), 19 deletions(-) diff --git a/codegen.c b/codegen.c index fec7ad43..c4e3121e 100644 --- a/codegen.c +++ b/codegen.c @@ -1075,20 +1075,20 @@ static int index_local(codegen_state *state, pic_sym sym) { codegen_context *cxt = state->cxt; - int i, offset; + size_t i, offset; pic_sym *var; offset = 1; - for (i = 0; i < (int)xv_size(&cxt->args); ++i) { + for (i = 0; i < xv_size(&cxt->args); ++i) { var = xv_get(&cxt->args, i); if (*var == sym) - return i + offset; + return (int)(i + offset); } offset += i; - for (i = 0; i < (int)xv_size(&cxt->locals); ++i) { + for (i = 0; i < xv_size(&cxt->locals); ++i) { var = xv_get(&cxt->locals, i); if (*var == sym) - return i + offset; + return (int)(i + offset); } return -1; } @@ -1126,7 +1126,7 @@ codegen(codegen_state *state, pic_value obj) name = pic_sym(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 + xv_size(&cxt->args) + xv_size(&cxt->locals) + 1; + cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1; cxt->clen++; return; } @@ -1172,7 +1172,7 @@ codegen(codegen_state *state, pic_value obj) name = pic_sym(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 + xv_size(&cxt->args) + xv_size(&cxt->locals) + 1; + 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++; @@ -1193,7 +1193,7 @@ codegen(codegen_state *state, pic_value obj) cxt->icapa *= 2; cxt->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->icapa); } - k = cxt->ilen++; + k = (int)cxt->ilen++; cxt->code[cxt->clen].insn = OP_LAMBDA; cxt->code[cxt->clen].u.i = k; cxt->clen++; @@ -1207,18 +1207,18 @@ codegen(codegen_state *state, pic_value obj) codegen(state, pic_list_ref(pic, obj, 1)); cxt->code[cxt->clen].insn = OP_JMPIF; - s = cxt->clen++; + s = (int)cxt->clen++; /* if false branch */ codegen(state, pic_list_ref(pic, obj, 3)); cxt->code[cxt->clen].insn = OP_JMP; - t = cxt->clen++; + t = (int)cxt->clen++; - cxt->code[s].u.i = cxt->clen - s; + cxt->code[s].u.i = (int)cxt->clen - s; /* if true branch */ codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[t].u.i = cxt->clen - t; + cxt->code[t].u.i = (int)cxt->clen - t; return; } else if (sym == pic->sBEGIN) { @@ -1266,7 +1266,7 @@ codegen(codegen_state *state, pic_value obj) cxt->pcapa *= 2; cxt->pool = pic_realloc(pic, cxt->pool, sizeof(pic_value) * cxt->pcapa); } - pidx = cxt->plen++; + pidx = (int)cxt->plen++; cxt->pool[pidx] = obj; cxt->code[cxt->clen].insn = OP_PUSHCONST; cxt->code[cxt->clen].u.i = pidx; diff --git a/include/picrin/irep.h b/include/picrin/irep.h index c6e5befb..fe924bbc 100644 --- a/include/picrin/irep.h +++ b/include/picrin/irep.h @@ -52,8 +52,8 @@ struct pic_code { int i; char c; struct { - short depth; - short idx; + int depth; + int idx; } r; } u; }; diff --git a/string.c b/string.c index 3bad3daf..7f03cfae 100644 --- a/string.c +++ b/string.c @@ -240,14 +240,14 @@ pic_str_string(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - buf = pic_alloc(pic, argc); + buf = pic_alloc(pic, (size_t)argc); for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], char); buf[i] = pic_char(argv[i]); } - str = pic_make_str(pic, buf, argc); + str = pic_make_str(pic, buf, (size_t)argc); pic_free(pic, buf); return pic_obj_value(str); diff --git a/symbol.c b/symbol.c index d6feab13..7e9f1b52 100644 --- a/symbol.c +++ b/symbol.c @@ -80,7 +80,7 @@ pic_ungensym(pic_state *pic, pic_sym base) if ((occr = strrchr(name, '@')) == NULL) { pic_panic(pic, "logic flaw"); } - return pic_intern(pic, name, occr - name); + return pic_intern(pic, name, (size_t)(occr - name)); } bool diff --git a/system.c b/system.c index 4c54b905..e9ef1aa9 100644 --- a/system.c +++ b/system.c @@ -110,7 +110,7 @@ pic_system_getenvs(pic_state *pic) for (i = 0; (*envp)[i] != '='; ++i) ; - key = pic_make_str(pic, *envp, i); + key = pic_make_str(pic, *envp, (size_t)i); val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key))); /* push */ From 186bad0503977d9cdf1e4533812986166288fc3f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 17:19:16 +0900 Subject: [PATCH 211/232] pair functions must use size_t for index, not int --- include/picrin/pair.h | 10 +++++----- pair.c | 14 +++++++------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 49e3f73f..d6cf779d 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -57,7 +57,7 @@ pic_value pic_list5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic pic_value pic_list6(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); pic_value pic_list_by_array(pic_state *, int, pic_value *); -pic_value pic_make_list(pic_state *, int, pic_value); +pic_value pic_make_list(pic_state *, size_t, pic_value); #define pic_for_each(var, list) \ pic_for_each_helper_(var, GENSYM(tmp), list) @@ -69,7 +69,7 @@ pic_value pic_make_list(pic_state *, int, pic_value); #define pic_push(pic, item, place) (place = pic_cons(pic, item, place)) #define pic_pop(pic, place) (place = pic_cdr(pic, place)) -int pic_length(pic_state *, pic_value); +size_t pic_length(pic_state *, pic_value); pic_value pic_reverse(pic_state *, pic_value); pic_value pic_append(pic_state *, pic_value, pic_value); @@ -88,9 +88,9 @@ pic_value pic_cadr(pic_state *, pic_value); pic_value pic_cdar(pic_state *, pic_value); pic_value pic_cddr(pic_state *, pic_value); -pic_value pic_list_tail(pic_state *, pic_value, int); -pic_value pic_list_ref(pic_state *, pic_value, int); -void pic_list_set(pic_state *, pic_value, int, pic_value); +pic_value pic_list_tail(pic_state *, pic_value, size_t); +pic_value pic_list_ref(pic_state *, pic_value, size_t); +void pic_list_set(pic_state *, pic_value, size_t, pic_value); pic_value pic_list_copy(pic_state *, pic_value); #if defined(__cplusplus) diff --git a/pair.c b/pair.c index 6a9687d8..c2a775dc 100644 --- a/pair.c +++ b/pair.c @@ -172,10 +172,10 @@ pic_list_by_array(pic_state *pic, int c, pic_value *vs) } pic_value -pic_make_list(pic_state *pic, int k, pic_value fill) +pic_make_list(pic_state *pic, size_t k, pic_value fill) { pic_value list; - int i; + size_t i; list = pic_nil_value(); for (i = 0; i < k; ++i) { @@ -185,10 +185,10 @@ pic_make_list(pic_state *pic, int k, pic_value fill) return list; } -int +size_t pic_length(pic_state *pic, pic_value obj) { - int c = 0; + size_t c = 0; if (! pic_list_p(obj)) { pic_errorf(pic, "length: expected list, but got ~s", obj); @@ -375,7 +375,7 @@ pic_cddr(pic_state *pic, pic_value v) } pic_value -pic_list_tail(pic_state *pic, pic_value list, int i) +pic_list_tail(pic_state *pic, pic_value list, size_t i) { while (i-- > 0) { list = pic_cdr(pic, list); @@ -384,13 +384,13 @@ pic_list_tail(pic_state *pic, pic_value list, int i) } pic_value -pic_list_ref(pic_state *pic, pic_value list, int i) +pic_list_ref(pic_state *pic, pic_value list, size_t i) { return pic_car(pic, pic_list_tail(pic, list, i)); } void -pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj) +pic_list_set(pic_state *pic, pic_value list, size_t i, pic_value obj) { pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj; } From 4ac6c2b7ab6a6b813d5f1d2712ba6a496b6f4cc3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 17:33:49 +0900 Subject: [PATCH 212/232] refine description of pic_get_args --- vm.c | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/vm.c b/vm.c index 7cc84d96..7599c919 100644 --- a/vm.c +++ b/vm.c @@ -35,26 +35,26 @@ pic_get_proc(pic_state *pic) } /** - * char type - * ---- ---- - * o object - * i int - * I int with exactness - * f float - * F float with exactness - * s string object - * z c string - * m symbol - * v vector object - * b bytevector object - * c char - * l lambda object - * p port object - * d dictionary object - * e error object + * char type desc. + * ---- ---- ---- + * o pic_value * object + * i int * int + * I int *, bool * int with exactness + * f double * float + * F double *, bool * float with exactness + * s pic_str ** string object + * z char ** c string + * m pic_sym * symbol + * v pic_vec ** vector object + * b pic_blob ** bytevector object + * c char * char + * l struct pic_proc ** lambda object + * p struct pic_port ** port object + * d struct pic_dict ** dictionary object + * e struct pic_error ** error object * - * | optional operator - * * variable length operator + * | optional operator + * * int *, pic_value ** variable length operator */ int From bfc45a228ba166416f97e6355c2c7147757f9ab7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 17:47:47 +0900 Subject: [PATCH 213/232] add 'k' specifier to pic_get_args format --- vm.c | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/vm.c b/vm.c index 7599c919..97e21bf6 100644 --- a/vm.c +++ b/vm.c @@ -40,6 +40,7 @@ pic_get_proc(pic_state *pic) * o pic_value * object * i int * int * I int *, bool * int with exactness + * k size_t * size_t implicitly converted from int * f double * float * F double *, bool * float with exactness * s pic_str ** string object @@ -196,6 +197,33 @@ pic_get_args(pic_state *pic, const char *format, ...) } break; } + case 'k': { + size_t *k; + + 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) && (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); + } + i++; + } + break; + } case 's': { pic_str **str; pic_value v; From 8bdf6230546644b89a94722a8ac2d5154730e2e5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 17:52:56 +0900 Subject: [PATCH 214/232] use k format specifier in blob.c --- blob.c | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/blob.c b/blob.c index da3907c3..509b295a 100644 --- a/blob.c +++ b/blob.c @@ -60,17 +60,15 @@ static pic_value pic_blob_make_bytevector(pic_state *pic) { pic_blob *blob; - int k, b = 0, i; + size_t k, i; + int b = 0; - pic_get_args(pic, "i|i", &k, &b); + pic_get_args(pic, "k|i", &k, &b); if (b < 0 || b > 255) pic_errorf(pic, "byte out of range"); - if (k < 0) - pic_errorf(pic, "make-bytevector: cannot create a bytevector of length %d", k); - - blob = pic_make_blob(pic, (size_t)k); + blob = pic_make_blob(pic, k); for (i = 0; i < k; ++i) { blob->data[i] = (unsigned char)b; } @@ -118,15 +116,16 @@ static pic_value pic_blob_bytevector_copy_i(pic_state *pic) { pic_blob *to, *from; - int n, at, start, end; + int n; + size_t at, start, end; - n = pic_get_args(pic, "bib|ii", &to, &at, &from, &start, &end); + n = pic_get_args(pic, "bkb|kk", &to, &at, &from, &start, &end); switch (n) { case 3: start = 0; case 4: - end = (int)from->len; + end = from->len; } if (to == from && (start <= at && at < end)) { @@ -149,23 +148,23 @@ static pic_value pic_blob_bytevector_copy(pic_state *pic) { pic_blob *from, *to; - int n, start, end, k, i = 0; + int n; + size_t start, end, i = 0; - n = pic_get_args(pic, "b|ii", &from, &start, &end); + n = pic_get_args(pic, "b|kk", &from, &start, &end); switch (n) { case 1: start = 0; case 2: - end = (int)from->len; + end = from->len; } - k = end - start; + if (end < start) { + pic_errorf(pic, "make-bytevector: end index must not be less than start index"); + } - if (k < 0) - pic_errorf(pic, "make-bytevector: cannot create a bytevector of length %d", k); - - to = pic_make_blob(pic, (size_t)k); + to = pic_make_blob(pic, end - start); while (start < end) { to->data[i++] = from->data[start++]; } @@ -211,7 +210,7 @@ pic_blob_list_to_bytevector(pic_state *pic) pic_get_args(pic, "o", &list); - blob = pic_make_blob(pic, (size_t)pic_length(pic, list)); + blob = pic_make_blob(pic, pic_length(pic, list)); data = blob->data; @@ -231,15 +230,16 @@ pic_blob_bytevector_to_list(pic_state *pic) { pic_blob *blob; pic_value list; - int n, start, end, i; + int n; + size_t start, end, i; - n = pic_get_args(pic, "b|ii", &blob, &start, &end); + n = pic_get_args(pic, "b|kk", &blob, &start, &end); switch (n) { case 1: start = 0; case 2: - end = (int)blob->len; + end = blob->len; } list = pic_nil_value(); From d34cbccf12062d0279df192a36f12a39c89321a2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 18:10:14 +0900 Subject: [PATCH 215/232] use k format specifier in vector.c --- vector.c | 95 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 47 insertions(+), 48 deletions(-) diff --git a/vector.c b/vector.c index ba0dc7c8..86cd3c9b 100644 --- a/vector.c +++ b/vector.c @@ -26,11 +26,11 @@ struct pic_vector * pic_make_vec_from_list(pic_state *pic, pic_value data) { struct pic_vector *vec; - int len, i; + size_t len, i; len = pic_length(pic, data); - vec = pic_make_vec(pic, (size_t)len); + vec = pic_make_vec(pic, len); for (i = 0; i < len; ++i) { vec->data[i] = pic_car(pic, data); data = pic_cdr(pic, data); @@ -70,19 +70,15 @@ static pic_value pic_vec_make_vector(pic_state *pic) { pic_value v; - int n, k; - size_t i; + int n; + size_t k, i; struct pic_vector *vec; - n = pic_get_args(pic, "i|o", &k, &v); + n = pic_get_args(pic, "k|o", &k, &v); - if (k < 0) { - pic_errorf(pic, "make-vector: vector length must be non-negative"); - } - - vec = pic_make_vec(pic, (size_t)k); + vec = pic_make_vec(pic, k); if (n == 2) { - for (i = 0; i < (size_t)k; ++i) { + for (i = 0; i < k; ++i) { vec->data[i] = v; } } @@ -103,11 +99,11 @@ static pic_value pic_vec_vector_ref(pic_state *pic) { struct pic_vector *v; - int k; + size_t k; - pic_get_args(pic, "vi", &v, &k); + pic_get_args(pic, "vk", &v, &k); - if (k < 0 || v->len <= (size_t)k) { + if (v->len <= k) { pic_errorf(pic, "vector-ref: index out of range"); } return v->data[k]; @@ -117,12 +113,12 @@ static pic_value pic_vec_vector_set(pic_state *pic) { struct pic_vector *v; - int k; + size_t k; pic_value o; - pic_get_args(pic, "vio", &v, &k, &o); + pic_get_args(pic, "vko", &v, &k, &o); - if (k < 0 || v->len <= (size_t)k) { + if (v->len <= k) { pic_errorf(pic, "vector-set!: index out of range"); } v->data[k] = o; @@ -133,15 +129,16 @@ static pic_value pic_vec_vector_copy_i(pic_state *pic) { pic_vec *to, *from; - int n, at, start, end; + int n; + size_t at, start, end; - n = pic_get_args(pic, "viv|ii", &to, &at, &from, &start, &end); + n = pic_get_args(pic, "vkv|kk", &to, &at, &from, &start, &end); switch (n) { case 3: start = 0; case 4: - end = (int)from->len; + end = from->len; } if (to == from && (start <= at && at < end)) { @@ -164,22 +161,23 @@ static pic_value pic_vec_vector_copy(pic_state *pic) { pic_vec *vec, *to; - int n, start, end, i = 0; + int n; + size_t start, end, i = 0; - n = pic_get_args(pic, "v|ii", &vec, &start, &end); + n = pic_get_args(pic, "v|kk", &vec, &start, &end); switch (n) { case 1: start = 0; case 2: - end = (int)vec->len; + end = vec->len; } - if (end - start < 0) { + if (end < start) { pic_errorf(pic, "vector-copy: end index must not be less than start index"); } - to = pic_make_vec(pic, (size_t)(end - start)); + to = pic_make_vec(pic, end - start); while (start < end) { to->data[i++] = vec->data[start++]; } @@ -221,15 +219,16 @@ pic_vec_vector_fill_i(pic_state *pic) { pic_vec *vec; pic_value obj; - int n, start, end; + int n; + size_t start, end; - n = pic_get_args(pic, "vo|ii", &vec, &obj, &start, &end); + n = pic_get_args(pic, "vo|kk", &vec, &obj, &start, &end); switch (n) { case 2: start = 0; case 3: - end = (int)vec->len; + end = vec->len; } while (start < end) { @@ -310,7 +309,7 @@ pic_vec_list_to_vector(pic_state *pic) pic_get_args(pic, "o", &list); - vec = pic_make_vec(pic, (size_t)pic_length(pic, list)); + vec = pic_make_vec(pic, pic_length(pic, list)); data = vec->data; @@ -325,15 +324,16 @@ pic_vec_vector_to_list(pic_state *pic) { struct pic_vector *vec; pic_value list; - int n, start, end, i; + int n; + size_t start, end, i; - n = pic_get_args(pic, "v|ii", &vec, &start, &end); + n = pic_get_args(pic, "v|kk", &vec, &start, &end); switch (n) { case 1: start = 0; case 2: - end = (int)vec->len; + end = vec->len; } list = pic_nil_value(); @@ -349,23 +349,24 @@ pic_vec_vector_to_string(pic_state *pic) { pic_vec *vec; char *buf; - int n, start, end, i; + int n; + size_t start, end, i; pic_str *str; - n = pic_get_args(pic, "v|ii", &vec, &start, &end); + n = pic_get_args(pic, "v|kk", &vec, &start, &end); switch (n) { case 1: start = 0; case 2: - end = (int)vec->len; + end = vec->len; } - if (end - start < 0) { + if (end < start) { pic_errorf(pic, "vector->string: end index must not be less than start index"); } - buf = pic_alloc(pic, (size_t)(end - start)); + buf = pic_alloc(pic, end - start); for (i = start; i < end; ++i) { pic_assert_type(pic, vec->data[i], char); @@ -373,7 +374,7 @@ pic_vec_vector_to_string(pic_state *pic) buf[i - start] = pic_char(vec->data[i]); } - str = pic_make_str(pic, buf, (size_t)(end - start)); + str = pic_make_str(pic, buf, end - start); pic_free(pic, buf); return pic_obj_value(str); @@ -383,30 +384,28 @@ static pic_value pic_vec_string_to_vector(pic_state *pic) { pic_str *str; - int n, start, end; + int n; + size_t start, end; size_t i; pic_vec *vec; - n = pic_get_args(pic, "s|ii", &str, &start, &end); + n = pic_get_args(pic, "s|kk", &str, &start, &end); switch (n) { case 1: start = 0; case 2: - end = (int)pic_strlen(str); + end = pic_strlen(str); } - if (start < 0) { - pic_errorf(pic, "string->vector: index must non-negative"); - } - if (end - start < 0) { + if (end < start) { pic_errorf(pic, "string->vector: end index must not be less than start index"); } - vec = pic_make_vec(pic, (size_t)(end - start)); + vec = pic_make_vec(pic, end - start); - for (i = 0; i < (size_t)(end - start); ++i) { - vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + (size_t)start)); + for (i = 0; i < end - start; ++i) { + vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + start)); } return pic_obj_value(vec); } From de51c221348b1e6673719baa91242f69a3688413 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 18:16:27 +0900 Subject: [PATCH 216/232] use k format specifier in pair.c --- pair.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/pair.c b/pair.c index c2a775dc..763458f9 100644 --- a/pair.c +++ b/pair.c @@ -533,10 +533,10 @@ pic_pair_list_p(pic_state *pic) static pic_value pic_pair_make_list(pic_state *pic) { - int i; + size_t i; pic_value fill = pic_none_value(); - pic_get_args(pic, "i|o", &i, &fill); + pic_get_args(pic, "k|o", &i, &fill); return pic_make_list(pic, i, fill); } @@ -596,9 +596,9 @@ static pic_value pic_pair_list_tail(pic_state *pic) { pic_value list; - int i; + size_t i; - pic_get_args(pic, "oi", &list, &i); + pic_get_args(pic, "ok", &list, &i); return pic_list_tail(pic, list, i); } @@ -607,9 +607,9 @@ static pic_value pic_pair_list_ref(pic_state *pic) { pic_value list; - int i; + size_t i; - pic_get_args(pic, "oi", &list, &i); + pic_get_args(pic, "ok", &list, &i); return pic_list_ref(pic, list, i); } @@ -618,9 +618,9 @@ static pic_value pic_pair_list_set(pic_state *pic) { pic_value list, obj; - int i; + size_t i; - pic_get_args(pic, "oio", &list, &i, &obj); + pic_get_args(pic, "oko", &list, &i, &obj); pic_list_set(pic, list, i, obj); From b3def908b6ac15eca0dee2721d9268a664ef16b9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 18:48:20 +0900 Subject: [PATCH 217/232] use k format specifier in string.c --- string.c | 38 ++++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/string.c b/string.c index 7f03cfae..6ef7e745 100644 --- a/string.c +++ b/string.c @@ -256,10 +256,10 @@ pic_str_string(pic_state *pic) static pic_value pic_str_make_string(pic_state *pic) { - int len; + size_t len; char c = ' '; - pic_get_args(pic, "i|c", &len, &c); + pic_get_args(pic, "k|c", &len, &c); return pic_obj_value(pic_make_str_fill(pic, len, c)); } @@ -278,9 +278,9 @@ static pic_value pic_str_string_ref(pic_state *pic) { pic_str *str; - int k; + size_t k; - pic_get_args(pic, "si", &str, &k); + pic_get_args(pic, "sk", &str, &k); return pic_char_value(pic_str_ref(pic, str, k)); } @@ -319,9 +319,10 @@ static pic_value pic_str_string_copy(pic_state *pic) { pic_str *str; - int n, start, end; + int n; + size_t start, end; - n = pic_get_args(pic, "s|ii", &str, &start, &end); + n = pic_get_args(pic, "s|kk", &str, &start, &end); switch (n) { case 1: @@ -356,14 +357,14 @@ static pic_value pic_str_string_map(pic_state *pic) { struct pic_proc *proc; - int argc, i; + int argc; pic_value *argv, vals, val; - size_t len, j; + size_t i, len, j; pic_get_args(pic, "l*", &proc, &argc, &argv); len = SIZE_MAX; - for (i = 0; i < argc; ++i) { + for (i = 0; i < (size_t)argc; ++i) { pic_assert_type(pic, argv[i], str); len = len < pic_strlen(pic_str_ptr(argv[i])) @@ -378,7 +379,7 @@ pic_str_string_map(pic_state *pic) for (i = 0; i < len; ++i) { vals = pic_nil_value(); - for (j = 0; j < argc; ++j) { + for (j = 0; j < (size_t)argc; ++j) { pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); } val = pic_apply(pic, proc, vals); @@ -395,14 +396,14 @@ static pic_value pic_str_string_for_each(pic_state *pic) { struct pic_proc *proc; - int argc, i; - size_t len, j; + int argc; + size_t len, i, j; pic_value *argv, vals, val; pic_get_args(pic, "l*", &proc, &argc, &argv); len = SIZE_MAX; - for (i = 0; i < argc; ++i) { + for (i = 0; i < (size_t)argc; ++i) { pic_assert_type(pic, argv[i], str); len = len < pic_strlen(pic_str_ptr(argv[i])) @@ -415,7 +416,7 @@ pic_str_string_for_each(pic_state *pic) for (i = 0; i < len; ++i) { vals = pic_nil_value(); - for (j = 0; j < argc; ++j) { + for (j = 0; j < (size_t)argc; ++j) { pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); } val = pic_apply(pic, proc, vals); @@ -429,7 +430,7 @@ pic_str_list_to_string(pic_state *pic) { pic_str *str; pic_value list, e; - int i = 0; + size_t i = 0; pic_get_args(pic, "o", &list); @@ -455,15 +456,16 @@ pic_str_string_to_list(pic_state *pic) { pic_str *str; pic_value list; - int n, start, end, i; + int n; + size_t start, end, i; - n = pic_get_args(pic, "s|ii", &str, &start, &end); + n = pic_get_args(pic, "s|kk", &str, &start, &end); switch (n) { case 1: start = 0; case 2: - end = (int)pic_strlen(str); + end = pic_strlen(str); } list = pic_nil_value(); From cf9d48a8653cb2dfb2826eca1cc4423de01849e9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 19:40:10 +0900 Subject: [PATCH 218/232] add pic_size_value --- blob.c | 2 +- dict.c | 2 +- include/picrin/value.h | 12 ++++++++++++ pair.c | 2 +- string.c | 2 +- vector.c | 2 +- 6 files changed, 17 insertions(+), 5 deletions(-) diff --git a/blob.c b/blob.c index 509b295a..ae0f2fb7 100644 --- a/blob.c +++ b/blob.c @@ -83,7 +83,7 @@ pic_blob_bytevector_length(pic_state *pic) pic_get_args(pic, "b", &bv); - return pic_int_value((int)bv->len); + return pic_size_value(bv->len); } static pic_value diff --git a/dict.c b/dict.c index 2a8fcd41..c5387706 100644 --- a/dict.c +++ b/dict.c @@ -213,7 +213,7 @@ pic_dict_dictionary_size(pic_state *pic) pic_get_args(pic, "d", &dict); - return pic_int_value((int)pic_dict_size(pic, dict)); + return pic_size_value(pic_dict_size(pic, dict)); } static pic_value diff --git a/include/picrin/value.h b/include/picrin/value.h index 37dd58c0..d0c1dbe3 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -189,6 +189,7 @@ 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(); @@ -323,6 +324,17 @@ pic_bool_value(bool b) return v; } +static inline pic_value +pic_size_value(size_t s) +{ + if (sizeof(unsigned) < sizeof(size_t)) { + if (s > (size_t)INT_MAX) { + return pic_float_value(s); + } + } + return pic_int_value((int)s); +} + #if PIC_NAN_BOXING static inline pic_value diff --git a/pair.c b/pair.c index 763458f9..184182cc 100644 --- a/pair.c +++ b/pair.c @@ -559,7 +559,7 @@ pic_pair_length(pic_state *pic) pic_get_args(pic, "o", &list); - return pic_int_value(pic_length(pic, list)); + return pic_size_value(pic_length(pic, list)); } static pic_value diff --git a/string.c b/string.c index 6ef7e745..cd4b3660 100644 --- a/string.c +++ b/string.c @@ -271,7 +271,7 @@ pic_str_string_length(pic_state *pic) pic_get_args(pic, "s", &str); - return pic_int_value(pic_strlen(str)); + return pic_size_value(pic_strlen(str)); } static pic_value diff --git a/vector.c b/vector.c index 86cd3c9b..a7dbd81d 100644 --- a/vector.c +++ b/vector.c @@ -92,7 +92,7 @@ pic_vec_vector_length(pic_state *pic) pic_get_args(pic, "v", &v); - return pic_int_value((int)v->len); + return pic_size_value(v->len); } static pic_value From 7f68fd3e2a6938c6633fc200605b17ce4d019b83 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 19:48:58 +0900 Subject: [PATCH 219/232] use k format specifier in port.c --- port.c | 34 +++++++++++++++------------------- 1 file changed, 15 insertions(+), 19 deletions(-) diff --git a/port.c b/port.c index 5cbcb1b8..ec61d984 100644 --- a/port.c +++ b/port.c @@ -521,20 +521,15 @@ pic_port_read_blob(pic_state *pic) { struct pic_port *port = pic_stdin(pic); pic_blob *blob; - int k; - size_t i; + size_t k, i; - pic_get_args(pic, "i|p", &k, &port); + pic_get_args(pic, "k|p", &k, &port); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector"); - if (k < 0) { - pic_errorf(pic, "read-bytevector: index must be non-negative %d", k); - } + blob = pic_make_blob(pic, k); - blob = pic_make_blob(pic, (size_t)k); - - i = xfread(blob->data, sizeof(char), (size_t)k, port->file); + i = xfread(blob->data, sizeof(char), k, port->file); if (i == 0) { return pic_eof_object(); } @@ -550,27 +545,27 @@ pic_port_read_blob_ip(pic_state *pic) { struct pic_port *port; struct pic_blob *bv; - int n, start, end; + int n; char *buf; - size_t i, len; + size_t start, end, i, len; - n = pic_get_args(pic, "b|pii", &bv, &port, &start, &end); + n = pic_get_args(pic, "b|pkk", &bv, &port, &start, &end); switch (n) { case 1: port = pic_stdin(pic); case 2: start = 0; case 3: - end = (int)bv->len; + end = bv->len; } assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!"); - if (end - start < 0) { + if (end < start) { pic_errorf(pic, "read-bytevector!: end index must be greater than or equal to start index"); } - len = (size_t)(end - start); + len = end - start; buf = pic_calloc(pic, len, sizeof(char)); i = xfread(buf, sizeof(char), len, port->file); @@ -581,7 +576,7 @@ pic_port_read_blob_ip(pic_state *pic) return pic_eof_object(); } else { - return pic_int_value((int)i); + return pic_size_value(i); } } @@ -656,16 +651,17 @@ pic_port_write_blob(pic_state *pic) { struct pic_blob *blob; struct pic_port *port; - int start, end, n, i; + int n; + size_t start, end, i; - n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end); + n = pic_get_args(pic, "b|pkk", &blob, &port, &start, &end); switch (n) { case 1: port = pic_stdout(pic); case 2: start = 0; case 3: - end = (int)blob->len; + end = blob->len; } assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector"); From d165b6ea6fbe995b7fb5c68023a32a290ff9344c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 19:49:32 +0900 Subject: [PATCH 220/232] avoid explicit casts if possible (small refacotring on dict.c, system.c) --- dict.c | 10 ++++++---- system.c | 4 ++-- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/dict.c b/dict.c index c5387706..890af074 100644 --- a/dict.c +++ b/dict.c @@ -12,11 +12,13 @@ xh_value_hash(const void *key, void *data) { union { double f; int i; } u; pic_value val = *(pic_value *)key; - int hash; + int hash, vtype; UNUSED(data); - switch (pic_vtype(val)) { + vtype = pic_vtype(val); + + switch (vtype) { default: hash = 0; break; @@ -31,11 +33,11 @@ xh_value_hash(const void *key, void *data) hash = pic_int(val); break; case PIC_VTYPE_HEAP: - hash = (int)pic_ptr(val); + hash = (int)(intptr_t)pic_ptr(val); break; } - return hash + (int)pic_vtype(val); + return hash + vtype; } static int diff --git a/system.c b/system.c index e9ef1aa9..1b251661 100644 --- a/system.c +++ b/system.c @@ -105,12 +105,12 @@ pic_system_getenvs(pic_state *pic) for (envp = pic->envp; *envp; ++envp) { pic_str *key, *val; - int i; + size_t i; for (i = 0; (*envp)[i] != '='; ++i) ; - key = pic_make_str(pic, *envp, (size_t)i); + key = pic_make_str(pic, *envp, i); val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key))); /* push */ From 552ee7444fc6e1519a84eb5d8cc5cbc6ae15cf91 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 19:58:04 +0900 Subject: [PATCH 221/232] more fix --- codegen.c | 4 ++-- time.c | 2 +- vm.c | 10 ++++++---- 3 files changed, 9 insertions(+), 7 deletions(-) diff --git a/codegen.c b/codegen.c index c4e3121e..f6183278 100644 --- a/codegen.c +++ b/codegen.c @@ -1375,7 +1375,7 @@ codegen(codegen_state *state, pic_value obj) return; } else if (sym == state->sCALL || sym == state->sTAILCALL) { - int len = pic_length(pic, obj); + int len = (int)pic_length(pic, obj); pic_value elt; pic_for_each (elt, pic_cdr(pic, obj)) { @@ -1401,7 +1401,7 @@ codegen(codegen_state *state, pic_value obj) return; } else if (sym == state->sRETURN) { - int len = pic_length(pic, obj); + int len = (int)pic_length(pic, obj); pic_value elt; pic_for_each (elt, pic_cdr(pic, obj)) { diff --git a/time.c b/time.c index a0a1ffb6..83716db8 100644 --- a/time.c +++ b/time.c @@ -27,7 +27,7 @@ pic_current_jiffy(pic_state *pic) pic_get_args(pic, ""); c = clock(); - return pic_int_value((int)c); + return pic_int_value((int)c); /* The year 2038 problem :-| */ } static pic_value diff --git a/vm.c b/vm.c index 97e21bf6..fbdd6c2b 100644 --- a/vm.c +++ b/vm.c @@ -212,8 +212,10 @@ pic_get_args(pic_state *pic, const char *format, ...) if (x < 0) { pic_errorf(pic, "pic_get_args: expected non-negative int, but got ~s", v); } - if (sizeof(unsigned) > sizeof(size_t) && (unsigned)x > (unsigned)SIZE_MAX) { - pic_errorf(pic, "pic_get_args: int unrepresentable with size_t ~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; @@ -707,7 +709,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) else { int argc, i; - argc = pic_length(pic, args) + 1; + argc = (int)pic_length(pic, args) + 1; VM_BOOT_PRINT; @@ -1139,7 +1141,7 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) ci = PUSHCI(); ci->ip = (pic_code *)iseq; ci->fp = pic->sp; - ci->retc = pic_length(pic, args); + ci->retc = (int)pic_length(pic, args); if (ci->retc == 0) { return pic_none_value(); From c808b34a677815886f784c4c89d4fbf821d9f397 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 20:15:47 +0900 Subject: [PATCH 222/232] refactor map and for-each --- pair.c | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/pair.c b/pair.c index 184182cc..cbb4de70 100644 --- a/pair.c +++ b/pair.c @@ -643,23 +643,24 @@ pic_pair_map(pic_state *pic) struct pic_proc *proc; int argc, i; pic_value *args; - pic_value cars, ret; + pic_value arg, ret; pic_get_args(pic, "l*", &proc, &argc, &args); ret = pic_nil_value(); do { - cars = pic_nil_value(); - for (i = argc - 1; i >= 0; --i) { + arg = pic_nil_value(); + for (i = 0; i < argc; ++i) { if (! pic_pair_p(args[i])) { break; } - cars = pic_cons(pic, pic_car(pic, args[i]), cars); + pic_push(pic, pic_car(pic, args[i]), arg); args[i] = pic_cdr(pic, args[i]); } - if (i >= 0) + if (i != argc) { break; - ret = pic_cons(pic, pic_apply(pic, proc, cars), ret); + } + pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg)), ret); } while (1); return pic_reverse(pic, ret); @@ -671,22 +672,23 @@ pic_pair_for_each(pic_state *pic) struct pic_proc *proc; int argc, i; pic_value *args; - pic_value cars; + pic_value arg; pic_get_args(pic, "l*", &proc, &argc, &args); do { - cars = pic_nil_value(); - for (i = argc - 1; i >= 0; --i) { + arg = pic_nil_value(); + for (i = 0; i < argc; ++i) { if (! pic_pair_p(args[i])) { break; } - cars = pic_cons(pic, pic_car(pic, args[i]), cars); + pic_push(pic, pic_car(pic, args[i]), arg); args[i] = pic_cdr(pic, args[i]); } - if (i >= 0) + if (i != argc) { break; - pic_apply(pic, proc, cars); + } + pic_apply(pic, proc, pic_reverse(pic, arg)); } while (1); return pic_none_value(); From 186c468c165cdfabc8ead6f85a39efbe4041dd4d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 20:17:02 +0900 Subject: [PATCH 223/232] revert: argc must be size_t type --- blob.c | 7 +++---- bool.c | 2 +- char.c | 2 +- cont.c | 4 ++-- dict.c | 2 +- error.c | 4 ++-- lib.c | 8 ++++---- number.c | 6 +++--- pair.c | 8 ++++---- proc.c | 2 +- string.c | 20 +++++++++----------- symbol.c | 2 +- vector.c | 19 ++++++++----------- vm.c | 6 +++--- 14 files changed, 43 insertions(+), 49 deletions(-) diff --git a/blob.c b/blob.c index ae0f2fb7..3e5b7723 100644 --- a/blob.c +++ b/blob.c @@ -33,13 +33,13 @@ static pic_value pic_blob_bytevector(pic_state *pic) { pic_value *argv; - int argc, i; + size_t argc, i; pic_blob *blob; unsigned char *data; pic_get_args(pic, "*", &argc, &argv); - blob = pic_make_blob(pic, (size_t)argc); + blob = pic_make_blob(pic, argc); data = blob->data; @@ -175,8 +175,7 @@ pic_blob_bytevector_copy(pic_state *pic) static pic_value pic_blob_bytevector_append(pic_state *pic) { - size_t j, len; - int argc, i; + size_t argc, i, j, len; pic_value *argv; pic_blob *blob; diff --git a/bool.c b/bool.c index ff5528e9..8f8c75f1 100644 --- a/bool.c +++ b/bool.c @@ -172,7 +172,7 @@ pic_bool_boolean_p(pic_state *pic) static pic_value pic_bool_boolean_eq_p(pic_state *pic) { - int argc, i; + size_t argc, i; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); diff --git a/char.c b/char.c index f08fcdd0..d9c675e7 100644 --- a/char.c +++ b/char.c @@ -42,7 +42,7 @@ pic_char_integer_to_char(pic_state *pic) static pic_value \ pic_char_##name##_p(pic_state *pic) \ { \ - int argc, i; \ + size_t argc, i; \ pic_value *argv; \ char c, d; \ \ diff --git a/cont.c b/cont.c index 4b980e4a..41a0fdb8 100644 --- a/cont.c +++ b/cont.c @@ -96,7 +96,7 @@ pic_load_point(pic_state *pic, struct pic_escape *escape) noreturn static pic_value escape_call(pic_state *pic) { - int argc; + size_t argc; pic_value *argv; struct pic_data *e; @@ -251,7 +251,7 @@ pic_cont_dynamic_wind(pic_state *pic) static pic_value pic_cont_values(pic_state *pic) { - int argc; + size_t argc; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); diff --git a/dict.c b/dict.c index 890af074..81bdea68 100644 --- a/dict.c +++ b/dict.c @@ -144,7 +144,7 @@ pic_dict_dictionary(pic_state *pic) { struct pic_dict *dict; pic_value *argv; - int argc, i; + size_t argc, i; pic_get_args(pic, "*", &argc, &argv); diff --git a/error.c b/error.c index 0f3ac651..3b462969 100644 --- a/error.c +++ b/error.c @@ -245,7 +245,7 @@ noreturn static pic_value pic_error_error(pic_state *pic) { const char *str; - int argc; + size_t argc; pic_value *argv; pic_get_args(pic, "z*", &str, &argc, &argv); @@ -259,7 +259,7 @@ pic_error_make_error_object(pic_state *pic) struct pic_error *e; pic_sym type; pic_str *msg; - int argc; + size_t argc; pic_value *argv; pic_get_args(pic, "ms*", &type, &msg, &argc, &argv); diff --git a/lib.c b/lib.c index cd760f18..37cba2bd 100644 --- a/lib.c +++ b/lib.c @@ -253,7 +253,7 @@ static pic_value pic_lib_condexpand(pic_state *pic) { pic_value *clauses; - int argc, i; + size_t argc, i; pic_get_args(pic, "*", &argc, &clauses); @@ -269,7 +269,7 @@ pic_lib_condexpand(pic_state *pic) static pic_value pic_lib_import(pic_state *pic) { - int argc, i; + size_t argc, i; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); @@ -284,7 +284,7 @@ pic_lib_import(pic_state *pic) static pic_value pic_lib_export(pic_state *pic) { - int argc, i; + size_t argc, i; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); @@ -300,7 +300,7 @@ static pic_value pic_lib_define_library(pic_state *pic) { struct pic_lib *prev = pic->lib; - int argc, i; + size_t argc, i; pic_value spec, *argv; pic_get_args(pic, "o*", &spec, &argc, &argv); diff --git a/number.c b/number.c index c72f58ca..88db88d6 100644 --- a/number.c +++ b/number.c @@ -162,7 +162,7 @@ pic_number_nan_p(pic_state *pic) static pic_value \ pic_number_##name(pic_state *pic) \ { \ - int argc, i; \ + size_t argc, i; \ pic_value *argv; \ double f,g; \ \ @@ -197,7 +197,7 @@ DEFINE_ARITH_CMP(>=, ge) static pic_value \ pic_number_##name(pic_state *pic) \ { \ - int argc, i; \ + size_t argc, i; \ pic_value *argv; \ double f; \ bool e = true; \ @@ -228,7 +228,7 @@ DEFINE_ARITH_OP(*, mul, 1) static pic_value \ pic_number_##name(pic_state *pic) \ { \ - int argc, i; \ + size_t argc, i; \ pic_value *argv; \ double f; \ bool e; \ diff --git a/pair.c b/pair.c index cbb4de70..f2803f1a 100644 --- a/pair.c +++ b/pair.c @@ -544,7 +544,7 @@ pic_pair_make_list(pic_state *pic) static pic_value pic_pair_list(pic_state *pic) { - int argc; + size_t argc; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); @@ -565,7 +565,7 @@ pic_pair_length(pic_state *pic) static pic_value pic_pair_append(pic_state *pic) { - int argc; + size_t argc; pic_value *args, list; pic_get_args(pic, "*", &argc, &args); @@ -641,7 +641,7 @@ static pic_value pic_pair_map(pic_state *pic) { struct pic_proc *proc; - int argc, i; + size_t argc, i; pic_value *args; pic_value arg, ret; @@ -670,7 +670,7 @@ static pic_value pic_pair_for_each(pic_state *pic) { struct pic_proc *proc; - int argc, i; + size_t argc, i; pic_value *args; pic_value arg; diff --git a/proc.c b/proc.c index 0d67ddd7..210f157d 100644 --- a/proc.c +++ b/proc.c @@ -61,7 +61,7 @@ pic_proc_apply(pic_state *pic) { struct pic_proc *proc; pic_value *args; - int argc; + size_t argc; pic_value arg_list; pic_get_args(pic, "l*", &proc, &argc, &args); diff --git a/string.c b/string.c index cd4b3660..f9f15a59 100644 --- a/string.c +++ b/string.c @@ -233,7 +233,7 @@ pic_str_string_p(pic_state *pic) static pic_value pic_str_string(pic_state *pic) { - int argc, i; + size_t argc, i; pic_value *argv; pic_str *str; char *buf; @@ -289,7 +289,7 @@ pic_str_string_ref(pic_state *pic) static pic_value \ pic_str_string_##name(pic_state *pic) \ { \ - int argc, i; \ + size_t argc, i; \ pic_value *argv; \ \ pic_get_args(pic, "*", &argc, &argv); \ @@ -337,7 +337,7 @@ pic_str_string_copy(pic_state *pic) static pic_value pic_str_string_append(pic_state *pic) { - int argc, i; + size_t argc, i; pic_value *argv; pic_str *str; @@ -357,14 +357,13 @@ static pic_value pic_str_string_map(pic_state *pic) { struct pic_proc *proc; - int argc; pic_value *argv, vals, val; - size_t i, len, j; + size_t argc, i, len, j; pic_get_args(pic, "l*", &proc, &argc, &argv); len = SIZE_MAX; - for (i = 0; i < (size_t)argc; ++i) { + for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], str); len = len < pic_strlen(pic_str_ptr(argv[i])) @@ -379,7 +378,7 @@ pic_str_string_map(pic_state *pic) for (i = 0; i < len; ++i) { vals = pic_nil_value(); - for (j = 0; j < (size_t)argc; ++j) { + for (j = 0; j < argc; ++j) { pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); } val = pic_apply(pic, proc, vals); @@ -396,14 +395,13 @@ static pic_value pic_str_string_for_each(pic_state *pic) { struct pic_proc *proc; - int argc; - size_t len, i, j; + size_t argc, len, i, j; pic_value *argv, vals, val; pic_get_args(pic, "l*", &proc, &argc, &argv); len = SIZE_MAX; - for (i = 0; i < (size_t)argc; ++i) { + for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], str); len = len < pic_strlen(pic_str_ptr(argv[i])) @@ -416,7 +414,7 @@ pic_str_string_for_each(pic_state *pic) for (i = 0; i < len; ++i) { vals = pic_nil_value(); - for (j = 0; j < (size_t)argc; ++j) { + for (j = 0; j < argc; ++j) { pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); } val = pic_apply(pic, proc, vals); diff --git a/symbol.c b/symbol.c index 7e9f1b52..115582c8 100644 --- a/symbol.c +++ b/symbol.c @@ -108,7 +108,7 @@ pic_symbol_symbol_p(pic_state *pic) static pic_value pic_symbol_symbol_eq_p(pic_state *pic) { - int argc, i; + size_t argc, i; pic_value *argv; pic_get_args(pic, "*", &argc, &argv); diff --git a/vector.c b/vector.c index a7dbd81d..33070d24 100644 --- a/vector.c +++ b/vector.c @@ -51,7 +51,7 @@ pic_vec_vector_p(pic_state *pic) static pic_value pic_vec_vector(pic_state *pic) { - int argc, i; + size_t argc, i; pic_value *argv; pic_vec *vec; @@ -188,9 +188,8 @@ pic_vec_vector_copy(pic_state *pic) static pic_value pic_vec_vector_append(pic_state *pic) { - int argc, i; pic_value *argv; - size_t j, len; + size_t argc, i, j, len; pic_vec *vec; pic_get_args(pic, "*", &argc, &argv); @@ -242,15 +241,14 @@ static pic_value pic_vec_vector_map(pic_state *pic) { struct pic_proc *proc; - int argc; - size_t i, len, j; + size_t argc, i, len, j; pic_value *argv, vals; pic_vec *vec; pic_get_args(pic, "l*", &proc, &argc, &argv); len = INT_MAX; - for (i = 0; i < (size_t)argc; ++i) { + for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], vec); len = len < pic_vec_ptr(argv[i])->len @@ -262,7 +260,7 @@ pic_vec_vector_map(pic_state *pic) for (i = 0; i < len; ++i) { vals = pic_nil_value(); - for (j = 0; j < (size_t)argc; ++j) { + for (j = 0; j < argc; ++j) { pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); } vec->data[i] = pic_apply(pic, proc, vals); @@ -275,14 +273,13 @@ static pic_value pic_vec_vector_for_each(pic_state *pic) { struct pic_proc *proc; - int argc; - size_t i, len, j; + size_t argc, i, len, j; pic_value *argv, vals; pic_get_args(pic, "l*", &proc, &argc, &argv); len = INT_MAX; - for (i = 0; i < (size_t)argc; ++i) { + for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], vec); len = len < pic_vec_ptr(argv[i])->len @@ -292,7 +289,7 @@ pic_vec_vector_for_each(pic_state *pic) for (i = 0; i < len; ++i) { vals = pic_nil_value(); - for (j = 0; j < (size_t)argc; ++j) { + for (j = 0; j < argc; ++j) { pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); } pic_apply(pic, proc, vals); diff --git a/vm.c b/vm.c index fbdd6c2b..accb47ce 100644 --- a/vm.c +++ b/vm.c @@ -416,13 +416,13 @@ pic_get_args(pic_state *pic, const char *format, ...) } } if ('*' == c) { - int *n; + size_t *n; pic_value **argv; - n = va_arg(ap, int *); + n = va_arg(ap, size_t *); argv = va_arg(ap, pic_value **); if (i <= argc) { - *n = argc - i; + *n = (size_t)(argc - i); *argv = &GET_OPERAND(pic, i); i = argc; } From 0403ca5570c81004f5477cfd97f2ccd2ba9fe499 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 20:21:54 +0900 Subject: [PATCH 224/232] more fixes --- cont.c | 16 ++++++++-------- include/picrin/cont.h | 4 ++-- include/picrin/pair.h | 2 +- pair.c | 2 +- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/cont.c b/cont.c index 41a0fdb8..4e38e8c6 100644 --- a/cont.c +++ b/cont.c @@ -184,14 +184,14 @@ pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_ } pic_value -pic_values_by_array(pic_state *pic, int argc, pic_value *argv) +pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv) { - int i; + size_t i; for (i = 0; i < argc; ++i) { pic->sp[i] = argv[i]; } - pic->ci->retc = argc; + pic->ci->retc = (int)argc; return argc == 0 ? pic_none_value() : pic->sp[0]; } @@ -211,15 +211,15 @@ pic_values_by_list(pic_state *pic, pic_value list) return pic_nil_p(list) ? pic_none_value() : pic->sp[0]; } -int -pic_receive(pic_state *pic, int n, pic_value *argv) +size_t +pic_receive(pic_state *pic, size_t n, pic_value *argv) { pic_callinfo *ci; - int i, retc; + size_t i, retc; /* take info from discarded frame */ ci = pic->ci + 1; - retc = ci->retc; + retc = (size_t)ci->retc; for (i = 0; i < retc && i < n; ++i) { argv[i] = ci->fp[i]; @@ -263,7 +263,7 @@ static pic_value pic_cont_call_with_values(pic_state *pic) { struct pic_proc *producer, *consumer; - int argc; + size_t argc; pic_value args[256]; pic_get_args(pic, "ll", &producer, &consumer); diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 01e86e11..645e6d9c 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -40,9 +40,9 @@ pic_value pic_values2(pic_state *, pic_value, pic_value); pic_value pic_values3(pic_state *, pic_value, pic_value, pic_value); pic_value pic_values4(pic_state *, pic_value, pic_value, pic_value, pic_value); pic_value pic_values5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_values_by_array(pic_state *, int, pic_value *); +pic_value pic_values_by_array(pic_state *, size_t, pic_value *); pic_value pic_values_by_list(pic_state *, pic_value); -int pic_receive(pic_state *, int, pic_value *); +size_t pic_receive(pic_state *, size_t, pic_value *); pic_value pic_escape(pic_state *, struct pic_proc *); diff --git a/include/picrin/pair.h b/include/picrin/pair.h index d6cf779d..d489b765 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -56,7 +56,7 @@ pic_value pic_list4(pic_state *, pic_value, pic_value, pic_value, pic_value); pic_value pic_list5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); pic_value pic_list6(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list_by_array(pic_state *, int, pic_value *); +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) \ diff --git a/pair.c b/pair.c index f2803f1a..b662534a 100644 --- a/pair.c +++ b/pair.c @@ -160,7 +160,7 @@ pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_va } pic_value -pic_list_by_array(pic_state *pic, int c, pic_value *vs) +pic_list_by_array(pic_state *pic, size_t c, pic_value *vs) { pic_value v; From 1b371026761b7f65ac41a669ebc28eb18b4e7a07 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 20:43:31 +0900 Subject: [PATCH 225/232] suppress warning in compiling read.c --- read.c | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/read.c b/read.c index 7deb5eb2..be160c0d 100644 --- a/read.c +++ b/read.c @@ -209,7 +209,7 @@ read_symbol(pic_state *pic, struct pic_port *port, const char *str) for (i = 0; i < len; ++i) { if (pic->reader->typecase == PIC_CASE_FOLD) { - buf[i] = tolower(str[i]); + buf[i] = (char)tolower(str[i]); } else { buf[i] = str[i]; } @@ -222,7 +222,7 @@ read_symbol(pic_state *pic, struct pic_port *port, const char *str) } len += 1; buf = pic_realloc(pic, buf, len + 1); - buf[len - 1] = c; + buf[len - 1] = (char)c; } sym = pic_intern(pic, buf, len); @@ -240,9 +240,9 @@ read_uinteger(pic_state *pic, struct pic_port *port, int c, char buf[]) read_error(pic, "expected one or more digits"); } - buf[i++] = c; + buf[i++] = (char)c; while (isdigit(c = peek(port))) { - buf[i++] = next(port); + buf[i++] = (char)next(port); } buf[i] = '\0'; @@ -262,12 +262,12 @@ read_suffix(pic_state *pic, struct pic_port *port, char buf[]) return i; } - buf[i++] = next(port); + buf[i++] = (char)next(port); switch ((c = next(port))) { case '-': case '+': - buf[i++] = c; + buf[i++] = (char)c; c = next(port); default: return i + read_uinteger(pic, port, c, buf + i); @@ -284,14 +284,14 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c) switch (peek(port)) { case '.': - buf[i++] = next(port); + 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)); default: read_suffix(pic, port, buf + i); - return pic_int_value((int)atof(buf)); + return pic_int_value((int)(atof(buf))); } } @@ -404,7 +404,7 @@ read_char(pic_state *pic, struct pic_port *port, const char *str) } } - return pic_char_value(c); + return pic_char_value((char)c); fail: read_error(pic, "unexpected character while reading character literal"); @@ -436,7 +436,7 @@ read_string(pic_state *pic, struct pic_port *port, const char *name) case 'r': c = '\r'; break; } } - buf[cnt++] = c; + buf[cnt++] = (char)c; if (cnt >= size) { buf = pic_realloc(pic, buf, size *= 2); } @@ -474,15 +474,15 @@ read_pipe(pic_state *pic, struct pic_port *port, const char *str) case 'r': c = '\r'; break; case 'x': i = 0; - while ((HEX_BUF[i++] = next(port)) != ';') { + while ((HEX_BUF[i++] = (char)next(port)) != ';') { if (i >= sizeof HEX_BUF) read_error(pic, "expected ';'"); } - c = strtol(HEX_BUF, NULL, 16); + c = (char)strtol(HEX_BUF, NULL, 16); break; } } - buf[cnt++] = c; + buf[cnt++] = (char)c; if (cnt >= size) { buf = pic_realloc(pic, buf, size *= 2); } @@ -500,7 +500,8 @@ read_blob(pic_state *pic, struct pic_port *port, const char *str) { int nbits, n, c; size_t len, i; - char *dat, buf[256]; + char buf[256]; + unsigned char *dat; pic_blob *blob; UNUSED(str); @@ -530,7 +531,7 @@ read_blob(pic_state *pic, struct pic_port *port, const char *str) } len += 1; dat = pic_realloc(pic, dat, len); - dat[len - 1] = n; + dat[len - 1] = (unsigned char)n; c = next(port); } @@ -710,7 +711,7 @@ read_nullable(pic_state *pic, struct pic_port *port, int c) read_error(pic, "invalid character at the seeker head"); } - buf[i++] = c; + buf[i++] = (char)c; while (i < sizeof buf) { trie = trie->table[c]; @@ -721,7 +722,7 @@ read_nullable(pic_state *pic, struct pic_port *port, int c) if (trie->table[c] == NULL) { break; } - buf[i++] = next(port); + buf[i++] = (char)next(port); } if (i == sizeof buf) { read_error(pic, "too long dispatch string"); From a22eef106077850db7dd2d9da5703a4d0b3b9ffe Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 20:46:58 +0900 Subject: [PATCH 226/232] fix comments --- include/picrin/value.h | 2 +- vm.c | 40 ++++++++++++++++++++-------------------- 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/include/picrin/value.h b/include/picrin/value.h index d0c1dbe3..709fcf77 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -41,7 +41,7 @@ enum pic_vtype { * ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP * int : 1111111111110110 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII * sym : 1111111111110111 0000000000000000 SSSSSSSSSSSSSSSS SSSSSSSSSSSSSSSS - * char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC ................ + * char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC */ typedef uint64_t pic_value; diff --git a/vm.c b/vm.c index accb47ce..32e7869c 100644 --- a/vm.c +++ b/vm.c @@ -35,27 +35,27 @@ pic_get_proc(pic_state *pic) } /** - * char type desc. - * ---- ---- ---- - * o pic_value * object - * i int * int - * I int *, bool * int with exactness - * k size_t * size_t implicitly converted from int - * f double * float - * F double *, bool * float with exactness - * s pic_str ** string object - * z char ** c string - * m pic_sym * symbol - * v pic_vec ** vector object - * b pic_blob ** bytevector object - * c char * char - * l struct pic_proc ** lambda object - * p struct pic_port ** port object - * d struct pic_dict ** dictionary object - * e struct pic_error ** error object + * char type desc. + * ---- ---- ---- + * o pic_value * object + * i int * int + * I int *, bool * int with exactness + * k size_t * size_t implicitly converted from int + * f double * float + * F double *, bool * float with exactness + * s pic_str ** string object + * z char ** c string + * m pic_sym * symbol + * v pic_vec ** vector object + * b pic_blob ** bytevector object + * c char * char + * l struct pic_proc ** lambda object + * p struct pic_port ** port object + * d struct pic_dict ** dictionary object + * e struct pic_error ** error object * - * | optional operator - * * int *, pic_value ** variable length operator + * | optional operator + * * size_t *, pic_value ** variable length operator */ int From 458511e2310d2882da5271c5b5a85759b855647c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 08:18:43 -0700 Subject: [PATCH 227/232] update xhash.h (remove unsafe type-punning) --- include/picrin/xhash.h | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/include/picrin/xhash.h b/include/picrin/xhash.h index 1d3596ca..e25302ed 100644 --- a/include/picrin/xhash.h +++ b/include/picrin/xhash.h @@ -28,8 +28,8 @@ typedef struct xh_entry { struct xh_entry *next; int hash; struct xh_entry *fw, *bw; - const char *key; /* == val + XHASH_ALIGN(vwidth) */ - char val[]; + const void *key; + void *val; } xh_entry; #define xh_key(e,type) (*(type *)((e)->key)) @@ -41,6 +41,7 @@ typedef int (*xh_equalf)(const void *, const void *, void *); typedef struct xhash { xh_entry **buckets; size_t size, count, kwidth, vwidth; + size_t koffset, voffset; xh_hashf hashf; xh_equalf equalf; xh_entry *head, *tail; @@ -96,6 +97,8 @@ xh_init_(xhash *x, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equal x->count = 0; x->kwidth = kwidth; x->vwidth = vwidth; + x->koffset = XHASH_ALIGN(sizeof(xh_entry)); + x->voffset = XHASH_ALIGN(sizeof(xh_entry)) + XHASH_ALIGN(kwidth); x->hashf = hashf; x->equalf = equalf; x->head = NULL; @@ -166,10 +169,11 @@ xh_put_(xhash *x, const void *key, void *val) hash = x->hashf(key, x->data); idx = ((unsigned)hash) % x->size; - e = (xh_entry *)malloc(offsetof(xh_entry, val) + XHASH_ALIGN(x->vwidth) + x->kwidth); + e = malloc(x->voffset + x->vwidth); e->next = x->buckets[idx]; e->hash = hash; - e->key = e->val + XHASH_ALIGN(x->vwidth); + e->key = ((char *)e) + x->koffset; + e->val = ((char *)e) + x->voffset; memcpy((void *)e->key, key, x->kwidth); memcpy(e->val, val, x->vwidth); From 7502ff4cb7e1f6553563d7921b690737e576a9ea Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 08:22:03 -0700 Subject: [PATCH 228/232] remove unused variable --- string.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/string.c b/string.c index f9f15a59..63f301d8 100644 --- a/string.c +++ b/string.c @@ -396,7 +396,7 @@ pic_str_string_for_each(pic_state *pic) { struct pic_proc *proc; size_t argc, len, i, j; - pic_value *argv, vals, val; + pic_value *argv, vals; pic_get_args(pic, "l*", &proc, &argc, &argv); @@ -417,7 +417,7 @@ pic_str_string_for_each(pic_state *pic) for (j = 0; j < argc; ++j) { pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); } - val = pic_apply(pic, proc, vals); + pic_apply(pic, proc, vals); } return pic_none_value(); From ed1a9aa7179c2cb273fa38ae33a7549cd163aabe Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 08:25:11 -0700 Subject: [PATCH 229/232] mark popped but not used value as 'unused' --- vm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm.c b/vm.c index 32e7869c..8eb67b71 100644 --- a/vm.c +++ b/vm.c @@ -731,7 +731,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) NEXT; } CASE(OP_POP) { - POP(); + (void)(POP()); NEXT; } CASE(OP_PUSHNIL) { From 15889a5feb515bd67ee7dc2c6419d16703151a54 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Sep 2014 08:29:55 -0700 Subject: [PATCH 230/232] [boot.c] commentify scheme code (as c code) --- boot.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/boot.c b/boot.c index 1dd344e8..2c0d06b6 100644 --- a/boot.c +++ b/boot.c @@ -1,5 +1,9 @@ #if 0 +=pod +/* +=cut + use strict; my $src = <<'EOL'; @@ -381,6 +385,10 @@ foreach (@lines) { print "\"$_\\n\"\n"; } +=pod +*/ +=cut + print < Date: Fri, 7 Nov 2014 19:24:47 +0100 Subject: [PATCH 231/232] change %a to %f in number->string --- number.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/number.c b/number.c index 88db88d6..be819bbd 100644 --- a/number.c +++ b/number.c @@ -546,9 +546,9 @@ pic_number_number_to_string(pic_state *pic) return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); } else { - char buf[snprintf(NULL, 0, "%a", f) + 1]; + char buf[snprintf(NULL, 0, "%f", f) + 1]; - snprintf(buf, sizeof buf, "%a", f); + snprintf(buf, sizeof buf, "%f", f); return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); } From 3c3d9f4c27ad7a1945fb0aadba34881f4defb25c Mon Sep 17 00:00:00 2001 From: "Sunrin SHIMURA (keen)" <3han5chou7@gmail.com> Date: Sat, 3 Jan 2015 06:31:15 +0000 Subject: [PATCH 232/232] rm benz subtree --- .gitmodules | 3 --- extlib/benz | 1 - 2 files changed, 4 deletions(-) delete mode 160000 extlib/benz diff --git a/.gitmodules b/.gitmodules index 25d3e4f0..e69de29b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +0,0 @@ -[submodule "extlib/benz"] - path = extlib/benz - url = git://github.com/picrin-scheme/benz.git diff --git a/extlib/benz b/extlib/benz deleted file mode 160000 index 569b1ace..00000000 --- a/extlib/benz +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 569b1ace02e6a066b21f94dff23c4e01b8748bf0