From a1281a8e8c5ea2df2ff730c4fd4e3a7c55e45035 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 25 Aug 2014 13:38:09 +0900 Subject: [PATCH] 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); + } +}