first commit

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)

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")

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.

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`

blob.c

@@ -0,0 +1,196 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <string.h>
+
+#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);
+}

bool.c

@@ -0,0 +1,201 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <string.h>
+
+#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);
+}

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);
+}

cont.c

@@ -0,0 +1,371 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <setjmp.h>
+#include <string.h>
+#include <stdarg.h>
+
+#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, "<continuation-procedure>");
+
+    /* 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, "<continuation-procedure>");
+
+    /* 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);
+}

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;
+}

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);
+}

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);
+  }
+}

error.c

@@ -0,0 +1,286 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+
+#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);
+}

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);
+  }
+}

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);
+  }
+}

gc.c

@@ -0,0 +1,872 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdlib.h>
+
+#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 <string.h>
+#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;
+}

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"))))

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 <stddef.h>
+#include <stdbool.h>
+#include <setjmp.h>
+#include <stdio.h>
+#include <stdint.h>
+#include <limits.h>
+#include <assert.h>
+
+#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

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"))))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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 <stdnoreturn.h>
+#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 <assert.h>
+# 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

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

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

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

init.c

@@ -0,0 +1,124 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdlib.h>
+
+#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;
+  }
+}

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);
+}

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);
+}

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);
+  }
+}

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);
+  }
+}

number.c

@@ -0,0 +1,944 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <math.h>
+#include <limits.h>
+#include <stdlib.h>
+
+#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);
+  }
+}

pair.c

@@ -0,0 +1,767 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdarg.h>
+
+#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);
+  }
+}

port.c

@@ -0,0 +1,749 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+
+#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);
+}

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);
+  }
+}

read.c

@@ -0,0 +1,976 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <ctype.h>
+#include <math.h>
+#include <stdlib.h>
+#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);
+  }
+}

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);
+  }
+}

state.c

@@ -0,0 +1,205 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdlib.h>
+
+#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);
+}

string.c

@@ -0,0 +1,424 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <string.h>
+
+#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_lt);
+  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);
+}

symbol.c

@@ -0,0 +1,161 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <string.h>
+#include <stdlib.h>
+#include <math.h>
+
+#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);
+  }
+}

system.c

@@ -0,0 +1,136 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdlib.h>
+
+#include "picrin.h"
+#include "picrin/string.h"
+#include "picrin/pair.h"
+#include "picrin/cont.h"
+
+static pic_value
+pic_system_cmdline(pic_state *pic)
+{
+  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);
+  }
+}

time.c

@@ -0,0 +1,49 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <time.h>
+
+#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);
+  }
+}

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);
+  }
+}

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);
+}

write.c

@@ -0,0 +1,506 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <math.h>
+
+#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, "#<record %p>", 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, "#<undef>");
+    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);
+  }
+}