Merge branch 'master' into restore-config

Conflicts:
	extlib/benz

.gitmodules

@@ -1,3 +0,0 @@
-[submodule "extlib/benz"]
-	path = extlib/benz
-	url = git://github.com/picrin-scheme/benz.git

CMakeLists.txt

@@ -9,15 +9,6 @@ PROJECT(picrin)
 # load extra cmake modules
 set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/cmake/")
 
-# ----
-
-# git submodule update --init
-find_package(Git REQUIRED)
-execute_process(
-  COMMAND ${GIT_EXECUTABLE} submodule update --init
-  WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}
-  )
-
 set(CMAKE_RUNTIME_OUTPUT_DIRECTORY bin)
 set(CMAKE_LIBRARY_OUTPUT_DIRECTORY lib)
 set(CMAKE_C_FLAGS "-O2 -Wall -Wextra")

README.md

@@ -24,18 +24,16 @@ There is a chat room on chat.freenode.org, channel #picrin. IRC logs here: https
 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.
+Change directory to `build` then run `cmake` to create Makefile. Once `Makefile` is generated you can run `make` command to build picrin.
 
 	$ cd build
-	$ ccmake ..
+	$ cmake ..
 
-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.
+Actually you don't necessarily need to move to `build` directory before running `cmake` (in that case `$ cmake .`), but I strongly recommend to follow above instruction.
     
 Before generating Makefile, you can change some compilation switches to enable or disable optional features. Take *NAN_BOXING* for example, when you turn on "Use C11 feature" flag and the platform supports addresses of 48bit length, it is enabled.
 
@@ -49,7 +47,7 @@ If you are building picrin on other systems than x86_64, PIC_NAN_BOXING flag is
 
 ### 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.
+Just running `make install`, picrin library, headers, and runtime binary are install on your system, by default into `/usr/local` directory. You can change this value via cmake.
 
 	$ make install
 
@@ -59,13 +57,21 @@ Before installing picrin, you can try picrin without breaking any of your system
 
 	$ make run
 
+### Run Test
+To run all the test including contribs, execute this.
+
+    $ make test
+
+To test only R7RS features,
+
+    $ make test-r7rs
+
 ### Debug run
 
 If you execute `cmake` with debug flag `-DCMAKE_BUILD_TYPE=Debug`, it builds the binary with all debug flags enabled (PIC_GC_STRESS, VM_DEBUG, DEBUG).
 
 	$ cmake -DCMAKE_BUILD_TYPE=Debug ..
 	
-
 ## Requirement
 
 Picrin scheme depends on some external libraries to build the binary:

cmake/FindGit.cmake

@@ -1,46 +0,0 @@
-# The module defines the following variables:
-#   GIT_EXECUTABLE - path to git command line client
-#   GIT_FOUND - true if the command line client was found
-# Example usage:
-#   find_package(Git)
-#   if(GIT_FOUND)
-#     message("git found: ${GIT_EXECUTABLE}")
-#   endif()
-
-#=============================================================================
-# Copyright 2010 Kitware, Inc.
-#
-# Distributed under the OSI-approved BSD License (the "License");
-# see accompanying file Copyright.txt for details.
-#
-# This software is distributed WITHOUT ANY WARRANTY; without even the
-# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-# See the License for more information.
-#=============================================================================
-# (To distributed this file outside of CMake, substitute the full
-#  License text for the above reference.)
-
-# Look for 'git' or 'eg' (easy git)
-#
-set(git_names git eg)
-
-# Prefer .cmd variants on Windows unless running in a Makefile
-# in the MSYS shell.
-#
-if(WIN32)
-  if(NOT CMAKE_GENERATOR MATCHES "MSYS")
-    set(git_names git.cmd git eg.cmd eg)
-  endif()
-endif()
-
-find_program(GIT_EXECUTABLE
-  NAMES ${git_names}
-  DOC "git command line client"
-  )
-mark_as_advanced(GIT_EXECUTABLE)
-
-# Handle the QUIETLY and REQUIRED arguments and set GIT_FOUND to TRUE if
-# all listed variables are TRUE
-
-include(FindPackageHandleStandardArgs)
-find_package_handle_standard_args(Git DEFAULT_MSG GIT_EXECUTABLE)

docs/CMakeLists.txt

@@ -9,7 +9,7 @@ set(PICRIN_DOC_OUTPUT_DIRECTORY doc)
 add_custom_command(
   OUTPUT ${PICRIN_CONTRIBS_DOC}
   COMMAND echo "Contrib Libraries \\\(a.k.a nitros\\\)" > ${PICRIN_CONTRIBS_DOC}
-  COMMAND echo "===============================" >> ${PICRIN_CONTRIBS_DOC}
+  COMMAND echo "================================" >> ${PICRIN_CONTRIBS_DOC}
   COMMAND echo "" >> ${PICRIN_CONTRIBS_DOC}
   COMMAND cat ${PICRIN_CONTRIB_DOCS} >> ${PICRIN_CONTRIBS_DOC}
   DEPENDS ${PICRIN_CONTRIB_DOCS}

docs/capi.rst

@@ -12,7 +12,7 @@ If you want to create a contribution library with C, the only thing you need to
 
 .. sourcecode:: cmake
 
-  list(APPEND PICRIN_CONTRIB_INITS "void pic_init_add(pic_state *)\; pic_init_add(pic)\;")
+  list(APPEND PICRIN_CONTRIB_INITS add)
   list(APPEND PICRIN_CONTRIB_SOURCES ${PROJECT_SOURCE_DIR}/contrib/add/add.c)
 
 * contrib/add/add.c
@@ -34,7 +34,7 @@ If you want to create a contribution library with C, the only thing you need to
   void
   pic_init_add(pic_state *pic)
   {
-    pic_deflibrary ("(picrin add)") {
+    pic_deflibrary (pic, "(picrin add)") {
       pic_defun(pic, "add", pic_add);
     }
   }

docs/contrib.rst

@@ -1,5 +1,5 @@
 Contrib Libraries (a.k.a nitros)
-===============================
+================================
 
 Scheme standard libraries
 -------------------------

extlib/benz

@@ -1 +0,0 @@
-Subproject commit 2440372c16fd1e479ad8aa346f6006dbf795a74c

extlib/benz/README.md

@@ -0,0 +1,120 @@
+# Benz
+
+Benz is a super tiny scheme interpreter intended to be embedded in other applications such as game engine and network server. It provides a subset language of R7RS with several useful extensions. By default, Benz just contains some C files and headers and this README file. In embedding, you only need to copy the files into the project and add `include` dir to the include path.
+
+Originally, Benz used to be the core component of [Picrin Scheme](https://github.com/picrin-scheme/picrin). They are currently maintained at separate repositories.
+
+## Example
+
+```c
+#include <stdio.h>
+
+#include "picrin.h"
+
+/* Simple REPL program */
+
+int
+main(int argc, char *argv[])
+{
+  pic_state *pic;
+  pic_value expr;
+
+  pic = pic_open(argc, argv, NULL);
+
+  while (1) {
+    printf("> ");
+
+    expr = pic_read(pic, pic_stdin(pic));
+
+    if (pic_eof_p(expr)) {
+      break;
+    }
+
+    pic_printf(pic, "~s\n", pic_eval(pic, expr, pic->lib));
+  }
+
+  pic_close(pic);
+
+  return 0;
+}
+```
+
+## More Example
+
+Function binding is also easy. `pic_defun` defines a scheme procedure converting from a C function. In the native function, callee arguments can be taken with `pic_get_args`. `pic_get_args` gets arguments according to the format string. If actual arguments does not match a number or incompatible types, it will raise an exception.
+
+```c
+#include "picrin.h"
+
+int fact(int i) {
+  return i == 1 ? 1 : i * fact(i - 1);
+}
+
+pic_value factorial(pic_state *pic) {
+  int i;
+
+  pic_get_args(pic, "i", &i);
+
+  return pic_int_value(fact(i));
+}
+
+int
+main(int argc, char *argv[])
+{
+  pic_state *pic = pic_open(argc, argv, NULL);
+
+  pic_defun(pic, "fact", factorial); /* define fact procedure */
+
+  pic_load_cstr(pic, "(display (fact 10))");
+
+  pic_close(pic);
+
+  return 0;
+}
+```
+
+## Language
+
+All procedures and syntaces are exported from a single library named `(picrin base)`. The complete list is found at https://gist.github.com/wasabiz/344d802a2340d1f734b7 .
+
+### call/cc
+
+Full continuation has many problems in embbeding into applications. By default, Benz's call/cc operator does not support continuation that can handle re-entering (it only supports escape continuations). To remove this restriction, please use an add-on provided from [Picrin Scheme's repository](https://github.com/picrin-scheme/picrin/tree/master/contrib/03.callcc).
+
+### Strings
+
+Benz utilize rope data structure to implement string type. Thanks to the implementation, string-append is guaranteed to be done in a constant time (so do string-copy, when ascii-only mode is enabled). In return for that, strings in benz are immutable by default. It does not provide mutation API (string-set!, string-copy! and string-fill! in R7RS). This restriction can be also removed with an add-on in [Picrin Scheme's repository](https://github.com/picrin-scheme/picrin/tree/master/contrib/03.mutable-string).
+
+### Dictionaries
+
+Dictionary is a hash table object. Its equivalence is tested with equal? procedure.
+
+### Attribute
+
+Benz has an facility to get or set metadata to any heap object.
+
+## Authors
+
+See https://github.com/picrin-scheme/benz and https://github.com/picrin-scheme/picrin for details.
+
+## LICENSE
+
+Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+

extlib/benz/attr.c

@@ -0,0 +1,50 @@
+#include "picrin.h"
+#include "picrin/dict.h"
+
+struct pic_dict *
+pic_attr(pic_state *pic, pic_value obj)
+{
+  xh_entry *e;
+
+  if (pic_vtype(obj) != PIC_VTYPE_HEAP) {
+    pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj);
+  }
+
+  e = xh_get_ptr(&pic->attrs, pic_ptr(obj));
+  if (e == NULL) {
+    struct pic_dict *dict = pic_make_dict(pic);
+
+    e = xh_put_ptr(&pic->attrs, pic_ptr(obj), &dict);
+
+    assert(dict == xh_val(e, struct pic_dict *));
+  }
+  return xh_val(e, struct pic_dict *);
+}
+
+pic_value
+pic_attr_ref(pic_state *pic, pic_value obj, const char *key)
+{
+  return pic_dict_ref(pic, pic_attr(pic, obj), pic_sym_value(pic_intern_cstr(pic, key)));
+}
+
+void
+pic_attr_set(pic_state *pic, pic_value obj, const char *key, pic_value v)
+{
+  pic_dict_set(pic, pic_attr(pic, obj), pic_sym_value(pic_intern_cstr(pic, key)), v);
+}
+
+static pic_value
+pic_attr_attribute(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+
+  return pic_obj_value(pic_attr(pic, obj));
+}
+
+void
+pic_init_attr(pic_state *pic)
+{
+  pic_defun(pic, "attribute", pic_attr_attribute);
+}

extlib/benz/blob.c

@@ -0,0 +1,266 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <string.h>
+
+#include "picrin.h"
+#include "picrin/blob.h"
+#include "picrin/pair.h"
+
+struct pic_blob *
+pic_make_blob(pic_state *pic, size_t len)
+{
+  struct pic_blob *bv;
+
+  bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB);
+  bv->data = pic_alloc(pic, len);
+  bv->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_bytevector(pic_state *pic)
+{
+  pic_value *argv;
+  size_t argc, i;
+  pic_blob *blob;
+  unsigned char *data;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  blob = pic_make_blob(pic, argc);
+
+  data = blob->data;
+
+  for (i = 0; i < argc; ++i) {
+    pic_assert_type(pic, argv[i], int);
+
+    if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) {
+      pic_errorf(pic, "byte out of range");
+    }
+
+    *data++ = (unsigned char)pic_int(argv[i]);
+  }
+
+  return pic_obj_value(blob);
+}
+
+static pic_value
+pic_blob_make_bytevector(pic_state *pic)
+{
+  pic_blob *blob;
+  size_t k, i;
+  int b = 0;
+
+  pic_get_args(pic, "k|i", &k, &b);
+
+  if (b < 0 || b > 255)
+    pic_errorf(pic, "byte out of range");
+
+  blob = pic_make_blob(pic, k);
+  for (i = 0; i < k; ++i) {
+    blob->data[i] = (unsigned char)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_size_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_errorf(pic, "byte out of range");
+
+  bv->data[k] = (unsigned char)v;
+  return pic_none_value();
+}
+
+static pic_value
+pic_blob_bytevector_copy_i(pic_state *pic)
+{
+  pic_blob *to, *from;
+  int n;
+  size_t at, start, end;
+
+  n = pic_get_args(pic, "bkb|kk", &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;
+  size_t start, end, i = 0;
+
+  n = pic_get_args(pic, "b|kk", &from, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = from->len;
+  }
+
+  if (end < start) {
+    pic_errorf(pic, "make-bytevector: end index must not be less than start index");
+  }
+
+  to = pic_make_blob(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_make_blob(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);
+}
+
+static pic_value
+pic_blob_list_to_bytevector(pic_state *pic)
+{
+  pic_blob *blob;
+  unsigned char *data;
+  pic_value list, e;
+
+  pic_get_args(pic, "o", &list);
+
+  blob = pic_make_blob(pic, pic_length(pic, list));
+
+  data = blob->data;
+
+  pic_for_each (e, list) {
+    pic_assert_type(pic, e, int);
+
+    if (pic_int(e) < 0 || pic_int(e) > 255)
+      pic_errorf(pic, "byte out of range");
+
+    *data++ = (unsigned char)pic_int(e);
+  }
+  return pic_obj_value(blob);
+}
+
+static pic_value
+pic_blob_bytevector_to_list(pic_state *pic)
+{
+  pic_blob *blob;
+  pic_value list;
+  int n;
+  size_t start, end, i;
+
+  n = pic_get_args(pic, "b|kk", &blob, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = blob->len;
+  }
+
+  list = pic_nil_value();
+
+  for (i = start; i < end; ++i) {
+    pic_push(pic, pic_int_value(blob->data[i]), list);
+  }
+  return pic_reverse(pic, list);
+}
+
+void
+pic_init_blob(pic_state *pic)
+{
+  pic_defun(pic, "bytevector?", pic_blob_bytevector_p);
+  pic_defun(pic, "bytevector", pic_blob_bytevector);
+  pic_defun(pic, "make-bytevector", pic_blob_make_bytevector);
+  pic_defun(pic, "bytevector-length", pic_blob_bytevector_length);
+  pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref);
+  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);
+  pic_defun(pic, "bytevector->list", pic_blob_bytevector_to_list);
+  pic_defun(pic, "list->bytevector", pic_blob_list_to_bytevector);
+}

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

extlib/benz/boot.c

@@ -0,0 +1,769 @@
+#if 0
+
+=pod
+/*
+=cut
+
+use strict;
+
+my $src = <<'EOL';
+
+(define-library (picrin base)
+
+  (define (memoize f)
+    "memoize on symbols"
+    (define cache (make-dictionary))
+    (lambda (sym)
+      (call-with-values (lambda () (dictionary-ref cache sym))
+        (lambda (value exists)
+          (if exists
+              value
+              (begin
+                (define val (f sym))
+                (dictionary-set! cache sym val)
+                val))))))
+
+  (define (er-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define rename
+        (memoize
+         (lambda (sym)
+           (make-identifier sym mac-env))))
+
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? use-env x use-env y))))
+
+      (f expr rename compare)))
+
+  (define-syntax syntax-error
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (apply error (cdr expr)))))
+
+  (define-syntax define-auxiliary-syntax
+    (er-macro-transformer
+     (lambda (expr r c)
+       (list (r 'define-syntax) (cadr expr)
+             (list (r 'lambda) '_
+                   (list (r 'error) "invalid use of auxiliary syntax"))))))
+
+  (define-auxiliary-syntax else)
+  (define-auxiliary-syntax =>)
+  (define-auxiliary-syntax unquote)
+  (define-auxiliary-syntax unquote-splicing)
+
+  (define-syntax let
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (if (symbol? (cadr expr))
+           (begin
+             (define name     (car (cdr expr)))
+             (define bindings (car (cdr (cdr expr))))
+             (define body     (cdr (cdr (cdr expr))))
+             (list (r 'let) '()
+                   (list (r 'define) name
+                         (cons (r 'lambda) (cons (map car bindings) body)))
+                   (cons name (map cadr bindings))))
+           (begin
+             (set! bindings (cadr expr))
+             (set! body (cddr expr))
+             (cons (cons (r 'lambda) (cons (map car bindings) body))
+                   (map cadr bindings)))))))
+
+  (define-syntax cond
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (let ((clauses (cdr expr)))
+         (if (null? clauses)
+             #f
+             (begin
+               (define clause (car clauses))
+               (if (compare (r 'else) (car clause))
+                   (cons (r 'begin) (cdr clause))
+                   (if (if (>= (length clause) 2)
+                           (compare (r '=>) (list-ref clause 1))
+                           #f)
+                       (list (r 'let) (list (list (r 'x) (car clause)))
+                             (list (r 'if) (r 'x)
+                                   (list (list-ref clause 2) (r 'x))
+                                   (cons (r 'cond) (cdr clauses))))
+                       (list (r 'if) (car clause)
+                             (cons (r 'begin) (cdr clause))
+                             (cons (r 'cond) (cdr clauses)))))))))))
+
+  (define-syntax and
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (let ((exprs (cdr expr)))
+         (cond
+          ((null? exprs)
+           #t)
+          ((= (length exprs) 1)
+           (car exprs))
+          (else
+           (list (r 'let) (list (list (r 'it) (car exprs)))
+                 (list (r 'if) (r 'it)
+                       (cons (r 'and) (cdr exprs))
+                       (r 'it)))))))))
+
+  (define-syntax or
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (let ((exprs (cdr expr)))
+         (cond
+          ((null? exprs)
+           #t)
+          ((= (length exprs) 1)
+           (car exprs))
+          (else
+           (list (r 'let) (list (list (r 'it) (car exprs)))
+                 (list (r 'if) (r 'it)
+                       (r 'it)
+                       (cons (r 'or) (cdr exprs))))))))))
+
+  (define-syntax quasiquote
+    (er-macro-transformer
+     (lambda (form rename compare)
+
+       (define (quasiquote? form)
+         (and (pair? form) (compare (car form) (rename 'quasiquote))))
+
+       (define (unquote? form)
+         (and (pair? form) (compare (car form) (rename 'unquote))))
+
+       (define (unquote-splicing? form)
+         (and (pair? form) (pair? (car form))
+              (compare (car (car form)) (rename 'unquote-splicing))))
+
+       (define (qq depth expr)
+         (cond
+          ;; unquote
+          ((unquote? expr)
+           (if (= depth 1)
+               (car (cdr expr))
+               (list (rename 'list)
+                     (list (rename 'quote) (rename 'unquote))
+                     (qq (- depth 1) (car (cdr expr))))))
+          ;; unquote-splicing
+          ((unquote-splicing? expr)
+           (if (= depth 1)
+               (list (rename 'append)
+                     (car (cdr (car expr)))
+                     (qq depth (cdr expr)))
+               (list (rename 'cons)
+                     (list (rename 'list)
+                           (list (rename 'quote) (rename 'unquote-splicing))
+                           (qq (- depth 1) (car (cdr (car expr)))))
+                     (qq depth (cdr expr)))))
+          ;; quasiquote
+          ((quasiquote? expr)
+           (list (rename 'list)
+                 (list (rename 'quote) (rename 'quasiquote))
+                 (qq (+ depth 1) (car (cdr expr)))))
+          ;; list
+          ((pair? expr)
+           (list (rename 'cons)
+                 (qq depth (car expr))
+                 (qq depth (cdr expr))))
+          ;; vector
+          ((vector? expr)
+           (list (rename 'list->vector) (qq depth (vector->list expr))))
+          ;; simple datum
+          (else
+           (list (rename 'quote) expr))))
+
+       (let ((x (cadr form)))
+         (qq 1 x)))))
+
+  (define-syntax let*
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((bindings (cadr form))
+             (body (cddr form)))
+         (if (null? bindings)
+             `(,(r 'let) () ,@body)
+             `(,(r 'let) ((,(caar bindings)
+                           ,@(cdar bindings)))
+               (,(r 'let*) (,@(cdr bindings))
+                ,@body)))))))
+
+  (define-syntax letrec*
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((bindings (cadr form))
+             (body (cddr form)))
+         (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
+               (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
+           `(,(r 'let) (,@vars)
+             ,@initials
+             ,@body))))))
+
+  (define-syntax letrec
+    (er-macro-transformer
+     (lambda (form rename compare)
+       `(,(rename 'letrec*) ,@(cdr form)))))
+
+  (define-syntax let*-values
+    (er-macro-transformer
+     (lambda (form r c)
+       (let ((formals (cadr form)))
+         (if (null? formals)
+             `(,(r 'let) () ,@(cddr form))
+             `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))
+               (,(r 'lambda) (,@(caar formals))
+                (,(r 'let*-values) (,@(cdr formals))
+                 ,@(cddr form)))))))))
+
+  (define-syntax let-values
+    (er-macro-transformer
+     (lambda (form r c)
+       `(,(r 'let*-values) ,@(cdr form)))))
+
+  (define-syntax define-values
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((formal (cadr form))
+             (exprs  (cddr form)))
+         `(,(r 'begin)
+            ,@(let loop ((formal formal))
+                (if (not (pair? formal))
+                    (if (symbol? formal)
+                        `((,(r 'define) ,formal #f))
+                        '())
+                    `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))))
+            (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)
+              (,(r 'lambda) ,(r 'args)
+                ,@(let loop ((formal formal) (args (r 'args)))
+                    (if (not (pair? formal))
+                        (if (symbol? formal)
+                            `((,(r 'set!) ,formal ,args))
+                            '())
+                        `((,(r 'set!) ,(car formal) (,(r 'car) ,args))
+                          ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))
+
+  (define-syntax do
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((bindings (car (cdr form)))
+             (finish   (car (cdr (cdr form))))
+             (body     (cdr (cdr (cdr form)))))
+         `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
+                                        (list (car x) (cadr x)))
+                                      bindings)
+           (,(r 'if) ,(car finish)
+            (,(r 'begin) ,@(cdr finish))
+            (,(r 'begin) ,@body
+             (,(r 'loop) ,@(map (lambda (x)
+                                  (if (null? (cddr x))
+                                      (car x)
+                                      (car (cddr x))))
+                                bindings)))))))))
+
+  (define-syntax when
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (let ((test (cadr expr))
+             (body (cddr expr)))
+         `(,(rename 'if) ,test
+              (,(rename 'begin) ,@body)
+              #f)))))
+
+  (define-syntax unless
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (let ((test (cadr expr))
+             (body (cddr expr)))
+         `(,(rename 'if) ,test
+              #f
+              (,(rename 'begin) ,@body))))))
+
+  (define-syntax case
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (let ((key (cadr expr))
+             (clauses (cddr expr)))
+         `(,(r 'let) ((,(r 'key) ,key))
+            ,(let loop ((clauses clauses))
+               (if (null? clauses)
+                   #f
+                   (begin
+                     (define clause (car clauses))
+                     `(,(r 'if) ,(if (compare (r 'else) (car clause))
+                                     '#t
+                                     `(,(r 'or)
+                                       ,@(map (lambda (x)
+                                                `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
+                                              (car clause))))
+                       ,(if (compare (r '=>) (list-ref clause 1))
+                            `(,(list-ref clause 2) ,(r 'key))
+                            `(,(r 'begin) ,@(cdr clause)))
+                       ,(loop (cdr clauses)))))))))))
+
+  (define (dynamic-bind parameters values body)
+    (let* ((old-bindings
+            (current-dynamic-environment))
+           (binding
+            (let ((dict (dictionary)))
+              (for-each
+               (lambda (parameter value)
+                 (dictionary-set! dict parameter (list (parameter value #f))))
+               parameters
+               values)
+              dict))
+           (new-bindings
+            (cons binding old-bindings)))
+      (dynamic-wind
+          (lambda () (current-dynamic-environment new-bindings))
+          body
+          (lambda () (current-dynamic-environment old-bindings)))))
+
+  (define-syntax parameterize
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((formal (cadr form))
+             (body (cddr form)))
+         `(,(r 'dynamic-bind)
+           (list ,@(map car formal))
+           (list ,@(map cadr formal))
+           (,(r 'lambda) () ,@body))))))
+
+  (define-syntax letrec-syntax
+    (er-macro-transformer
+     (lambda (form r c)
+       (let ((formal (car (cdr form)))
+             (body   (cdr (cdr form))))
+         `(let ()
+            ,@(map (lambda (x)
+                     `(,(r 'define-syntax) ,(car x) ,(cadr x)))
+                   formal)
+            ,@body)))))
+
+  (define-syntax let-syntax
+    (er-macro-transformer
+     (lambda (form r c)
+       `(,(r 'letrec-syntax) ,@(cdr form)))))
+
+  (export let let* letrec letrec*
+          let-values let*-values define-values
+          quasiquote unquote unquote-splicing
+          and or
+          cond case else =>
+          do when unless
+          parameterize
+          let-syntax letrec-syntax
+          syntax-error))
+
+EOL
+
+open IN, "./boot.c";
+my @data = <IN>;
+close IN;
+
+open STDOUT, ">", "./boot.c";
+
+foreach (@data) {
+  print;
+  last if $_ eq "#---END---\n";
+}
+
+print "\n#endif\n\n";
+
+print <<EOL;
+const char pic_boot[] =
+EOL
+
+my @lines = split /\n/, $src;
+
+foreach (@lines) {
+  s/\\/\\\\/g;
+  s/"/\\"/g;
+  print "\"$_\\n\"\n";
+}
+
+=pod
+*/
+=cut
+
+print <<EOL;
+;
+
+#if 0
+Local Variables:
+mode: scheme
+End:
+
+=cut
+#endif
+EOL
+
+=pod
+
+#---END---
+
+#endif
+
+const char pic_boot[] =
+"\n"
+"(define-library (picrin base)\n"
+"\n"
+"  (define (memoize f)\n"
+"    \"memoize on symbols\"\n"
+"    (define cache (make-dictionary))\n"
+"    (lambda (sym)\n"
+"      (call-with-values (lambda () (dictionary-ref cache sym))\n"
+"        (lambda (value exists)\n"
+"          (if exists\n"
+"              value\n"
+"              (begin\n"
+"                (define val (f sym))\n"
+"                (dictionary-set! cache sym val)\n"
+"                val))))))\n"
+"\n"
+"  (define (er-macro-transformer f)\n"
+"    (lambda (expr use-env mac-env)\n"
+"\n"
+"      (define rename\n"
+"        (memoize\n"
+"         (lambda (sym)\n"
+"           (make-identifier sym mac-env))))\n"
+"\n"
+"      (define (compare x y)\n"
+"        (if (not (symbol? x))\n"
+"            #f\n"
+"            (if (not (symbol? y))\n"
+"                #f\n"
+"                (identifier=? use-env x use-env y))))\n"
+"\n"
+"      (f expr rename compare)))\n"
+"\n"
+"  (define-syntax syntax-error\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr rename compare)\n"
+"       (apply error (cdr expr)))))\n"
+"\n"
+"  (define-syntax define-auxiliary-syntax\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr r c)\n"
+"       (list (r 'define-syntax) (cadr expr)\n"
+"             (list (r 'lambda) '_\n"
+"                   (list (r 'error) \"invalid use of auxiliary syntax\"))))))\n"
+"\n"
+"  (define-auxiliary-syntax else)\n"
+"  (define-auxiliary-syntax =>)\n"
+"  (define-auxiliary-syntax unquote)\n"
+"  (define-auxiliary-syntax unquote-splicing)\n"
+"\n"
+"  (define-syntax let\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr r compare)\n"
+"       (if (symbol? (cadr expr))\n"
+"           (begin\n"
+"             (define name     (car (cdr expr)))\n"
+"             (define bindings (car (cdr (cdr expr))))\n"
+"             (define body     (cdr (cdr (cdr expr))))\n"
+"             (list (r 'let) '()\n"
+"                   (list (r 'define) name\n"
+"                         (cons (r 'lambda) (cons (map car bindings) body)))\n"
+"                   (cons name (map cadr bindings))))\n"
+"           (begin\n"
+"             (set! bindings (cadr expr))\n"
+"             (set! body (cddr expr))\n"
+"             (cons (cons (r 'lambda) (cons (map car bindings) body))\n"
+"                   (map cadr bindings)))))))\n"
+"\n"
+"  (define-syntax cond\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr r compare)\n"
+"       (let ((clauses (cdr expr)))\n"
+"         (if (null? clauses)\n"
+"             #f\n"
+"             (begin\n"
+"               (define clause (car clauses))\n"
+"               (if (compare (r 'else) (car clause))\n"
+"                   (cons (r 'begin) (cdr clause))\n"
+"                   (if (if (>= (length clause) 2)\n"
+"                           (compare (r '=>) (list-ref clause 1))\n"
+"                           #f)\n"
+"                       (list (r 'let) (list (list (r 'x) (car clause)))\n"
+"                             (list (r 'if) (r 'x)\n"
+"                                   (list (list-ref clause 2) (r 'x))\n"
+"                                   (cons (r 'cond) (cdr clauses))))\n"
+"                       (list (r 'if) (car clause)\n"
+"                             (cons (r 'begin) (cdr clause))\n"
+"                             (cons (r 'cond) (cdr clauses)))))))))))\n"
+"\n"
+"  (define-syntax and\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr r compare)\n"
+"       (let ((exprs (cdr expr)))\n"
+"         (cond\n"
+"          ((null? exprs)\n"
+"           #t)\n"
+"          ((= (length exprs) 1)\n"
+"           (car exprs))\n"
+"          (else\n"
+"           (list (r 'let) (list (list (r 'it) (car exprs)))\n"
+"                 (list (r 'if) (r 'it)\n"
+"                       (cons (r 'and) (cdr exprs))\n"
+"                       (r 'it)))))))))\n"
+"\n"
+"  (define-syntax or\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr r compare)\n"
+"       (let ((exprs (cdr expr)))\n"
+"         (cond\n"
+"          ((null? exprs)\n"
+"           #t)\n"
+"          ((= (length exprs) 1)\n"
+"           (car exprs))\n"
+"          (else\n"
+"           (list (r 'let) (list (list (r 'it) (car exprs)))\n"
+"                 (list (r 'if) (r 'it)\n"
+"                       (r 'it)\n"
+"                       (cons (r 'or) (cdr exprs))))))))))\n"
+"\n"
+"  (define-syntax quasiquote\n"
+"    (er-macro-transformer\n"
+"     (lambda (form rename compare)\n"
+"\n"
+"       (define (quasiquote? form)\n"
+"         (and (pair? form) (compare (car form) (rename 'quasiquote))))\n"
+"\n"
+"       (define (unquote? form)\n"
+"         (and (pair? form) (compare (car form) (rename 'unquote))))\n"
+"\n"
+"       (define (unquote-splicing? form)\n"
+"         (and (pair? form) (pair? (car form))\n"
+"              (compare (car (car form)) (rename 'unquote-splicing))))\n"
+"\n"
+"       (define (qq depth expr)\n"
+"         (cond\n"
+"          ;; unquote\n"
+"          ((unquote? expr)\n"
+"           (if (= depth 1)\n"
+"               (car (cdr expr))\n"
+"               (list (rename 'list)\n"
+"                     (list (rename 'quote) (rename 'unquote))\n"
+"                     (qq (- depth 1) (car (cdr expr))))))\n"
+"          ;; unquote-splicing\n"
+"          ((unquote-splicing? expr)\n"
+"           (if (= depth 1)\n"
+"               (list (rename 'append)\n"
+"                     (car (cdr (car expr)))\n"
+"                     (qq depth (cdr expr)))\n"
+"               (list (rename 'cons)\n"
+"                     (list (rename 'list)\n"
+"                           (list (rename 'quote) (rename 'unquote-splicing))\n"
+"                           (qq (- depth 1) (car (cdr (car expr)))))\n"
+"                     (qq depth (cdr expr)))))\n"
+"          ;; quasiquote\n"
+"          ((quasiquote? expr)\n"
+"           (list (rename 'list)\n"
+"                 (list (rename 'quote) (rename 'quasiquote))\n"
+"                 (qq (+ depth 1) (car (cdr expr)))))\n"
+"          ;; list\n"
+"          ((pair? expr)\n"
+"           (list (rename 'cons)\n"
+"                 (qq depth (car expr))\n"
+"                 (qq depth (cdr expr))))\n"
+"          ;; vector\n"
+"          ((vector? expr)\n"
+"           (list (rename 'list->vector) (qq depth (vector->list expr))))\n"
+"          ;; simple datum\n"
+"          (else\n"
+"           (list (rename 'quote) expr))))\n"
+"\n"
+"       (let ((x (cadr form)))\n"
+"         (qq 1 x)))))\n"
+"\n"
+"  (define-syntax let*\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r compare)\n"
+"       (let ((bindings (cadr form))\n"
+"             (body (cddr form)))\n"
+"         (if (null? bindings)\n"
+"             `(,(r 'let) () ,@body)\n"
+"             `(,(r 'let) ((,(caar bindings)\n"
+"                           ,@(cdar bindings)))\n"
+"               (,(r 'let*) (,@(cdr bindings))\n"
+"                ,@body)))))))\n"
+"\n"
+"  (define-syntax letrec*\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r compare)\n"
+"       (let ((bindings (cadr form))\n"
+"             (body (cddr form)))\n"
+"         (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n"
+"               (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n"
+"           `(,(r 'let) (,@vars)\n"
+"             ,@initials\n"
+"             ,@body))))))\n"
+"\n"
+"  (define-syntax letrec\n"
+"    (er-macro-transformer\n"
+"     (lambda (form rename compare)\n"
+"       `(,(rename 'letrec*) ,@(cdr form)))))\n"
+"\n"
+"  (define-syntax let*-values\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r c)\n"
+"       (let ((formals (cadr form)))\n"
+"         (if (null? formals)\n"
+"             `(,(r 'let) () ,@(cddr form))\n"
+"             `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n"
+"               (,(r 'lambda) (,@(caar formals))\n"
+"                (,(r 'let*-values) (,@(cdr formals))\n"
+"                 ,@(cddr form)))))))))\n"
+"\n"
+"  (define-syntax let-values\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r c)\n"
+"       `(,(r 'let*-values) ,@(cdr form)))))\n"
+"\n"
+"  (define-syntax define-values\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r compare)\n"
+"       (let ((formal (cadr form))\n"
+"             (exprs  (cddr form)))\n"
+"         `(,(r 'begin)\n"
+"            ,@(let loop ((formal formal))\n"
+"                (if (not (pair? formal))\n"
+"                    (if (symbol? formal)\n"
+"                        `((,(r 'define) ,formal #f))\n"
+"                        '())\n"
+"                    `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))))\n"
+"            (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n"
+"              (,(r 'lambda) ,(r 'args)\n"
+"                ,@(let loop ((formal formal) (args (r 'args)))\n"
+"                    (if (not (pair? formal))\n"
+"                        (if (symbol? formal)\n"
+"                            `((,(r 'set!) ,formal ,args))\n"
+"                            '())\n"
+"                        `((,(r 'set!) ,(car formal) (,(r 'car) ,args))\n"
+"                          ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))\n"
+"\n"
+"  (define-syntax do\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r compare)\n"
+"       (let ((bindings (car (cdr form)))\n"
+"             (finish   (car (cdr (cdr form))))\n"
+"             (body     (cdr (cdr (cdr form)))))\n"
+"         `(,(r 'let) ,(r 'loop) ,(map (lambda (x)\n"
+"                                        (list (car x) (cadr x)))\n"
+"                                      bindings)\n"
+"           (,(r 'if) ,(car finish)\n"
+"            (,(r 'begin) ,@(cdr finish))\n"
+"            (,(r 'begin) ,@body\n"
+"             (,(r 'loop) ,@(map (lambda (x)\n"
+"                                  (if (null? (cddr x))\n"
+"                                      (car x)\n"
+"                                      (car (cddr x))))\n"
+"                                bindings)))))))))\n"
+"\n"
+"  (define-syntax when\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr rename compare)\n"
+"       (let ((test (cadr expr))\n"
+"             (body (cddr expr)))\n"
+"         `(,(rename 'if) ,test\n"
+"              (,(rename 'begin) ,@body)\n"
+"              #f)))))\n"
+"\n"
+"  (define-syntax unless\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr rename compare)\n"
+"       (let ((test (cadr expr))\n"
+"             (body (cddr expr)))\n"
+"         `(,(rename 'if) ,test\n"
+"              #f\n"
+"              (,(rename 'begin) ,@body))))))\n"
+"\n"
+"  (define-syntax case\n"
+"    (er-macro-transformer\n"
+"     (lambda (expr r compare)\n"
+"       (let ((key (cadr expr))\n"
+"             (clauses (cddr expr)))\n"
+"         `(,(r 'let) ((,(r 'key) ,key))\n"
+"            ,(let loop ((clauses clauses))\n"
+"               (if (null? clauses)\n"
+"                   #f\n"
+"                   (begin\n"
+"                     (define clause (car clauses))\n"
+"                     `(,(r 'if) ,(if (compare (r 'else) (car clause))\n"
+"                                     '#t\n"
+"                                     `(,(r 'or)\n"
+"                                       ,@(map (lambda (x)\n"
+"                                                `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n"
+"                                              (car clause))))\n"
+"                       ,(if (compare (r '=>) (list-ref clause 1))\n"
+"                            `(,(list-ref clause 2) ,(r 'key))\n"
+"                            `(,(r 'begin) ,@(cdr clause)))\n"
+"                       ,(loop (cdr clauses)))))))))))\n"
+"\n"
+"  (define (dynamic-bind parameters values body)\n"
+"    (let* ((old-bindings\n"
+"            (current-dynamic-environment))\n"
+"           (binding\n"
+"            (let ((dict (dictionary)))\n"
+"              (for-each\n"
+"               (lambda (parameter value)\n"
+"                 (dictionary-set! dict parameter (list (parameter value #f))))\n"
+"               parameters\n"
+"               values)\n"
+"              dict))\n"
+"           (new-bindings\n"
+"            (cons binding old-bindings)))\n"
+"      (dynamic-wind\n"
+"          (lambda () (current-dynamic-environment new-bindings))\n"
+"          body\n"
+"          (lambda () (current-dynamic-environment old-bindings)))))\n"
+"\n"
+"  (define-syntax parameterize\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r compare)\n"
+"       (let ((formal (cadr form))\n"
+"             (body (cddr form)))\n"
+"         `(,(r 'dynamic-bind)\n"
+"           (list ,@(map car formal))\n"
+"           (list ,@(map cadr formal))\n"
+"           (,(r 'lambda) () ,@body))))))\n"
+"\n"
+"  (define-syntax letrec-syntax\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r c)\n"
+"       (let ((formal (car (cdr form)))\n"
+"             (body   (cdr (cdr form))))\n"
+"         `(let ()\n"
+"            ,@(map (lambda (x)\n"
+"                     `(,(r 'define-syntax) ,(car x) ,(cadr x)))\n"
+"                   formal)\n"
+"            ,@body)))))\n"
+"\n"
+"  (define-syntax let-syntax\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r c)\n"
+"       `(,(r 'letrec-syntax) ,@(cdr form)))))\n"
+"\n"
+"  (export let let* letrec letrec*\n"
+"          let-values let*-values define-values\n"
+"          quasiquote unquote unquote-splicing\n"
+"          and or\n"
+"          cond case else =>\n"
+"          do when unless\n"
+"          parameterize\n"
+"          let-syntax letrec-syntax\n"
+"          syntax-error))\n"
+;
+
+#if 0
+Local Variables:
+mode: scheme
+End:
+
+=cut
+#endif

extlib/benz/char.c

@@ -0,0 +1,85 @@
+/**
+ * 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);
+
+  if (i < 0 || i > 127) {
+    pic_errorf(pic, "integer->char: integer out of char range: %d", i);
+  }
+
+  return pic_char_value((char)i);
+}
+
+#define DEFINE_CHAR_CMP(op, name)			\
+  static pic_value					\
+  pic_char_##name##_p(pic_state *pic)			\
+  {							\
+    size_t argc, i;                                     \
+    pic_value *argv;					\
+    char c, d;						\
+    							\
+    pic_get_args(pic, "cc*", &c, &d, &argc, &argv);	\
+    							\
+    if (! (c op d))					\
+      return pic_false_value();				\
+    							\
+    for (i = 0; i < argc; ++i) {			\
+      c = d;                                            \
+      if (pic_char_p(argv[i]))                          \
+        d = pic_char(argv[i]);                          \
+      else						\
+	pic_errorf(pic, #op ": char required");         \
+      							\
+      if (! (c op d))					\
+	return pic_false_value();			\
+    }							\
+    							\
+    return pic_true_value();				\
+  }
+
+DEFINE_CHAR_CMP(==, eq)
+DEFINE_CHAR_CMP(<, lt)
+DEFINE_CHAR_CMP(>, gt)
+DEFINE_CHAR_CMP(<=, le)
+DEFINE_CHAR_CMP(>=, ge)
+
+void
+pic_init_char(pic_state *pic)
+{
+  pic_defun(pic, "char?", pic_char_char_p);
+  pic_defun(pic, "char->integer", pic_char_char_to_integer);
+  pic_defun(pic, "integer->char", pic_char_integer_to_char);
+  pic_defun(pic, "char=?", pic_char_eq_p);
+  pic_defun(pic, "char<?", pic_char_lt_p);
+  pic_defun(pic, "char>?", pic_char_gt_p);
+  pic_defun(pic, "char<=?", pic_char_le_p);
+  pic_defun(pic, "char>=?", pic_char_ge_p);
+}

extlib/benz/cont.c

@@ -0,0 +1,286 @@
+/**
+ * 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/data.h"
+#include "picrin/error.h"
+
+void
+pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there)
+{
+  if (here == there)
+    return;
+
+  if (here->depth < there->depth) {
+    pic_wind(pic, here, there->prev);
+    pic_apply0(pic, there->in);
+  }
+  else {
+    pic_apply0(pic, there->out);
+    pic_wind(pic, here->prev, there);
+  }
+}
+
+pic_value
+pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
+{
+  struct pic_winder *here;
+  pic_value val;
+
+  if (in != NULL) {
+    pic_apply0(pic, in);        /* enter */
+  }
+
+  here = pic->wind;
+  pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
+  pic->wind->prev = here;
+  pic->wind->depth = here->depth + 1;
+  pic->wind->in = in;
+  pic->wind->out = out;
+
+  val = pic_apply0(pic, thunk);
+
+  pic->wind = here;
+
+  if (out != NULL) {
+    pic_apply0(pic, out);       /* exit */
+  }
+
+  return val;
+}
+
+void
+pic_save_point(pic_state *pic, struct pic_escape *escape)
+{
+  escape->valid = true;
+
+  /* save runtime context */
+  escape->wind = pic->wind;
+  escape->sp_offset = pic->sp - pic->stbase;
+  escape->ci_offset = pic->ci - pic->cibase;
+  escape->xp_offset = pic->xp - pic->xpbase;
+  escape->arena_idx = pic->arena_idx;
+  escape->ip = pic->ip;
+
+  escape->results = pic_undef_value();
+}
+
+void
+pic_load_point(pic_state *pic, struct pic_escape *escape)
+{
+  if (! escape->valid) {
+    pic_errorf(pic, "calling dead escape continuation");
+  }
+
+  pic_wind(pic, pic->wind, escape->wind);
+
+  /* load runtime context */
+  pic->wind = escape->wind;
+  pic->sp = pic->stbase + escape->sp_offset;
+  pic->ci = pic->cibase + escape->ci_offset;
+  pic->xp = pic->xpbase + escape->xp_offset;
+  pic->arena_idx = escape->arena_idx;
+  pic->ip = escape->ip;
+
+  escape->valid = false;
+}
+
+noreturn static pic_value
+escape_call(pic_state *pic)
+{
+  size_t argc;
+  pic_value *argv;
+  struct pic_data *e;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  e = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
+
+  pic_load_point(pic, e->data);
+
+  longjmp(((struct pic_escape *)e->data)->jmp, 1);
+}
+
+struct pic_proc *
+pic_make_econt(pic_state *pic, struct pic_escape *escape)
+{
+  static const pic_data_type escape_type = { "escape", pic_free, NULL };
+  struct pic_proc *cont;
+  struct pic_data *e;
+
+  cont = pic_make_proc(pic, escape_call, "<escape-procedure>");
+
+  e = pic_data_alloc(pic, &escape_type, escape);
+
+  /* save the escape continuation in proc */
+  pic_attr_set(pic, pic_obj_value(cont), "@@escape", pic_obj_value(e));
+
+  return cont;
+}
+
+pic_value
+pic_escape(pic_state *pic, struct pic_proc *proc)
+{
+  struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape));
+
+  pic_save_point(pic, escape);
+
+  if (setjmp(escape->jmp)) {
+    return pic_values_by_list(pic, escape->results);
+  }
+  else {
+    pic_value val;
+
+    val = pic_apply1(pic, proc, pic_obj_value(pic_make_econt(pic, escape)));
+
+    escape->valid = false;
+
+    return val;
+  }
+}
+
+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 = (int)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;
+  int 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 = (size_t)ci->retc;
+
+  for (i = 0; i < retc && i < n; ++i) {
+    argv[i] = ci->fp[i];
+  }
+
+  return retc;
+}
+
+static pic_value
+pic_cont_callcc(pic_state *pic)
+{
+  struct pic_proc *cb;
+
+  pic_get_args(pic, "l", &cb);
+
+  return pic_escape(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);
+}

extlib/benz/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;
+}

extlib/benz/debug.c

@@ -0,0 +1,69 @@
+/**
+ * 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_make_str(pic, NULL, 0);
+
+  for (ci = pic->ci; ci != pic->cibase; --ci) {
+    struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);
+
+    trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, "  at "));
+    trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));
+
+    if (pic_proc_func_p(proc)) {
+      trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
+    } else if (pic_proc_irep_p(proc)) {
+      trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */
+    }
+  }
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, pic_obj_value(trace));
+
+  return trace;
+}
+
+void
+pic_print_backtrace(pic_state *pic)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+  pic_str *trace;
+
+  assert(! pic_undef_p(pic->err));
+
+  if (! pic_error_p(pic->err)) {
+    trace = pic_format(pic, "raised: ~s", pic->err);
+  } else {
+    struct pic_error *e;
+
+    e = pic_error_ptr(pic->err);
+    if (e->type != pic_intern_cstr(pic, "")) {
+      trace = pic_format(pic, "~s ", pic_sym_value(e->type));
+    } else {
+      trace = pic_make_str(pic, NULL, 0);
+    }
+    trace = pic_strcat(pic, trace, pic_format(pic, "error: ~s", pic_obj_value(e->msg)));
+
+    /* TODO: print error irritants */
+
+    trace = pic_strcat(pic, trace, pic_make_str(pic, "\n", 1));
+    trace = pic_strcat(pic, trace, e->stack);
+  }
+
+  /* print! */
+  xfprintf(xstderr, "%s", pic_str_cstr(trace));
+
+  pic_gc_arena_restore(pic, ai);
+}

extlib/benz/dict.c

@@ -0,0 +1,303 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/dict.h"
+#include "picrin/cont.h"
+#include "picrin/pair.h"
+
+static int
+xh_value_hash(const void *key, void *data)
+{
+  union { double f; int i; } u;
+  pic_value val = *(pic_value *)key;
+  int hash, vtype;
+
+  UNUSED(data);
+
+  vtype = pic_vtype(val);
+
+  switch (vtype) {
+  default:
+    hash = 0;
+    break;
+  case PIC_VTYPE_SYMBOL:
+    hash = pic_sym(val);
+    break;
+  case PIC_VTYPE_FLOAT:
+    u.f = pic_float(val);
+    hash = u.i;
+    break;
+  case PIC_VTYPE_INT:
+    hash = pic_int(val);
+    break;
+  case PIC_VTYPE_HEAP:
+    hash = (int)(intptr_t)pic_ptr(val);
+    break;
+  }
+
+  return hash + vtype;
+}
+
+static int
+xh_value_equal(const void *key1, const void *key2, void *pic)
+{
+  return pic_equal_p(pic, *(pic_value *)key1, *(pic_value *)key2);
+}
+
+static void
+xh_init_value(pic_state *pic, xhash *x)
+{
+  xh_init_(x, sizeof(pic_value), sizeof(pic_value), xh_value_hash, xh_value_equal, pic);
+}
+
+static inline xh_entry *
+xh_get_value(xhash *x, pic_value key)
+{
+  return xh_get_(x, &key);
+}
+
+static inline xh_entry *
+xh_put_value(xhash *x, pic_value key, void *val)
+{
+  return xh_put_(x, &key, val);
+}
+
+static inline void
+xh_del_value(xhash *x, pic_value key)
+{
+  xh_del_(x, &key);
+}
+
+struct pic_dict *
+pic_make_dict(pic_state *pic)
+{
+  struct pic_dict *dict;
+
+  dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
+  xh_init_value(pic, &dict->hash);
+
+  return dict;
+}
+
+pic_value
+pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_value key)
+{
+  xh_entry *e;
+
+  e = xh_get_value(&dict->hash, key);
+  if (! e) {
+    pic_errorf(pic, "element not found for a key: ~s", key);
+  }
+  return xh_val(e, pic_value);
+}
+
+void
+pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_value key, pic_value val)
+{
+  UNUSED(pic);
+
+  xh_put_value(&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_value key)
+{
+  UNUSED(pic);
+
+  return xh_get_value(&dict->hash, key) != NULL;
+}
+
+void
+pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_value key)
+{
+  if (xh_get_value(&dict->hash, key) == NULL) {
+    pic_errorf(pic, "no slot named ~s found in dictionary", key);
+  }
+
+  xh_del_value(&dict->hash, key);
+}
+
+static pic_value
+pic_dict_make_dictionary(pic_state *pic)
+{
+  struct pic_dict *dict;
+
+  pic_get_args(pic, "");
+
+  dict = pic_make_dict(pic);
+
+  return pic_obj_value(dict);
+}
+
+static pic_value
+pic_dict_dictionary(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_value *argv;
+  size_t argc, i;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  dict = pic_make_dict(pic);
+
+  for (i = 0; i < argc; i += 2) {
+    pic_dict_set(pic, dict, argv[i], argv[i+1]);
+  }
+
+  return pic_obj_value(dict);
+}
+
+static pic_value
+pic_dict_dictionary_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_dictionary_ref(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_value key;
+
+  pic_get_args(pic, "do", &dict, &key);
+
+  if (pic_dict_has(pic, dict, key)) {
+    return pic_values2(pic, pic_dict_ref(pic, dict, key), pic_true_value());
+  } else {
+    return pic_values2(pic, pic_none_value(), pic_false_value());
+  }
+}
+
+static pic_value
+pic_dict_dictionary_set(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_value key, val;
+
+  pic_get_args(pic, "doo", &dict, &key, &val);
+
+  pic_dict_set(pic, dict, key, val);
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_dict_dictionary_del(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_value key;
+
+  pic_get_args(pic, "do", &dict, &key);
+
+  pic_dict_del(pic, dict, key);
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_dict_dictionary_size(pic_state *pic)
+{
+  struct pic_dict *dict;
+
+  pic_get_args(pic, "d", &dict);
+
+  return pic_size_value(pic_dict_size(pic, dict));
+}
+
+static pic_value
+pic_dict_dictionary_to_alist(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_value item, alist = pic_nil_value();
+  xh_entry *it;
+
+  pic_get_args(pic, "d", &dict);
+
+  for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
+    item = pic_cons(pic, xh_key(it, pic_value), xh_val(it, pic_value));
+    pic_push(pic, item, alist);
+  }
+
+  return pic_reverse(pic, alist);
+}
+
+static pic_value
+pic_dict_alist_to_dictionary(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_value alist, e;
+
+  pic_get_args(pic, "o", &alist);
+
+  dict = pic_make_dict(pic);
+
+  pic_for_each (e, pic_reverse(pic, alist)) {
+    pic_dict_set(pic, dict, pic_car(pic, e), pic_cdr(pic, e));
+  }
+
+  return pic_obj_value(dict);
+}
+
+static pic_value
+pic_dict_dictionary_to_plist(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_value plist = pic_nil_value();
+  xh_entry *it;
+
+  pic_get_args(pic, "d", &dict);
+
+  for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
+    pic_push(pic, xh_key(it, pic_value), plist);
+    pic_push(pic, xh_val(it, pic_value), plist);
+  }
+
+  return pic_reverse(pic, plist);
+}
+
+static pic_value
+pic_dict_plist_to_dictionary(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_value plist, e;
+
+  pic_get_args(pic, "o", &plist);
+
+  dict = pic_make_dict(pic);
+
+  for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) {
+    pic_dict_set(pic, dict, pic_cadr(pic, e), pic_car(pic, e));
+  }
+
+  return pic_obj_value(dict);
+}
+
+void
+pic_init_dict(pic_state *pic)
+{
+  pic_defun(pic, "make-dictionary", pic_dict_make_dictionary);
+  pic_defun(pic, "dictionary?", pic_dict_dictionary_p);
+  pic_defun(pic, "dictionary", pic_dict_dictionary);
+  pic_defun(pic, "dictionary-ref", pic_dict_dictionary_ref);
+  pic_defun(pic, "dictionary-set!", pic_dict_dictionary_set);
+  pic_defun(pic, "dictionary-delete!", pic_dict_dictionary_del);
+  pic_defun(pic, "dictionary-size", pic_dict_dictionary_size);
+  pic_defun(pic, "dictionary->alist", pic_dict_dictionary_to_alist);
+  pic_defun(pic, "alist->dictionary", pic_dict_alist_to_dictionary);
+  pic_defun(pic, "dictionary->plist", pic_dict_dictionary_to_plist);
+  pic_defun(pic, "plist->dictionary", pic_dict_plist_to_dictionary);
+}

extlib/benz/error.c

@@ -0,0 +1,324 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+
+#include "picrin.h"
+#include "picrin/pair.h"
+#include "picrin/proc.h"
+#include "picrin/cont.h"
+#include "picrin/data.h"
+#include "picrin/string.h"
+#include "picrin/error.h"
+
+void
+pic_panic(pic_state *pic, const char *msg)
+{
+  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_xvformat(pic, fmt, ap);
+  va_end(ap);
+
+  fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))));
+}
+
+void
+pic_errorf(pic_state *pic, const char *fmt, ...)
+{
+  va_list ap;
+  pic_value err_line, irrs;
+  const char *msg;
+
+  va_start(ap, fmt);
+  err_line = pic_xvformat(pic, fmt, ap);
+  va_end(ap);
+
+  msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)));
+  irrs = pic_cdr(pic, err_line);
+
+  pic_error(pic, msg, irrs);
+}
+
+const char *
+pic_errmsg(pic_state *pic)
+{
+  pic_str *str;
+
+  assert(! pic_undef_p(pic->err));
+
+  if (! pic_error_p(pic->err)) {
+    str = pic_format(pic, "~s", pic->err);
+  } else {
+    str = pic_error_ptr(pic->err)->msg;
+  }
+
+  return pic_str_cstr(str);
+}
+
+noreturn static pic_value
+native_exception_handler(pic_state *pic)
+{
+  pic_value err;
+  struct pic_proc *cont;
+
+  pic_get_args(pic, "o", &err);
+
+  pic->err = err;
+
+  cont = pic_proc_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
+
+  pic_apply1(pic, cont, pic_false_value());
+
+  UNREACHABLE();
+}
+
+void
+pic_push_try(pic_state *pic, struct pic_escape *escape)
+{
+  struct pic_proc *cont, *handler;
+  size_t xp_len;
+  ptrdiff_t xp_offset;
+
+  cont = pic_make_econt(pic, escape);
+
+  handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)");
+
+  pic_attr_set(pic, pic_obj_value(handler), "@@escape", pic_obj_value(cont));
+
+  if (pic->xp >= pic->xpend) {
+    xp_len = (size_t)(pic->xpend - pic->xpbase) * 2;
+    xp_offset = pic->xp - pic->xpbase;
+    pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len);
+    pic->xp = pic->xpbase + xp_offset;
+    pic->xpend = pic->xpbase + xp_len;
+  }
+
+  *pic->xp++ = handler;
+}
+
+void
+pic_pop_try(pic_state *pic)
+{
+  pic_value cont, escape;
+
+  assert(pic->xp > pic->xpbase);
+
+  cont = pic_attr_ref(pic, pic_obj_value(*--pic->xp), "@@escape");
+
+  assert(pic_proc_p(cont));
+
+  escape = pic_attr_ref(pic, cont, "@@escape");
+
+  assert(pic_data_p(escape));
+
+  ((struct pic_escape *)pic_data_ptr(escape)->data)->valid = false;
+}
+
+struct pic_error *
+pic_make_error(pic_state *pic, pic_sym type, const char *msg, pic_value irrs)
+{
+  struct pic_error *e;
+  pic_str *stack;
+
+  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 = pic_make_str_cstr(pic, msg);
+  e->irrs = irrs;
+  e->stack = stack;
+
+  return e;
+}
+
+pic_value
+pic_raise_continuable(pic_state *pic, pic_value err)
+{
+  struct pic_proc *handler;
+  pic_value v;
+
+  if (pic->xp == pic->xpbase) {
+    pic_panic(pic, "no exception handler registered");
+  }
+
+  handler = *--pic->xp;
+
+  pic_gc_protect(pic, pic_obj_value(handler));
+
+  v = pic_apply1(pic, handler, err);
+
+  *pic->xp++ = handler;
+
+  return v;
+}
+
+noreturn void
+pic_raise(pic_state *pic, pic_value err)
+{
+  pic_value val;
+
+  val = pic_raise_continuable(pic, err);
+
+  pic_pop_try(pic);
+
+  pic_errorf(pic, "error handler returned with ~s on error ~s", val, err);
+}
+
+noreturn void
+pic_throw(pic_state *pic, pic_sym type, const char *msg, pic_value irrs)
+{
+  struct pic_error *e;
+
+  e = pic_make_error(pic, type, msg, irrs);
+
+  pic_raise(pic, pic_obj_value(e));
+}
+
+noreturn void
+pic_error(pic_state *pic, const char *msg, pic_value irrs)
+{
+  pic_throw(pic, pic_intern_cstr(pic, ""), msg, irrs);
+}
+
+static pic_value
+pic_error_with_exception_handler(pic_state *pic)
+{
+  struct pic_proc *handler, *thunk;
+  pic_value val;
+  size_t xp_len;
+  ptrdiff_t xp_offset;
+
+  pic_get_args(pic, "ll", &handler, &thunk);
+
+  if (pic->xp >= pic->xpend) {
+    xp_len = (size_t)(pic->xpend - pic->xpbase) * 2;
+    xp_offset = pic->xp - pic->xpbase;
+    pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len);
+    pic->xp = pic->xpbase + xp_offset;
+    pic->xpend = pic->xpbase + xp_len;
+  }
+
+  *pic->xp++ = handler;
+
+  val = pic_apply0(pic, thunk);
+
+  --pic->xp;
+
+  return val;
+}
+
+noreturn static pic_value
+pic_error_raise(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  pic_raise(pic, v);
+}
+
+static pic_value
+pic_error_raise_continuable(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_raise_continuable(pic, 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_error(pic, str, pic_list_by_array(pic, argc, argv));
+}
+
+static pic_value
+pic_error_make_error_object(pic_state *pic)
+{
+  struct pic_error *e;
+  pic_sym type;
+  pic_str *msg;
+  size_t argc;
+  pic_value *argv;
+
+  pic_get_args(pic, "ms*", &type, &msg, &argc, &argv);
+
+  e = pic_make_error(pic, type, pic_str_cstr(msg), pic_list_by_array(pic, argc, argv));
+
+  return pic_obj_value(e);
+}
+
+static pic_value
+pic_error_error_object_p(pic_state *pic)
+{
+  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_error_object_type(pic_state *pic)
+{
+  struct pic_error *e;
+
+  pic_get_args(pic, "e", &e);
+
+  return pic_sym_value(e->type);
+}
+
+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, "make-error-object", pic_error_make_error_object);
+  pic_defun(pic, "error-object?", pic_error_error_object_p);
+  pic_defun(pic, "error-object-message", pic_error_error_object_message);
+  pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants);
+  pic_defun(pic, "error-object-type", pic_error_error_object_type);
+}

extlib/benz/eval.c

@@ -0,0 +1,37 @@
+/**
+ * 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_defun(pic, "eval", pic_eval_eval);
+}

extlib/benz/file.c

@@ -0,0 +1,117 @@
+/**
+ * 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->sFILE, 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_binary_input_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_binary_output_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_defun(pic, "open-input-file", pic_file_open_input_file);
+  pic_defun(pic, "open-binary-input-file", pic_file_open_binary_input_file);
+  pic_defun(pic, "open-output-file", pic_file_open_output_file);
+  pic_defun(pic, "open-binary-output-file", pic_file_open_binary_output_file);
+  pic_defun(pic, "file-exists?", pic_file_exists_p);
+  pic_defun(pic, "delete-file", pic_file_delete);
+}

extlib/benz/gc.c

@@ -0,0 +1,853 @@
+/**
+ * See Copyright Notice in picrin.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/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_panic(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_panic(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_panic(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 bool
+gc_obj_is_marked(struct pic_object *obj)
+{
+  union header *p;
+
+  p = ((union header *)obj) - 1;
+
+  return gc_is_marked(p);
+}
+
+static void
+gc_unmark(union header *p)
+{
+  p->s.mark = PIC_GC_UNMARK;
+}
+
+static void
+gc_mark_winder(pic_state *pic, struct pic_winder *wind)
+{
+  if (wind->prev) {
+    gc_mark_object(pic, (struct pic_object *)wind->prev);
+  }
+  if (wind->in) {
+    gc_mark_object(pic, (struct pic_object *)wind->in);
+  }
+  if (wind->out) {
+    gc_mark_object(pic, (struct pic_object *)wind->out);
+  }
+}
+
+static void
+gc_mark_object(pic_state *pic, struct pic_object *obj)
+{
+  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 (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_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);
+    }
+    gc_mark(pic, senv->defer);
+    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_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_entry *it;
+
+    for (it = xh_begin(&data->storage); it != NULL; it = xh_next(it)) {
+      gc_mark(pic, xh_val(it, pic_value));
+    }
+    if (data->type->mark) {
+      data->type->mark(pic, data->data, gc_mark);
+    }
+    break;
+  }
+  case PIC_TT_DICT: {
+    struct pic_dict *dict = (struct pic_dict *)obj;
+    xh_entry *it;
+
+    for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
+      gc_mark(pic, xh_key(it, pic_value));
+      gc_mark(pic, xh_val(it, pic_value));
+    }
+    break;
+  }
+  case PIC_TT_RECORD: {
+    struct pic_record *rec = (struct pic_record *)obj;
+    xh_entry *it;
+
+    for (it = xh_begin(&rec->hash); it != NULL; it = xh_next(it)) {
+      gc_mark(pic, xh_val(it, pic_value));
+    }
+    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_panic(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;
+  struct pic_proc **xhandler;
+  size_t j;
+  xh_entry *it;
+  struct pic_object *obj;
+
+  /* winder */
+  if (pic->wind) {
+    gc_mark_winder(pic, pic->wind);
+  }
+
+  /* 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);
+    }
+  }
+
+  /* exception handlers */
+  for (xhandler = pic->xpbase; xhandler != pic->xp; ++xhandler) {
+    gc_mark_object(pic, (struct pic_object *)*xhandler);
+  }
+
+  /* arena */
+  for (j = 0; j < pic->arena_idx; ++j) {
+    gc_mark_object(pic, pic->arena[j]);
+  }
+
+  /* global variables */
+  for (it = xh_begin(&pic->globals); it != NULL; it = xh_next(it)) {
+    gc_mark(pic, xh_val(it, pic_value));
+  }
+
+  /* macro objects */
+  for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) {
+    gc_mark_object(pic, xh_val(it, struct pic_object *));
+  }
+
+  /* error object */
+  gc_mark(pic, pic->err);
+
+  /* features */
+  gc_mark(pic, pic->features);
+
+  /* readers */
+  gc_mark_trie(pic, pic->reader->trie);
+
+  /* library table */
+  gc_mark(pic, pic->libs);
+
+  /* standard I/O ports */
+  if (pic->xSTDIN) {
+    gc_mark_object(pic, (struct pic_object *)pic->xSTDIN);
+  }
+  if (pic->xSTDOUT) {
+    gc_mark_object(pic, (struct pic_object *)pic->xSTDOUT);
+  }
+  if (pic->xSTDERR) {
+    gc_mark_object(pic, (struct pic_object *)pic->xSTDERR);
+  }
+
+  /* attributes */
+  do {
+    j = 0;
+
+    for (it = xh_begin(&pic->attrs); it != NULL; it = xh_next(it)) {
+      if (gc_obj_is_marked(xh_key(it, struct pic_object *))) {
+        obj = (struct pic_object *)xh_val(it, struct pic_dict *);
+        if (! gc_obj_is_marked(obj)) {
+          gc_mark_object(pic, obj);
+          ++j;
+        }
+      }
+    }
+  } while (j > 0);
+}
+
+static void
+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_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_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_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_panic(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 = NIL;
+
+#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;
+  xh_entry *it, *next;
+
+  do {
+    for (it = xh_begin(&pic->attrs); it != NULL; it = next) {
+      next = xh_next(it);
+      if (! gc_obj_is_marked(xh_key(it, struct pic_object *))) {
+        xh_del_ptr(&pic->attrs, xh_key(it, struct pic_object *));
+      }
+    }
+  } while (it != NULL);
+
+  while (page) {
+    gc_sweep_page(pic, page);
+    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_panic(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;
+}

extlib/benz/include/picrin.h

@@ -0,0 +1,249 @@
+/**
+ * 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 <stdint.h>
+#include <limits.h>
+#include <assert.h>
+
+#include "picrin/xvect.h"
+#include "picrin/xhash.h"
+#include "picrin/xfile.h"
+#include "picrin/xrope.h"
+
+#include "picrin/config.h"
+#include "picrin/util.h"
+#include "picrin/value.h"
+
+typedef struct pic_code pic_code;
+
+struct pic_winder {
+  struct pic_proc *in;
+  struct pic_proc *out;
+  int depth;
+  struct pic_winder *prev;
+};
+
+typedef struct {
+  int argc, retc;
+  pic_code *ip;
+  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_winder *wind;
+
+  pic_value *sp;
+  pic_value *stbase, *stend;
+
+  pic_callinfo *ci;
+  pic_callinfo *cibase, *ciend;
+
+  struct pic_proc **xp;
+  struct pic_proc **xpbase, **xpend;
+
+  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 sCOND_EXPAND, sAND, sOR, sELSE, sLIBRARY;
+  pic_sym sONLY, sRENAME, sPREFIX, sEXCEPT;
+  pic_sym sCONS, sCAR, sCDR, sNILP;
+  pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
+  pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
+  pic_sym sREAD, sFILE;
+
+  pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
+  pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT;
+  pic_sym rDEFINE_LIBRARY, rIN_LIBRARY;
+  pic_sym rCOND_EXPAND;
+
+  struct pic_lib *PICRIN_BASE;
+  struct pic_lib *PICRIN_USER;
+
+  pic_value features;
+
+  xhash syms;                   /* name to symbol */
+  xhash sym_names;              /* symbol to name */
+  int sym_cnt;
+  int uniq_sym_cnt;
+
+  xhash globals;
+  xhash macros;
+  pic_value libs;
+  xhash attrs;
+
+  struct pic_reader *reader;
+
+  struct pic_heap *heap;
+  struct pic_object **arena;
+  size_t arena_size, arena_idx;
+
+  struct pic_port *xSTDIN, *xSTDOUT, *xSTDERR;
+
+  pic_value err;
+
+  char *native_stack_start;
+} pic_state;
+
+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_add_feature(pic_state *, const char *);
+
+void pic_define(pic_state *, const char *, pic_value);
+void pic_define_noexport(pic_state *, const char *, pic_value);
+void pic_defun(pic_state *, const char *, pic_func_t);
+
+struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *);
+void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *);
+
+struct pic_proc *pic_get_proc(pic_state *);
+int pic_get_args(pic_state *, const char *, ...);
+
+bool pic_eq_p(pic_value, pic_value);
+bool pic_eqv_p(pic_value, pic_value);
+bool pic_equal_p(pic_state *, pic_value, pic_value);
+
+pic_sym pic_intern(pic_state *, const char *, size_t);
+pic_sym pic_intern_str(pic_state *, pic_str *);
+pic_sym pic_intern_cstr(pic_state *, const char *);
+const char *pic_symbol_name(pic_state *, pic_sym);
+pic_sym pic_gensym(pic_state *, pic_sym);
+pic_sym pic_ungensym(pic_state *, pic_sym);
+bool pic_interned_p(pic_state *, pic_sym);
+
+pic_value pic_read(pic_state *, struct pic_port *);
+pic_value pic_read_cstr(pic_state *, const char *);
+
+void pic_load(pic_state *, const char *);
+void pic_load_cstr(pic_state *, const char *);
+
+pic_value pic_funcall(pic_state *pic, struct pic_lib *, const char *, pic_list);
+pic_value pic_ref(pic_state *, struct pic_lib *, const char *);
+void pic_set(pic_state *, struct pic_lib *, const char *, pic_value);
+
+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_open_library(pic_state *, pic_value);
+struct pic_lib *pic_find_library(pic_state *, pic_value);
+
+#define pic_deflibrary(pic, spec)                                       \
+  pic_deflibrary_helper_(pic, GENSYM(i), GENSYM(prev_lib), spec)
+#define pic_deflibrary_helper_(pic, i, prev_lib, spec)                  \
+  for (int i = 0; ! i; )                                                \
+    for (struct pic_lib *prev_lib; ! i; )                               \
+      for ((prev_lib = pic->lib), pic_open_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib)
+
+void pic_import(pic_state *, pic_value);
+void pic_import_library(pic_state *, struct pic_lib *);
+void pic_export(pic_state *, pic_sym);
+
+noreturn void pic_panic(pic_state *, const char *);
+noreturn void pic_errorf(pic_state *, const char *, ...);
+void pic_warnf(pic_state *, const char *, ...);
+const char *pic_errmsg(pic_state *);
+pic_str *pic_get_backtrace(pic_state *);
+void pic_print_backtrace(pic_state *);
+
+/* obsoleted */
+static inline void pic_warn(pic_state *pic, const char *msg)
+{
+  pic_warnf(pic, msg);
+}
+
+struct pic_dict *pic_attr(pic_state *, pic_value);
+pic_value pic_attr_ref(pic_state *, pic_value, const char *);
+void pic_attr_set(pic_state *, pic_value, const char *, pic_value);
+
+struct pic_port *pic_stdin(pic_state *);
+struct pic_port *pic_stdout(pic_state *);
+struct pic_port *pic_stderr(pic_state *);
+
+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

extlib/benz/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
+  unsigned 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_make_blob(pic_state *, size_t);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/config.h

@@ -0,0 +1,97 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+/** switch normal VM and direct threaded VM */
+/* #define PIC_DIRECT_THREADED_VM 1 */
+
+/** switch internal value representation */
+/* #define PIC_NAN_BOXING 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_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_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

extlib/benz/include/picrin/cont.h

@@ -0,0 +1,53 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#ifndef PICRIN_CONT_H
+#define PICRIN_CONT_H
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+struct pic_escape {
+  jmp_buf jmp;
+
+  bool valid;
+
+  struct pic_winder *wind;
+
+  ptrdiff_t sp_offset;
+  ptrdiff_t ci_offset;
+  ptrdiff_t xp_offset;
+  size_t arena_idx;
+
+  pic_code *ip;
+
+  pic_value results;
+};
+
+void pic_save_point(pic_state *, struct pic_escape *);
+void pic_load_point(pic_state *, struct pic_escape *);
+
+struct pic_proc *pic_make_econt(pic_state *, struct pic_escape *);
+
+void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *);
+pic_value pic_dynamic_wind(pic_state *, struct pic_proc *, struct pic_proc *, struct pic_proc *);
+
+pic_value pic_values0(pic_state *);
+pic_value pic_values1(pic_state *, pic_value);
+pic_value pic_values2(pic_state *, pic_value, pic_value);
+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_escape(pic_state *, struct pic_proc *);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/data.h

@@ -0,0 +1,38 @@
+/**
+ * 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 *);
+  void (*mark)(pic_state *, void *, void (*)(pic_state *, pic_value));
+} 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

extlib/benz/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_make_dict(pic_state *);
+
+pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_value);
+void pic_dict_set(pic_state *, struct pic_dict *, pic_value, pic_value);
+void pic_dict_del(pic_state *, struct pic_dict *, pic_value);
+size_t pic_dict_size(pic_state *, struct pic_dict *);
+bool pic_dict_has(pic_state *, struct pic_dict *, pic_value);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/error.h

@@ -0,0 +1,54 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#ifndef PICRIN_ERROR_H
+#define PICRIN_ERROR_H
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+#include "picrin/cont.h"
+
+struct pic_error {
+  PIC_OBJECT_HEADER
+  pic_sym type;
+  pic_str *msg;
+  pic_value irrs;
+  pic_str *stack;
+};
+
+#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR)
+#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v))
+
+struct pic_error *pic_make_error(pic_state *, pic_sym, const char *, pic_list);
+
+/* do not return from try block! */
+
+#define pic_try                                 \
+  pic_try_(GENSYM(escape))
+#define pic_try_(escape)                                                \
+  struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape)); \
+  pic_save_point(pic, escape);                                          \
+  if (setjmp(escape->jmp) == 0) {                                       \
+    pic_push_try(pic, escape);                                          \
+    do
+#define pic_catch                                         \
+    while (0);                                            \
+    pic_pop_try(pic);                                     \
+  } else
+
+void pic_push_try(pic_state *, struct pic_escape *);
+void pic_pop_try(pic_state *);
+
+pic_value pic_raise_continuable(pic_state *, pic_value);
+noreturn void pic_raise(pic_state *, pic_value);
+noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list);
+noreturn void pic_error(pic_state *, const char *, pic_list);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/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

extlib/benz/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 {
+      int depth;
+      int 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

extlib/benz/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

extlib/benz/include/picrin/macro.h

@@ -0,0 +1,48 @@
+/**
+ * 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;
+  pic_value defer;
+  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_make_senv(pic_state *, struct pic_senv *);
+
+pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym);
+bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */);
+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

extlib/benz/include/picrin/pair.h

@@ -0,0 +1,100 @@
+/**
+ * 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))
+
+static inline pic_value
+pic_car(pic_state *pic, pic_value obj)
+{
+  struct pic_pair *pair;
+
+  if (! pic_pair_p(obj)) {
+    pic_errorf(pic, "pair required, but got ~s", obj);
+  }
+  pair = pic_pair_ptr(obj);
+
+  return pair->car;
+}
+
+static inline pic_value
+pic_cdr(pic_state *pic, pic_value obj)
+{
+  struct pic_pair *pair;
+
+  if (! pic_pair_p(obj)) {
+    pic_errorf(pic, "pair required, but got ~s", obj);
+  }
+  pair = pic_pair_ptr(obj);
+
+  return pair->cdr;
+}
+
+pic_value pic_cons(pic_state *, pic_value, pic_value);
+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 *, size_t, 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))
+
+size_t pic_length(pic_state *, pic_value);
+pic_value pic_reverse(pic_state *, pic_value);
+pic_value pic_append(pic_state *, pic_value, pic_value);
+
+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, size_t);
+pic_value pic_list_ref(pic_state *, pic_value, size_t);
+void pic_list_set(pic_state *, pic_value, size_t, pic_value);
+pic_value pic_list_copy(pic_state *, pic_value);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/port.h

@@ -0,0 +1,46 @@
+/**
+ * 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_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

extlib/benz/include/picrin/proc.h

@@ -0,0 +1,57 @@
+/**
+ * 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;
+};
+
+#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_make_proc(pic_state *, pic_func_t, const char *);
+struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_env *);
+
+pic_sym pic_proc_name(struct pic_proc *);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/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_make_trie(pic_state *);
+void pic_trie_delete(pic_state *, struct pic_trie *);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/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_make_record(pic_state *, pic_value);
+
+pic_value pic_record_type(pic_state *, struct pic_record *);
+pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym);
+void pic_record_set(pic_state *, struct pic_record *, pic_sym, pic_value);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/string.h

@@ -0,0 +1,45 @@
+/**
+ * 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_make_str(pic_state *, const char * /* nullable */, size_t);
+pic_str *pic_make_str_cstr(pic_state *, const char *);
+pic_str *pic_make_str_fill(pic_state *, size_t, char);
+
+size_t pic_strlen(pic_str *);
+char pic_str_ref(pic_state *, pic_str *, size_t);
+
+pic_str *pic_strcat(pic_state *, pic_str *, pic_str *);
+pic_str *pic_substr(pic_state *, pic_str *, size_t, size_t);
+int pic_strcmp(pic_str *, pic_str *);
+
+const char *pic_str_cstr(pic_str *);
+
+pic_str *pic_format(pic_state *, const char *, ...);
+pic_str *pic_vformat(pic_state *, const char *, va_list);
+void pic_vfformat(pic_state *, xFILE *, const char *, va_list);
+
+pic_value pic_xformat(pic_state *, const char *, ...);
+pic_value pic_xvformat(pic_state *, const char *, va_list);
+pic_value pic_xvfformat(pic_state *, xFILE *, const char *, va_list);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/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

extlib/benz/include/picrin/value.h

@@ -0,0 +1,534 @@
+/**
+ * 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 of 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 CCCCCCCCCCCCCCCC
+ */
+
+typedef uint64_t pic_value;
+
+#define pic_ptr(v) ((void *)(0xfffffffffffful & (v)))
+#define pic_init_value(v,vtype) (v = (0xfff0000000000000ul | ((uint64_t)(vtype) << 48)))
+
+static inline enum pic_vtype
+pic_vtype(pic_value v)
+{
+  return 0xfff0 >= (v >> 48) ? PIC_VTYPE_FLOAT : ((v >> 48) & 0xf);
+}
+
+static inline double
+pic_float(pic_value v)
+{
+  union { double f; uint64_t i; } u;
+  u.i = v;
+  return u.f;
+}
+
+static inline int
+pic_int(pic_value v)
+{
+  union { int i; unsigned u; } u;
+  u.u = v & 0xfffffffful;
+  return u.i;
+}
+
+static inline int
+pic_sym(pic_value v)
+{
+  union { int i; unsigned u; } u;
+  u.u = v & 0xfffffffful;
+  return u.i;
+}
+
+#define pic_char(v) ((v) & 0xfffffffful)
+
+#else
+
+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)
+
+#define pic_float(v) ((v).u.f)
+#define pic_int(v) ((v).u.i)
+#define pic_sym(v) ((v).u.sym)
+#define pic_char(v) ((v).u.c)
+
+#endif
+
+enum pic_tt {
+  /* 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_SENV,
+  PIC_TT_MACRO,
+  PIC_TT_LIB,
+  PIC_TT_IREP,
+  PIC_TT_DATA,
+  PIC_TT_DICT,
+  PIC_TT_RECORD,
+};
+
+#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;
+struct pic_error;
+
+/* 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_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_size_value(size_t);
+static inline pic_value pic_sym_value(pic_sym);
+static inline pic_value pic_char_value(char c);
+static inline pic_value pic_none_value();
+
+#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;
+  }
+
+  UNREACHABLE();
+}
+
+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_PROC:
+    return "proc";
+  case PIC_TT_SENV:
+    return "senv";
+  case PIC_TT_MACRO:
+    return "macro";
+  case PIC_TT_LIB:
+    return "lib";
+  case PIC_TT_IREP:
+    return "irep";
+  case PIC_TT_DATA:
+    return "data";
+  case PIC_TT_DICT:
+    return "dict";
+  case PIC_TT_RECORD:
+    return "record";
+  }
+  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;
+}
+
+static inline pic_value
+pic_size_value(size_t s)
+{
+  if (sizeof(unsigned) < sizeof(size_t)) {
+    if (s > (size_t)INT_MAX) {
+      return pic_float_value(s);
+    }
+  }
+  return pic_int_value((int)s);
+}
+
+#if PIC_NAN_BOXING
+
+static inline pic_value
+pic_obj_value(void *ptr)
+{
+  pic_value v;
+
+  pic_init_value(v, PIC_VTYPE_HEAP);
+  v |= 0xfffffffffffful & (uint64_t)ptr;
+  return v;
+}
+
+static inline pic_value
+pic_float_value(double f)
+{
+  union { double f; uint64_t i; } u;
+
+  if (f != f) {
+    return 0x7ff8000000000000ul;
+  } else {
+    u.f = f;
+    return u.i;
+  }
+}
+
+static inline pic_value
+pic_int_value(int i)
+{
+  union { int i; unsigned u; } u;
+  pic_value v;
+
+  u.i = i;
+
+  pic_init_value(v, PIC_VTYPE_INT);
+  v |= u.u;
+  return v;
+}
+
+static inline pic_value
+pic_symbol_value(pic_sym sym)
+{
+  union { int i; unsigned u; } u;
+  pic_value v;
+
+  u.i = sym;
+
+  pic_init_value(v, PIC_VTYPE_SYMBOL);
+  v |= u.u;
+  return v;
+}
+
+static inline pic_value
+pic_char_value(char c)
+{
+  pic_value v;
+
+  pic_init_value(v, PIC_VTYPE_CHAR);
+  v |= c;
+  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;
+}
+
+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;
+}
+
+#endif
+
+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 == y;
+}
+
+static inline bool
+pic_eqv_p(pic_value x, pic_value y)
+{
+  return x == y;
+}
+
+#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

extlib/benz/include/picrin/vector.h

@@ -0,0 +1,28 @@
+/**
+ * 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_make_vec(pic_state *, size_t);
+struct pic_vector *pic_make_vec_from_list(pic_state *, pic_value);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/xfile.h

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

extlib/benz/include/picrin/xhash.h

@@ -0,0 +1,427 @@
+#ifndef XHASH_H
+#define XHASH_H
+
+/*
+ * Copyright (c) 2013-2014 by Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
+ */
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+#include <stddef.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdint.h>
+#include <assert.h>
+
+/* simple object to object hash table */
+
+#define XHASH_INIT_SIZE 11
+#define XHASH_RESIZE_RATIO 0.75
+
+#define XHASH_ALIGNMENT 3       /* quad word alignment */
+#define XHASH_MASK (~(size_t)((1 << XHASH_ALIGNMENT) - 1))
+#define XHASH_ALIGN(i) ((((i) - 1) & XHASH_MASK) + (1 << XHASH_ALIGNMENT))
+
+typedef struct xh_entry {
+  struct xh_entry *next;
+  int hash;
+  struct xh_entry *fw, *bw;
+  const void *key;
+  void *val;
+} xh_entry;
+
+#define xh_key(e,type) (*(type *)((e)->key))
+#define xh_val(e,type) (*(type *)((e)->val))
+
+typedef int (*xh_hashf)(const void *, void *);
+typedef int (*xh_equalf)(const void *, const void *, void *);
+
+typedef struct xhash {
+  xh_entry **buckets;
+  size_t size, count, kwidth, vwidth;
+  size_t koffset, voffset;
+  xh_hashf hashf;
+  xh_equalf equalf;
+  xh_entry *head, *tail;
+  void *data;
+} xhash;
+
+/** Protected Methods:
+ * static inline void xh_init_(xhash *x, size_t, size_t, xh_hashf, xh_equalf, void *);
+ * static inline xh_entry *xh_get_(xhash *x, const void *key);
+ * static inline xh_entry *xh_put_(xhash *x, const void *key, void *val);
+ * static inline void xh_del_(xhash *x, const void *key);
+ */
+
+/* string map */
+static inline void xh_init_str(xhash *x, size_t width);
+static inline xh_entry *xh_get_str(xhash *x, const char *key);
+static inline xh_entry *xh_put_str(xhash *x, const char *key, void *);
+static inline void xh_del_str(xhash *x, const char *key);
+
+/* object map */
+static inline void xh_init_ptr(xhash *x, size_t width);
+static inline xh_entry *xh_get_ptr(xhash *x, const void *key);
+static inline xh_entry *xh_put_ptr(xhash *x, const void *key, void *);
+static inline void xh_del_ptr(xhash *x, const void *key);
+
+/* int map */
+static inline void xh_init_int(xhash *x, size_t width);
+static inline xh_entry *xh_get_int(xhash *x, int key);
+static inline xh_entry *xh_put_int(xhash *x, int key, void *);
+static inline void xh_del_int(xhash *x, int key);
+
+static inline size_t xh_size(xhash *x);
+static inline void xh_clear(xhash *x);
+static inline void xh_destroy(xhash *x);
+
+static inline xh_entry *xh_begin(xhash *x);
+static inline xh_entry *xh_next(xh_entry *e);
+
+
+static inline void
+xh_bucket_realloc(xhash *x, size_t newsize)
+{
+  x->size = newsize;
+  x->buckets = realloc(x->buckets, (x->size + 1) * sizeof(xh_entry *));
+  memset(x->buckets, 0, (x->size + 1) * sizeof(xh_entry *));
+}
+
+static inline void
+xh_init_(xhash *x, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equalf, void *data)
+{
+  x->size = 0;
+  x->buckets = NULL;
+  x->count = 0;
+  x->kwidth = kwidth;
+  x->vwidth = vwidth;
+  x->koffset = XHASH_ALIGN(sizeof(xh_entry));
+  x->voffset = XHASH_ALIGN(sizeof(xh_entry)) + XHASH_ALIGN(kwidth);
+  x->hashf = hashf;
+  x->equalf = equalf;
+  x->head = NULL;
+  x->tail = NULL;
+  x->data = data;
+
+  xh_bucket_realloc(x, XHASH_INIT_SIZE);
+}
+
+static inline xh_entry *
+xh_get_(xhash *x, const void *key)
+{
+  int hash;
+  size_t idx;
+  xh_entry *e;
+
+  hash = x->hashf(key, x->data);
+  idx = ((unsigned)hash) % x->size;
+  for (e = x->buckets[idx]; e; e = e->next) {
+    if (e->hash == hash && x->equalf(key, e->key, x->data))
+      break;
+  }
+  return e;
+}
+
+static inline void
+xh_resize_(xhash *x, size_t newsize)
+{
+  xhash y;
+  xh_entry *it;
+  size_t idx;
+
+  xh_init_(&y, x->kwidth, x->vwidth, x->hashf, x->equalf, x->data);
+  xh_bucket_realloc(&y, newsize);
+
+  for (it = xh_begin(x); it != NULL; it = xh_next(it)) {
+    idx = ((unsigned)it->hash) % y.size;
+    /* reuse entry object */
+    it->next = y.buckets[idx];
+    y.buckets[idx] = it;
+    y.count++;
+  }
+
+  y.head = x->head;
+  y.tail = x->tail;
+
+  free(x->buckets);
+
+  /* copy all members from y to x */
+  memcpy(x, &y, sizeof(xhash));
+}
+
+static inline xh_entry *
+xh_put_(xhash *x, const void *key, void *val)
+{
+  int hash;
+  size_t idx;
+  xh_entry *e;
+
+  if ((e = xh_get_(x, key))) {
+    memcpy(e->val, val, x->vwidth);
+    return e;
+  }
+
+  if (x->count + 1 > x->size * XHASH_RESIZE_RATIO) {
+    xh_resize_(x, x->size * 2 + 1);
+  }
+
+  hash = x->hashf(key, x->data);
+  idx = ((unsigned)hash) % x->size;
+  e = malloc(x->voffset + x->vwidth);
+  e->next = x->buckets[idx];
+  e->hash = hash;
+  e->key = ((char *)e) + x->koffset;
+  e->val = ((char *)e) + x->voffset;
+  memcpy((void *)e->key, key, x->kwidth);
+  memcpy(e->val, val, x->vwidth);
+
+  if (x->head == NULL) {
+    x->head = x->tail = e;
+    e->fw = e->bw = NULL;
+  } else {
+    x->tail->bw = e;
+    e->fw = x->tail;
+    e->bw = NULL;
+    x->tail = e;
+  }
+
+  x->count++;
+
+  return x->buckets[idx] = e;
+}
+
+static inline void
+xh_del_(xhash *x, const void *key)
+{
+  int hash;
+  size_t idx;
+  xh_entry *p, *q, *r;
+
+  hash = x->hashf(key, x->data);
+  idx = ((unsigned)hash) % x->size;
+  if (x->buckets[idx]->hash == hash && x->equalf(key, x->buckets[idx]->key, x->data)) {
+    q = x->buckets[idx];
+    if (q->fw == NULL) {
+      x->head = q->bw;
+    } else {
+      q->fw->bw = q->bw;
+    }
+    if (q->bw == NULL) {
+      x->tail = q->fw;
+    } else {
+      q->bw->fw = q->fw;
+    }
+    r = q->next;
+    free(q);
+    x->buckets[idx] = r;
+  }
+  else {
+    for (p = x->buckets[idx]; ; p = p->next) {
+      if (p->next->hash == hash && x->equalf(key, p->next->key, x->data))
+        break;
+    }
+    q = p->next;
+    if (q->fw == NULL) {
+      x->head = q->bw;
+    } else {
+      q->fw->bw = q->bw;
+    }
+    if (q->bw == NULL) {
+      x->tail = q->fw;
+    } else {
+      q->bw->fw = q->fw;
+    }
+    r = q->next;
+    free(q);
+    p->next = r;
+  }
+
+  x->count--;
+}
+
+static inline size_t
+xh_size(xhash *x)
+{
+  return x->count;
+}
+
+static inline void
+xh_clear(xhash *x)
+{
+  size_t i;
+  xh_entry *e, *d;
+
+  for (i = 0; i < x->size; ++i) {
+    e = x->buckets[i];
+    while (e) {
+      d = e->next;
+      free(e);
+      e = d;
+    }
+    x->buckets[i] = NULL;
+  }
+
+  x->head = x->tail = NULL;
+  x->count = 0;
+}
+
+static inline void
+xh_destroy(xhash *x)
+{
+  xh_clear(x);
+  free(x->buckets);
+}
+
+/* string map */
+
+static inline int
+xh_str_hash(const void *key, void *data)
+{
+  const char *str = *(const char **)key;
+  int hash = 0;
+
+  (void)data;
+
+  while (*str) {
+    hash = hash * 31 + *str++;
+  }
+  return hash;
+}
+
+static inline int
+xh_str_equal(const void *key1, const void *key2, void *data)
+{
+  (void)data;
+
+  return strcmp(*(const char **)key1, *(const char **)key2) == 0;
+}
+
+static inline void
+xh_init_str(xhash *x, size_t width)
+{
+  xh_init_(x, sizeof(const char *), width, xh_str_hash, xh_str_equal, NULL);
+}
+
+static inline xh_entry *
+xh_get_str(xhash *x, const char *key)
+{
+  return xh_get_(x, &key);
+}
+
+static inline xh_entry *
+xh_put_str(xhash *x, const char *key, void *val)
+{
+  return xh_put_(x, &key, val);
+}
+
+static inline void
+xh_del_str(xhash *x, const char *key)
+{
+  xh_del_(x, &key);
+}
+
+/* object map */
+
+static inline int
+xh_ptr_hash(const void *key, void *data)
+{
+  (void)data;
+
+  return (int)(size_t)*(const void **)key;
+}
+
+static inline int
+xh_ptr_equal(const void *key1, const void *key2, void *data)
+{
+  (void) data;
+
+  return *(const void **)key1 == *(const void **)key2;
+}
+
+static inline void
+xh_init_ptr(xhash *x, size_t width)
+{
+  xh_init_(x, sizeof(const void *), width, xh_ptr_hash, xh_ptr_equal, NULL);
+}
+
+static inline xh_entry *
+xh_get_ptr(xhash *x, const void *key)
+{
+  return xh_get_(x, &key);
+}
+
+static inline xh_entry *
+xh_put_ptr(xhash *x, const void *key, void *val)
+{
+  return xh_put_(x, &key, val);
+}
+
+static inline void
+xh_del_ptr(xhash *x, const void *key)
+{
+  xh_del_(x, &key);
+}
+
+/* int map */
+
+static inline int
+xh_int_hash(const void *key, void *data)
+{
+  (void)data;
+
+  return *(int *)key;
+}
+
+static inline int
+xh_int_equal(const void *key1, const void *key2, void *data)
+{
+  (void)data;
+
+  return *(int *)key1 == *(int *)key2;
+}
+
+static inline void
+xh_init_int(xhash *x, size_t width)
+{
+  xh_init_(x, sizeof(int), width, xh_int_hash, xh_int_equal, NULL);
+}
+
+static inline xh_entry *
+xh_get_int(xhash *x, int key)
+{
+  return xh_get_(x, &key);
+}
+
+static inline xh_entry *
+xh_put_int(xhash *x, int key, void *val)
+{
+  return xh_put_(x, &key, val);
+}
+
+static inline void
+xh_del_int(xhash *x, int key)
+{
+  xh_del_(x, &key);
+}
+
+/** iteration */
+
+static inline xh_entry *
+xh_begin(xhash *x)
+{
+  return x->head;
+}
+
+static inline xh_entry *
+xh_next(xh_entry *e)
+{
+  return e->bw;
+}
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/xrope.h

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

extlib/benz/include/picrin/xvect.h

@@ -0,0 +1,207 @@
+#ifndef XVECT_H__
+#define XVECT_H__
+
+/*
+ * Copyright (c) 2014 by Yuichi Nishiwaki <yuichi@idylls.jp>
+ */
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+#include <stddef.h>
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+
+typedef struct xvect {
+  char *data;
+  size_t size, mask, head, tail, width;
+} xvect;
+
+static inline void xv_init(xvect *, size_t);
+static inline void xv_destroy(xvect *);
+
+static inline size_t xv_size(xvect *);
+
+static inline void xv_reserve(xvect *, size_t);
+static inline void xv_shrink(xvect *, size_t);
+
+static inline void *xv_get(xvect *, size_t);
+static inline void xv_set(xvect *, size_t, void *);
+
+static inline void xv_push(xvect *, void *);
+static inline void *xv_pop(xvect *);
+
+static inline void *xv_shift(xvect *);
+static inline void xv_unshift(xvect *, void *);
+
+static inline void xv_splice(xvect *, size_t, size_t);
+static inline void xv_insert(xvect *, size_t, void *);
+
+static inline void
+xv_init(xvect *x, size_t width)
+{
+  x->data = NULL;
+  x->width = width;
+  x->size = 0;
+  x->mask = (size_t)-1;
+  x->head = 0;
+  x->tail = 0;
+}
+
+static inline void
+xv_destroy(xvect *x)
+{
+  free(x->data);
+}
+
+static inline size_t
+xv_size(xvect *x)
+{
+  return x->tail < x->head
+    ? x->tail + x->size - x->head
+    : x->tail - x->head;
+}
+
+static inline size_t
+xv_round2(size_t x)
+{
+  x -= 1;
+  x |= (x >> 1);
+  x |= (x >> 2);
+  x |= (x >> 4);
+  x |= (x >> 8);
+  x |= (x >> 16);
+  x |= (x >> 32);
+  x++;
+  return x;
+}
+
+static inline void
+xv_rotate(xvect *x)
+{
+  if (x->tail < x->head) {
+    char buf[x->size * x->width];
+
+    /* perform rotation */
+    memcpy(buf, x->data, sizeof buf);
+    memcpy(x->data, buf + x->head * x->width, (x->size - x->head) * x->width);
+    memcpy(x->data + (x->size - x->head) * x->width, buf, x->tail * x->width);
+    x->tail = x->size - x->head + x->tail;
+    x->head = 0;
+  }
+}
+
+static inline void
+xv_adjust(xvect *x, size_t size)
+{
+  size = xv_round2(size);
+  if (size != x->size) {
+    xv_rotate(x);
+    x->data = realloc(x->data, size * x->width);
+    x->size = size;
+    x->mask = size - 1;
+  }
+}
+
+static inline void
+xv_reserve(xvect *x, size_t mincapa)
+{
+  if (x->size < mincapa + 1) {
+    xv_adjust(x, mincapa + 1);  /* capa == size - 1 */
+  }
+}
+
+static inline void
+xv_shrink(xvect *x, size_t maxcapa)
+{
+  if (x->size > maxcapa + 1) {
+    xv_adjust(x, maxcapa + 1);  /* capa == size - 1 */
+  }
+}
+
+static inline void *
+xv_get(xvect *x, size_t i)
+{
+  assert(i < xv_size(x));
+
+  return x->data + ((x->head + i) & x->mask) * x->width;
+}
+
+static inline void
+xv_set(xvect *x, size_t i, void *src)
+{
+  memcpy(xv_get(x, i), src, x->width);
+}
+
+static inline void
+xv_push(xvect *x, void *src)
+{
+  xv_reserve(x, xv_size(x) + 1);
+  x->tail = (x->tail + 1) & x->mask;
+  xv_set(x, xv_size(x) - 1, src);
+}
+
+static inline void *
+xv_pop(xvect *x)
+{
+  void *dat;
+
+  assert(xv_size(x) >= 1);
+
+  dat = xv_get(x, xv_size(x) - 1);
+  x->tail = (x->tail - 1) & x->mask;
+  return dat;
+}
+
+static inline void *
+xv_shift(xvect *x)
+{
+  void *dat;
+
+  assert(xv_size(x) >= 1);
+
+  dat = xv_get(x, 0);
+  x->head = (x->head + 1) & x->mask;
+  return dat;
+}
+
+static inline void
+xv_unshift(xvect *x, void *src)
+{
+  xv_reserve(x, xv_size(x) + 1);
+  x->head = (x->head - 1) & x->mask;
+  xv_set(x, 0, src);
+}
+
+static inline void
+xv_splice(xvect *x, size_t i, size_t j)
+{
+  assert(i <= j && j < xv_size(x));
+
+  xv_rotate(x);
+  memmove(xv_get(x, i), xv_get(x, j), (xv_size(x) - j) * x->width);
+  x->tail = (x->tail - j + i) & x->mask;
+}
+
+static inline void
+xv_insert(xvect *x, size_t i, void *src)
+{
+  assert(i <= xv_size(x));
+
+  xv_reserve(x, xv_size(x) + 1);
+  xv_rotate(x);
+  x->tail = (x->tail + 1) & x->mask;
+
+  if (xv_size(x) - 1 != i) {
+    memmove(xv_get(x, i + 1), xv_get(x, i), (xv_size(x) - 1 - i) * x->width);
+  }
+  xv_set(x, i, src);
+}
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/init.c

@@ -0,0 +1,148 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/pair.h"
+#include "picrin/lib.h"
+#include "picrin/macro.h"
+#include "picrin/error.h"
+
+void
+pic_add_feature(pic_state *pic, const char *feature)
+{
+  pic_push(pic, pic_sym_value(pic_intern_cstr(pic, feature)), pic->features);
+}
+
+void pic_init_bool(pic_state *);
+void pic_init_pair(pic_state *);
+void pic_init_port(pic_state *);
+void pic_init_number(pic_state *);
+void pic_init_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_attr(pic_state *);
+
+extern const char pic_boot[];
+
+static void
+pic_init_features(pic_state *pic)
+{
+  pic_add_feature(pic, "picrin");
+  pic_add_feature(pic, "ieee-float");
+
+#if _POSIX_SOURCE
+  pic_add_feature(pic, "posix");
+#endif
+
+#if _WIN32
+  pic_add_feature(pic, "windows");
+#endif
+
+#if __unix__
+  pic_add_feature(pic, "unix");
+#endif
+#if __gnu_linux__
+  pic_add_feature(pic, "gnu-linux");
+#endif
+#if __FreeBSD__
+  pic_add_feature(pic, "freebsd");
+#endif
+
+#if __i386__
+  pic_add_feature(pic, "i386");
+#elif __x86_64__
+  pic_add_feature(pic, "x86-64");
+#elif __ppc__
+  pic_add_feature(pic, "ppc");
+#elif __sparc__
+  pic_add_feature(pic, "sparc");
+#endif
+
+#if __ILP32__
+  pic_add_feature(pic, "ilp32");
+#elif __LP64__
+  pic_add_feature(pic, "lp64");
+#endif
+
+#if defined(__BYTE_ORDER__)
+# if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
+  pic_add_feature(pic, "little-endian");
+# elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
+  pic_add_feature(pic, "big-endian");
+# endif
+#else
+# if __LITTLE_ENDIAN__
+  pic_add_feature(pic, "little-endian");
+# elif __BIG_ENDIAN__
+  pic_add_feature(pic, "big-endian");
+# endif
+#endif
+}
+
+#define DONE pic_gc_arena_restore(pic, ai);
+
+void
+pic_init_core(pic_state *pic)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+
+  pic_init_features(pic);
+
+  pic_deflibrary (pic, "(picrin base)") {
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
+
+    pic_init_bool(pic); DONE;
+    pic_init_pair(pic); DONE;
+    pic_init_port(pic); DONE;
+    pic_init_number(pic); DONE;
+    pic_init_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_init_attr(pic); DONE;
+
+    pic_load_cstr(pic, pic_boot);
+  }
+
+  pic_import_library(pic, pic->PICRIN_BASE);
+}

extlib/benz/lib.c

@@ -0,0 +1,349 @@
+/**
+ * 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/string.h"
+#include "picrin/proc.h"
+
+struct pic_lib *
+pic_open_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 void
+import_table(pic_state *pic, pic_value spec, xhash *imports)
+{
+  struct pic_lib *lib;
+  xhash table;
+  pic_value val;
+  pic_sym sym, id, tag;
+  xh_entry *it;
+
+  xh_init_int(&table, sizeof(pic_sym));
+
+  if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) {
+
+    tag = pic_sym(pic_car(pic, spec));
+
+    if (tag == pic->sONLY) {
+      import_table(pic, pic_cadr(pic, spec), &table);
+      pic_for_each (val, pic_cddr(pic, spec)) {
+        xh_put_int(imports, pic_sym(val), &xh_val(xh_get_int(&table, pic_sym(val)), pic_sym));
+      }
+      goto exit;
+    }
+    if (tag == pic->sRENAME) {
+      import_table(pic, pic_cadr(pic, spec), imports);
+      pic_for_each (val, pic_cddr(pic, spec)) {
+        id = xh_val(xh_get_int(imports, pic_sym(pic_car(pic, val))), pic_sym);
+        xh_del_int(imports, pic_sym(pic_car(pic, val)));
+        xh_put_int(imports, pic_sym(pic_cadr(pic, val)), &id);
+      }
+      goto exit;
+    }
+    if (tag == pic->sPREFIX) {
+      import_table(pic, pic_cadr(pic, spec), &table);
+      for (it = xh_begin(&table); it != NULL; it = xh_next(it)) {
+        val = pic_list_ref(pic, spec, 2);
+        sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, pic_sym_value(xh_key(it, pic_sym))));
+        xh_put_int(imports, sym, &xh_val(it, pic_sym));
+      }
+      goto exit;
+    }
+    if (tag == pic->sEXCEPT) {
+      import_table(pic, pic_cadr(pic, spec), imports);
+      pic_for_each (val, pic_cddr(pic, spec)) {
+        xh_del_int(imports, pic_sym(val));
+      }
+      goto exit;
+    }
+  }
+  lib = pic_find_library(pic, spec);
+  if (! lib) {
+    pic_errorf(pic, "library not found: ~a", spec);
+  }
+  for (it = xh_begin(&lib->exports); it != NULL; it = xh_next(it)) {
+    xh_put_int(imports, xh_key(it, pic_sym), &xh_val(it, pic_sym));
+  }
+
+ exit:
+  xh_destroy(&table);
+}
+
+static void
+import(pic_state *pic, pic_value spec)
+{
+  xhash imports;
+  xh_entry *it;
+
+  xh_init_int(&imports, sizeof(pic_sym)); /* pic_sym to pic_sym */
+
+  import_table(pic, spec, &imports);
+
+  for (it = xh_begin(&imports); it != NULL; it = xh_next(it)) {
+
+#if DEBUG
+    printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it, pic_sym)), pic_symbol_name(pic, xh_val(it, pic_sym)));
+#endif
+
+    pic_put_rename(pic, pic->lib->env, xh_key(it, pic_sym), xh_val(it, pic_sym));
+  }
+
+  xh_destroy(&imports);
+}
+
+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_import_library(pic_state *pic, struct pic_lib *lib)
+{
+  import(pic, lib->name);
+}
+
+void
+pic_export(pic_state *pic, pic_sym sym)
+{
+  export(pic, pic_sym_value(sym));
+}
+
+static bool
+condexpand(pic_state *pic, pic_value clause)
+{
+  pic_sym tag;
+  pic_value c, feature;
+
+  if (pic_eq_p(clause, pic_sym_value(pic->sELSE))) {
+    return true;
+  }
+  if (pic_sym_p(clause)) {
+    pic_for_each (feature, pic->features) {
+      if(pic_eq_p(feature, clause))
+        return true;
+    }
+    return false;
+  }
+
+  if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) {
+    pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause);
+  } else {
+    tag = pic_sym(pic_car(pic, clause));
+  }
+
+  if (tag == pic->sLIBRARY) {
+    return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL;
+  }
+  if (tag == pic->sNOT) {
+    return ! condexpand(pic, pic_list_ref(pic, clause, 1));
+  }
+  if (tag == pic->sAND) {
+    pic_for_each (c, pic_cdr(pic, clause)) {
+      if (! condexpand(pic, c))
+        return false;
+    }
+    return true;
+  }
+  if (tag == pic->sOR) {
+    pic_for_each (c, pic_cdr(pic, clause)) {
+      if (condexpand(pic, c))
+        return true;
+    }
+    return false;
+  }
+
+  pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause);
+}
+
+static pic_value
+pic_lib_condexpand(pic_state *pic)
+{
+  pic_value *clauses;
+  size_t argc, i;
+
+  pic_get_args(pic, "*", &argc, &clauses);
+
+  for (i = 0; i < argc; i++) {
+    if (condexpand(pic, pic_car(pic, clauses[i]))) {
+      return pic_cons(pic, pic_sym_value(pic->rBEGIN), pic_cdr(pic, clauses[i]));
+    }
+  }
+
+  return pic_none_value();
+}
+
+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_open_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_raise(pic, pic->err);
+  }
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_lib_in_library(pic_state *pic)
+{
+  pic_value spec;
+
+  pic_get_args(pic, "o", &spec);
+
+  pic_in_library(pic, spec);
+
+  return pic_none_value();
+}
+
+void
+pic_init_lib(pic_state *pic)
+{
+  void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t);
+
+  pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand);
+  pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import);
+  pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export);
+  pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library);
+  pic_defmacro(pic, pic->sIN_LIBRARY, pic->rIN_LIBRARY, pic_lib_in_library);
+}

extlib/benz/load.c

@@ -0,0 +1,77 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/pair.h"
+#include "picrin/port.h"
+#include "picrin/error.h"
+
+static void
+pic_load_port(pic_state *pic, struct pic_port *port)
+{
+  pic_value form;
+
+  pic_try {
+    size_t ai = pic_gc_arena_preserve(pic);
+
+    while (! pic_eof_p(form = pic_read(pic, port))) {
+      pic_eval(pic, form, pic->lib);
+
+      pic_gc_arena_restore(pic, ai);
+    }
+  }
+  pic_catch {
+    pic_errorf(pic, "load error: %s", pic_errmsg(pic));
+  }
+}
+
+void
+pic_load_cstr(pic_state *pic, const char *src)
+{
+  struct pic_port *port = pic_open_input_string(pic, src);
+
+  pic_load_port(pic, port);
+
+  pic_close_port(pic, port);
+}
+
+void
+pic_load(pic_state *pic, const char *filename)
+{
+  struct pic_port *port;
+  xFILE *file;
+
+  file = xfopen(filename, "r");
+  if (file == NULL) {
+    pic_errorf(pic, "could not open file: %s", filename);
+  }
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
+  port->file = file;
+  port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
+  port->status = PIC_PORT_OPEN;
+
+  pic_load_port(pic, port);
+
+  pic_close_port(pic, port);
+}
+
+static pic_value
+pic_load_load(pic_state *pic)
+{
+  pic_value envid;
+  char *fn;
+
+  pic_get_args(pic, "z|o", &fn, &envid);
+
+  pic_load(pic, fn);
+
+  return pic_none_value();
+}
+
+void
+pic_init_load(pic_state *pic)
+{
+  pic_defun(pic, "load", pic_load_load);
+}

extlib/benz/macro.c

@@ -0,0 +1,506 @@
+/**
+ * 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_lambda(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_defer(pic_state *pic, pic_value expr, struct pic_senv *senv)
+{
+  pic_value skel = pic_list1(pic, pic_none_value()); /* (#<none>) */
+
+  pic_push(pic, pic_cons(pic, expr, skel), senv->defer);
+
+  return skel;
+}
+
+static void
+macroexpand_deferred(pic_state *pic, struct pic_senv *senv)
+{
+  pic_value defer, val, src, dst;
+
+  pic_for_each (defer, pic_reverse(pic, senv->defer)) {
+    src = pic_car(pic, defer);
+    dst = pic_cdr(pic, defer);
+
+    val = macroexpand_lambda(pic, src, senv);
+
+    /* copy */
+    pic_pair_ptr(dst)->car = pic_car(pic, val);
+    pic_pair_ptr(dst)->cdr = pic_cdr(pic, val);
+  }
+
+  senv->defer = pic_nil_value();
+}
+
+static pic_value
+macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
+{
+  pic_value formal, body;
+  struct pic_senv *in;
+  pic_value a;
+
+  if (pic_length(pic, expr) < 2) {
+    pic_errorf(pic, "syntax error");
+  }
+
+  in = pic_make_senv(pic, senv);
+
+  for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
+    pic_value v = pic_car(pic, a);
+
+    if (! pic_sym_p(v)) {
+      pic_errorf(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_errorf(pic, "syntax error");
+  }
+
+  formal = macroexpand_list(pic, pic_cadr(pic, expr), in);
+  body = macroexpand_list(pic, pic_cddr(pic, expr), in);
+
+  macroexpand_deferred(pic, in);
+
+  return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body));
+}
+
+static pic_value
+macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
+{
+  pic_sym sym, rename;
+  pic_value var, val;
+
+  while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) {
+    var = pic_car(pic, pic_cadr(pic, expr));
+    val = pic_cdr(pic, pic_cadr(pic, expr));
+
+    expr = pic_list3(pic, pic_sym_value(pic->rDEFINE), var, pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr))));
+  }
+
+  if (pic_length(pic, expr) != 3) {
+    pic_errorf(pic, "syntax error");
+  }
+
+  var = pic_cadr(pic, expr);
+  if (! pic_sym_p(var)) {
+    pic_errorf(pic, "binding to non-symbol object");
+  }
+  sym = pic_sym(var);
+  if (! pic_find_rename(pic, senv, sym, &rename)) {
+    rename = pic_add_rename(pic, senv, sym);
+  }
+  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_errorf(pic, "syntax error");
+  }
+
+  var = pic_cadr(pic, expr);
+  if (! pic_sym_p(var)) {
+    pic_errorf(pic, "binding to non-symbol object");
+  }
+  sym = pic_sym(var);
+  if (! pic_find_rename(pic, senv, sym, &rename)) {
+    rename = pic_add_rename(pic, senv, sym);
+  } 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_defer(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;
+
+  lib->env->defer = pic_nil_value(); /* the last expansion could fail and leave defer field old */
+
+  v = macroexpand(pic, expr, lib->env);
+
+  macroexpand_deferred(pic, lib->env);
+
+  pic->lib = prev;
+
+#if DEBUG
+  puts("after expand:");
+  pic_debug(pic, v);
+  puts("");
+#endif
+
+  return v;
+}
+
+struct pic_senv *
+pic_make_senv(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;
+  senv->defer = pic_nil_value();
+  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_make_senv(pic, NULL);
+
+  pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY);
+  pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT);
+  pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT);
+  pic_define_syntactic_keyword(pic, senv, pic->sIN_LIBRARY, pic->rIN_LIBRARY);
+  pic_define_syntactic_keyword(pic, senv, pic->sCOND_EXPAND, pic->rCOND_EXPAND);
+
+  return senv;
+}
+
+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_make_proc(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));
+}
+
+bool
+pic_identifier_eq_p(pic_state *pic, struct pic_senv *env1, pic_sym sym1, struct pic_senv *env2, pic_sym sym2)
+{
+  pic_sym a, b;
+
+  a = make_identifier(pic, sym1, env1);
+  if (a != make_identifier(pic, sym1, env1)) {
+    a = sym1;
+  }
+
+  b = make_identifier(pic, sym2, env2);
+  if (b != make_identifier(pic, sym2, env2)) {
+    b = sym2;
+  }
+
+  return pic_eq_p(pic_sym_value(a), pic_sym_value(b));
+}
+
+static pic_value
+pic_macro_identifier_p(pic_state *pic)
+{
+  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)));
+}
+
+static pic_value
+pic_macro_identifier_eq_p(pic_state *pic)
+{
+  pic_sym sym1, sym2;
+  pic_value env1, env2;
+
+  pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2);
+
+  pic_assert_type(pic, env1, senv);
+  pic_assert_type(pic, env2, senv);
+
+  return pic_bool_value(pic_identifier_eq_p(pic, pic_senv_ptr(env1), sym1, pic_senv_ptr(env2), sym2));
+}
+
+void
+pic_init_macro(pic_state *pic)
+{
+  pic_defun(pic, "identifier?", pic_macro_identifier_p);
+  pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
+  pic_defun(pic, "make-identifier", pic_macro_make_identifier);
+}

extlib/benz/number.c

@@ -0,0 +1,647 @@
+/**
+ * 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"
+
+/**
+ * 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, i;                                     \
+    pic_value *argv;					\
+    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_errorf(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)
+
+#define DEFINE_ARITH_OP(op, name, unit)                         \
+  static pic_value                                              \
+  pic_number_##name(pic_state *pic)                             \
+  {                                                             \
+    size_t argc, i;                                             \
+    pic_value *argv;                                            \
+    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_errorf(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, i;                                                     \
+   pic_value *argv;                                                     \
+   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_errorf(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(abs((int)f));
+  }
+  else {
+    return pic_float_value(fabs(f));
+  }
+}
+
+static pic_value
+pic_number_floor2(pic_state *pic)
+{
+  int i, j;
+  bool e1, e2;
+
+  pic_get_args(pic, "II", &i, &e1, &j, &e2);
+
+  if (e1 && e2) {
+    int k;
+
+    k = (i < 0 && j < 0) || (0 <= i && 0 <= j)
+      ? i / j
+      : (i / j) - 1;
+
+    return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j));
+  }
+  else {
+    double q, r;
+
+    q = floor((double)i/j);
+    r = i - j * q;
+    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
+  }
+}
+
+static pic_value
+pic_number_trunc2(pic_state *pic)
+{
+  int i, j;
+  bool e1, e2;
+
+  pic_get_args(pic, "II", &i, &e1, &j, &e2);
+
+  if (e1 && e2) {
+    return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j));
+  }
+  else {
+    double q, r;
+
+    q = trunc((double)i/j);
+    r = i - j * q;
+
+    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
+  }
+}
+
+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_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_make_str(pic, buf, sizeof buf - 1));
+  }
+  else {
+    char buf[snprintf(NULL, 0, "%f", f) + 1];
+
+    snprintf(buf, sizeof buf, "%f", f);
+
+    return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1));
+  }
+}
+
+static pic_value
+pic_number_string_to_number(pic_state *pic)
+{
+  const char *str;
+  int radix = 10;
+  long num;
+  char *eptr;
+  double flo;
+
+  pic_get_args(pic, "z|i", &str, &radix);
+
+  num = strtol(str, &eptr, radix);
+  if (*eptr == '\0') {
+    return pic_valid_int(num)
+      ? pic_int_value((int)num)
+      : pic_float_value(num);
+  }
+
+  flo = strtod(str, &eptr);
+  if (*eptr == '\0') {
+    return pic_float_value(flo);
+  }
+
+  pic_errorf(pic, "invalid string given: %s", str);
+}
+
+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_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, "+", 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, "floor/", pic_number_floor2);
+  pic_defun(pic, "truncate/", pic_number_trunc2);
+  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, "inexact", pic_number_inexact);
+  pic_defun(pic, "exact", pic_number_exact);
+  pic_gc_arena_restore(pic, ai);
+
+  pic_defun(pic, "finite?", pic_number_finite_p);
+  pic_defun(pic, "infinite?", pic_number_infinite_p);
+  pic_defun(pic, "nan?", pic_number_nan_p);
+  pic_gc_arena_restore(pic, ai);
+
+  pic_defun(pic, "abs", pic_number_abs);
+  pic_defun(pic, "sqrt", pic_number_sqrt);
+  pic_defun(pic, "expt", pic_number_expt);
+  pic_defun(pic, "exp", pic_number_exp);
+  pic_defun(pic, "log", pic_number_log);
+  pic_defun(pic, "sin", pic_number_sin);
+  pic_defun(pic, "cos", pic_number_cos);
+  pic_defun(pic, "tan", pic_number_tan);
+  pic_defun(pic, "acos", pic_number_acos);
+  pic_defun(pic, "asin", pic_number_asin);
+  pic_defun(pic, "atan", pic_number_atan);
+  pic_gc_arena_restore(pic, ai);
+
+  pic_defun(pic, "number->string", pic_number_number_to_string);
+  pic_defun(pic, "string->number", pic_number_string_to_number);
+  pic_gc_arena_restore(pic, ai);
+}

extlib/benz/pair.c

@@ -0,0 +1,792 @@
+/**
+ * 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);
+}
+
+void
+pic_set_car(pic_state *pic, pic_value obj, pic_value val)
+{
+  struct pic_pair *pair;
+
+  if (! pic_pair_p(obj)) {
+    pic_errorf(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_errorf(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, size_t k, pic_value fill)
+{
+  pic_value list;
+  size_t i;
+
+  list = pic_nil_value();
+  for (i = 0; i < k; ++i) {
+    list = pic_cons(pic, fill, list);
+  }
+
+  return list;
+}
+
+size_t
+pic_length(pic_state *pic, pic_value obj)
+{
+  size_t 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, size_t i)
+{
+  while (i-- > 0) {
+    list = pic_cdr(pic, list);
+  }
+  return list;
+}
+
+pic_value
+pic_list_ref(pic_state *pic, pic_value list, size_t i)
+{
+  return pic_car(pic, pic_list_tail(pic, list, i));
+}
+
+void
+pic_list_set(pic_state *pic, pic_value list, size_t 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);
+
+  pic_set_car(pic, v, 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);
+
+  pic_set_cdr(pic, v, 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)
+{
+  size_t i;
+  pic_value fill = pic_none_value();
+
+  pic_get_args(pic, "k|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_size_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;
+  size_t i;
+
+  pic_get_args(pic, "ok", &list, &i);
+
+  return pic_list_tail(pic, list, i);
+}
+
+static pic_value
+pic_pair_list_ref(pic_state *pic)
+{
+  pic_value list;
+  size_t i;
+
+  pic_get_args(pic, "ok", &list, &i);
+
+  return pic_list_ref(pic, list, i);
+}
+
+static pic_value
+pic_pair_list_set(pic_state *pic)
+{
+  pic_value list, obj;
+  size_t i;
+
+  pic_get_args(pic, "oko", &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_map(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc, i;
+  pic_value *args;
+  pic_value arg, ret;
+
+  pic_get_args(pic, "l*", &proc, &argc, &args);
+
+  ret = pic_nil_value();
+  do {
+    arg = pic_nil_value();
+    for (i = 0; i < argc; ++i) {
+      if (! pic_pair_p(args[i])) {
+        break;
+      }
+      pic_push(pic, pic_car(pic, args[i]), arg);
+      args[i] = pic_cdr(pic, args[i]);
+    }
+    if (i != argc) {
+      break;
+    }
+    pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg)), ret);
+  } while (1);
+
+  return pic_reverse(pic, ret);
+}
+
+static pic_value
+pic_pair_for_each(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc, i;
+  pic_value *args;
+  pic_value arg;
+
+  pic_get_args(pic, "l*", &proc, &argc, &args);
+
+  do {
+    arg = pic_nil_value();
+    for (i = 0; i < argc; ++i) {
+      if (! pic_pair_p(args[i])) {
+        break;
+      }
+      pic_push(pic, pic_car(pic, args[i]), arg);
+      args[i] = pic_cdr(pic, args[i]);
+    }
+    if (i != argc) {
+      break;
+    }
+    pic_apply(pic, proc, pic_reverse(pic, arg));
+  } while (1);
+
+  return pic_none_value();
+}
+
+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_defun(pic, "pair?", pic_pair_pair_p);
+  pic_defun(pic, "cons", pic_pair_cons);
+  pic_defun(pic, "car", pic_pair_car);
+  pic_defun(pic, "cdr", pic_pair_cdr);
+  pic_defun(pic, "set-car!", pic_pair_set_car);
+  pic_defun(pic, "set-cdr!", pic_pair_set_cdr);
+  pic_defun(pic, "null?", pic_pair_null_p);
+
+  pic_defun(pic, "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, "map", pic_pair_map);
+  pic_defun(pic, "for-each", pic_pair_for_each);
+  pic_defun(pic, "memq", pic_pair_memq);
+  pic_defun(pic, "memv", pic_pair_memv);
+  pic_defun(pic, "member", pic_pair_member);
+  pic_defun(pic, "assq", pic_pair_assq);
+  pic_defun(pic, "assv", pic_pair_assv);
+  pic_defun(pic, "assoc", pic_pair_assoc);
+}

extlib/benz/port.c

@@ -0,0 +1,735 @@
+/**
+ * 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"
+
+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)
+{
+  pic_value obj;
+
+  obj = pic_funcall(pic, pic->PICRIN_BASE, "current-input-port", pic_nil_value());
+
+  return pic_port_ptr(obj);
+}
+
+struct pic_port *
+pic_stdout(pic_state *pic)
+{
+  pic_value obj;
+
+  obj = pic_funcall(pic, pic->PICRIN_BASE, "current-output-port", pic_nil_value());
+
+  return pic_port_ptr(obj);
+}
+
+struct pic_port *
+pic_make_standard_port(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)
+{
+  size_t size;
+  char *buf;
+
+  /* get endpos */
+  xfflush(port->file);
+  size = (size_t)xftell(port->file);
+  xrewind(port->file);
+
+  /* copy to buf */
+  buf = (char *)pic_alloc(pic, size + 1);
+  buf[size] = 0;
+  xfread(buf, size, 1, port->file);
+
+  return pic_make_str(pic, buf, size);
+}
+
+void
+pic_close_port(pic_state *pic, struct pic_port *port)
+{
+  if (xfclose(port->file) == EOF) {
+    pic_errorf(pic, "close-port: failure");
+  }
+  port->status = PIC_PORT_CLOSE;
+}
+
+static pic_value
+pic_port_call_with_port(pic_state *pic)
+{
+  struct pic_port *port;
+  struct pic_proc *proc;
+  pic_value value;
+
+  pic_get_args(pic, "pl", &port, &proc);
+
+  value = pic_apply1(pic, proc, pic_obj_value(port));
+
+  pic_close_port(pic, port);
+
+  return value;
+}
+
+static pic_value
+pic_port_input_port_p(pic_state *pic)
+{
+  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_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_port_open_p(pic_state *pic)
+{
+  struct pic_port *port;
+
+  pic_get_args(pic, "p", &port);
+
+  return pic_bool_value(port->status == PIC_PORT_OPEN);
+}
+
+static pic_value
+pic_port_close_port(pic_state *pic)
+{
+  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_errorf(pic, caller ": expected output port");               \
+      case PIC_PORT_OUT:                                                \
+        pic_errorf(pic, caller ": expected input port");                \
+      case PIC_PORT_IN | PIC_PORT_TEXT:                                 \
+        pic_errorf(pic, caller ": expected input/textual port");        \
+      case PIC_PORT_IN | PIC_PORT_BINARY:                               \
+        pic_errorf(pic, caller ": expected input/binary port");         \
+      case PIC_PORT_OUT | PIC_PORT_TEXT:                                \
+        pic_errorf(pic, caller ": expected output/textual port");       \
+      case PIC_PORT_OUT | PIC_PORT_BINARY:                              \
+        pic_errorf(pic, caller ": expected output/binary port");        \
+      }                                                                 \
+    }                                                                   \
+    if (port->status != stat) {                                         \
+      switch (stat) {                                                   \
+      case PIC_PORT_OPEN:                                               \
+        pic_errorf(pic, caller ": expected open port");                 \
+      case PIC_PORT_CLOSE:                                              \
+        pic_errorf(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;
+  size_t size;
+
+  pic_get_args(pic, "|p", &port);
+
+  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector");
+
+  /* get endpos */
+  xfflush(port->file);
+  size = (size_t)xftell(port->file);
+  xrewind(port->file);
+
+  /* copy to buf */
+  blob = pic_make_blob(pic, size);
+  xfread(blob->data, 1, size, 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;
+  size_t k, i;
+
+  pic_get_args(pic, "k|p", &k, &port);
+
+  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector");
+
+  blob = pic_make_blob(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 n;
+  char *buf;
+  size_t start, end, i, len;
+
+  n = pic_get_args(pic, "b|pkk", &bv, &port, &start, &end);
+  switch (n) {
+  case 1:
+    port = pic_stdin(pic);
+  case 2:
+    start = 0;
+  case 3:
+    end = bv->len;
+  }
+
+  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!");
+
+  if (end < start) {
+    pic_errorf(pic, "read-bytevector!: end index must be greater than or equal to start index");
+  }
+
+  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_size_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 n;
+  size_t start, end, i;
+
+  n = pic_get_args(pic, "b|pkk", &blob, &port, &start, &end);
+  switch (n) {
+  case 1:
+    port = pic_stdout(pic);
+  case 2:
+    start = 0;
+  case 3:
+    end = 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)
+{
+  pic_defvar(pic, "current-input-port", pic_obj_value(pic->xSTDIN), NULL);
+  pic_defvar(pic, "current-output-port", pic_obj_value(pic->xSTDOUT), NULL);
+  pic_defvar(pic, "current-error-port", pic_obj_value(pic->xSTDERR), NULL);
+
+  pic_defun(pic, "call-with-port", pic_port_call_with_port);
+
+  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, "port-open?", pic_port_port_open_p);
+  pic_defun(pic, "close-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);
+}

extlib/benz/proc.c

@@ -0,0 +1,86 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/pair.h"
+#include "picrin/proc.h"
+#include "picrin/irep.h"
+
+struct pic_proc *
+pic_make_proc(pic_state *pic, pic_func_t func, const char *name)
+{
+  struct pic_proc *proc;
+
+  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;
+  return proc;
+}
+
+struct pic_proc *
+pic_make_proc_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;
+  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();
+}
+
+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_errorf(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);
+}
+
+void
+pic_init_proc(pic_state *pic)
+{
+  pic_defun(pic, "procedure?", pic_proc_proc_p);
+  pic_defun(pic, "apply", pic_proc_apply);
+}

extlib/benz/read.c

@@ -0,0 +1,934 @@
+/**
+ * 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->sREAD, 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] = (char)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] = (char)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++] = (char)c;
+  while (isdigit(c = peek(port))) {
+    buf[i++] = (char)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++] = (char)next(port);
+
+  switch ((c = next(port))) {
+  case '-':
+  case '+':
+    buf[i++] = (char)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++] = (char)next(port);
+    i += read_uinteger(pic, port, next(port), buf + i);
+    read_suffix(pic, port, buf + i);
+    return pic_float_value(atof(buf));
+
+  default:
+    read_suffix(pic, port, buf + i);
+    return pic_int_value((int)(atof(buf)));
+  }
+}
+
+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((char)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++] = (char)c;
+    if (cnt >= size) {
+      buf = pic_realloc(pic, buf, size *= 2);
+    }
+  }
+  buf[cnt] = '\0';
+
+  str = pic_make_str(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++] = (char)next(port)) != ';') {
+          if (i >= sizeof HEX_BUF)
+            read_error(pic, "expected ';'");
+        }
+        c = (char)strtol(HEX_BUF, NULL, 16);
+        break;
+      }
+    }
+    buf[cnt++] = (char)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 buf[256];
+  unsigned char *dat;
+  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] = (unsigned char)n;
+    c = next(port);
+  }
+
+  blob = pic_make_blob(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_make_vec_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_make_vec(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++] = (char)c;
+
+  while (i < sizeof buf) {
+    trie = trie->table[c];
+
+    if ((c = peek(port)) == EOF) {
+      break;
+    }
+    if (trie->table[c] == NULL) {
+      break;
+    }
+    buf[i++] = (char)next(port);
+  }
+  if (i == sizeof buf) {
+    read_error(pic, "too long dispatch string");
+  }
+
+  if (trie->proc == NULL) {
+    read_error(pic, "no reader registered for current string");
+  }
+  str = pic_make_str(pic, buf, i);
+  return pic_apply2(pic, trie->proc, pic_obj_value(port), pic_obj_value(str));
+}
+
+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_make_trie(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_make_trie(pic);
+    }
+    trie = trie->table[c];
+  }
+  trie->proc = pic_make_proc(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_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_defun(pic, "read", pic_read_read);
+}

extlib/benz/record.c

@@ -0,0 +1,113 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/record.h"
+
+struct pic_record *
+pic_make_record(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_make_record(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_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);
+}

extlib/benz/state.c

@@ -0,0 +1,239 @@
+/**
+ * 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/port.h"
+#include "picrin/error.h"
+
+void pic_init_core(pic_state *);
+
+pic_state *
+pic_open(int argc, char *argv[], char **envp)
+{
+  struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short);
+  char t;
+
+  pic_state *pic;
+  size_t ai;
+
+  pic = malloc(sizeof(pic_state));
+
+  /* root block */
+  pic->wind = 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;
+
+  /* exception handler */
+  pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
+  pic->xpend = pic->xpbase + PIC_RESCUE_SIZE;
+
+  /* memory heap */
+  pic->heap = pic_heap_open();
+
+  /* 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 *));
+
+  /* attributes */
+  xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *));
+
+  /* features */
+  pic->features = pic_nil_value();
+
+  /* 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_make_trie(pic);
+  xh_init_int(&pic->reader->labels, sizeof(pic_value));
+
+  /* raised error object */
+  pic->err = pic_undef_value();
+
+  /* standard ports */
+  pic->xSTDIN = NULL;
+  pic->xSTDOUT = NULL;
+  pic->xSTDERR = NULL;
+
+  /* GC arena */
+  pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
+  pic->arena_size = PIC_ARENA_SIZE;
+  pic->arena_idx = 0;
+
+  /* native stack marker */
+  pic->native_stack_start = &t;
+
+#define S(slot,name) pic->slot = pic_intern_cstr(pic, name);
+
+  ai = pic_gc_arena_preserve(pic);
+  S(sDEFINE, "define");
+  S(sLAMBDA, "lambda");
+  S(sIF, "if");
+  S(sBEGIN, "begin");
+  S(sSETBANG, "set!");
+  S(sQUOTE, "quote");
+  S(sQUASIQUOTE, "quasiquote");
+  S(sUNQUOTE, "unquote");
+  S(sUNQUOTE_SPLICING, "unquote-splicing");
+  S(sDEFINE_SYNTAX, "define-syntax");
+  S(sIMPORT, "import");
+  S(sEXPORT, "export");
+  S(sDEFINE_LIBRARY, "define-library");
+  S(sIN_LIBRARY, "in-library");
+  S(sCOND_EXPAND, "cond-expand");
+  S(sAND, "and");
+  S(sOR, "or");
+  S(sELSE, "else");
+  S(sLIBRARY, "library");
+  S(sONLY, "only");
+  S(sRENAME, "rename");
+  S(sPREFIX, "prefix");
+  S(sEXCEPT, "except");
+  S(sCONS, "cons");
+  S(sCAR, "car");
+  S(sCDR, "cdr");
+  S(sNILP, "null?");
+  S(sADD, "+");
+  S(sSUB, "-");
+  S(sMUL, "*");
+  S(sDIV, "/");
+  S(sMINUS, "minus");
+  S(sEQ, "=");
+  S(sLT, "<");
+  S(sLE, "<=");
+  S(sGT, ">");
+  S(sGE, ">=");
+  S(sNOT, "not");
+  S(sREAD, "read");
+  S(sFILE, "file");
+  pic_gc_arena_restore(pic, ai);
+
+#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name));
+
+  ai = pic_gc_arena_preserve(pic);
+  R(rDEFINE, "define");
+  R(rLAMBDA, "lambda");
+  R(rIF, "if");
+  R(rBEGIN, "begin");
+  R(rSETBANG, "set!");
+  R(rQUOTE, "quote");
+  R(rDEFINE_SYNTAX, "define-syntax");
+  R(rIMPORT, "import");
+  R(rEXPORT, "export");
+  R(rDEFINE_LIBRARY, "define-library");
+  R(rIN_LIBRARY, "in-library");
+  R(rCOND_EXPAND, "cond-expand");
+  pic_gc_arena_restore(pic, ai);
+
+  /* root block */
+  pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
+  pic->wind->prev = NULL;
+  pic->wind->depth = 0;
+  pic->wind->in = pic->wind->out = NULL;
+
+  /* init readers */
+  pic_init_reader(pic);
+
+  /* standard libraries */
+  pic->PICRIN_BASE = pic_open_library(pic, pic_read_cstr(pic, "(picrin base)"));
+  pic->PICRIN_USER = pic_open_library(pic, pic_read_cstr(pic, "(picrin user)"));
+  pic->lib = pic->PICRIN_USER;
+
+  /* standard I/O */
+  pic->xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN);
+  pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT);
+  pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT);
+
+  pic_init_core(pic);
+
+  return pic;
+}
+
+void
+pic_close(pic_state *pic)
+{
+  xh_entry *it;
+
+  /* invoke exit handlers */
+  while (pic->wind) {
+    if (pic->wind->out) {
+      pic_apply0(pic, pic->wind->out);
+    }
+    pic->wind = pic->wind->prev;
+  }
+
+  /* clear out root objects */
+  pic->sp = pic->stbase;
+  pic->ci = pic->cibase;
+  pic->xp = pic->xpbase;
+  pic->arena_idx = 0;
+  pic->err = pic_undef_value();
+  xh_clear(&pic->globals);
+  xh_clear(&pic->macros);
+  xh_clear(&pic->attrs);
+  pic->features = pic_nil_value();
+  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(pic->xpbase);
+
+  /* free reader struct */
+  xh_destroy(&pic->reader->labels);
+  pic_trie_delete(pic, pic->reader->trie);
+  free(pic->reader);
+
+  /* free global stacks */
+  xh_destroy(&pic->syms);
+  xh_destroy(&pic->globals);
+  xh_destroy(&pic->macros);
+  xh_destroy(&pic->attrs);
+
+  /* free GC arena */
+  free(pic->arena);
+
+  /* free symbol names */
+  for (it = xh_begin(&pic->sym_names); it != NULL; it = xh_next(it)) {
+    free(xh_val(it, char *));
+  }
+  xh_destroy(&pic->sym_names);
+
+  free(pic);
+}

extlib/benz/string.c

@@ -0,0 +1,497 @@
+/**
+ * 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 *
+make_str_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_make_str(pic_state *pic, const char *imbed, size_t len)
+{
+  if (imbed == NULL && len > 0) {
+    pic_errorf(pic, "zero length specified against NULL ptr");
+  }
+  return make_str_rope(pic, xr_new_copy(imbed, len));
+}
+
+pic_str *
+pic_make_str_cstr(pic_state *pic, const char *cstr)
+{
+  return pic_make_str(pic, cstr, strlen(cstr));
+}
+
+pic_str *
+pic_make_str_fill(pic_state *pic, size_t len, char fill)
+{
+  size_t i;
+  char buf[len + 1];
+
+  for (i = 0; i < len; ++i) {
+    buf[i] = fill;
+  }
+  buf[i] = '\0';
+
+  return pic_make_str(pic, buf, len);
+}
+
+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;
+}
+
+pic_str *
+pic_strcat(pic_state *pic, pic_str *a, pic_str *b)
+{
+  return make_str_rope(pic, xr_cat(a->rope, b->rope));
+}
+
+pic_str *
+pic_substr(pic_state *pic, pic_str *str, size_t s, size_t e)
+{
+  return make_str_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_xvfformat(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_xvformat(pic_state *pic, const char *fmt, va_list ap)
+{
+  struct pic_port *port;
+  pic_value irrs;
+
+  port = pic_open_output_string(pic);
+
+  irrs = pic_xvfformat(pic, port->file, fmt, ap);
+  irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs);
+
+  pic_close_port(pic, port);
+  return irrs;
+}
+
+pic_value
+pic_xformat(pic_state *pic, const char *fmt, ...)
+{
+  va_list ap;
+  pic_value objs;
+
+  va_start(ap, fmt);
+  objs = pic_xvformat(pic, fmt, ap);
+  va_end(ap);
+
+  return objs;
+}
+
+void
+pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
+{
+  pic_xvfformat(pic, file, fmt, ap);
+}
+
+pic_str *
+pic_vformat(pic_state *pic, const char *fmt, va_list ap)
+{
+  struct pic_port *port;
+  pic_str *str;
+
+  port = pic_open_output_string(pic);
+
+  pic_vfformat(pic, port->file, fmt, ap);
+  str = pic_get_output_string(pic, port);
+
+  pic_close_port(pic, port);
+  return str;
+}
+
+pic_str *
+pic_format(pic_state *pic, const char *fmt, ...)
+{
+  va_list ap;
+  pic_str *str;
+
+  va_start(ap, fmt);
+  str = pic_vformat(pic, fmt, ap);
+  va_end(ap);
+
+  return str;
+}
+
+static pic_value
+pic_str_string_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_bool_value(pic_str_p(v));
+}
+
+static pic_value
+pic_str_string(pic_state *pic)
+{
+  size_t argc, i;
+  pic_value *argv;
+  pic_str *str;
+  char *buf;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  buf = pic_alloc(pic, (size_t)argc);
+
+  for (i = 0; i < argc; ++i) {
+    pic_assert_type(pic, argv[i], char);
+    buf[i] = pic_char(argv[i]);
+  }
+
+  str = pic_make_str(pic, buf, (size_t)argc);
+  pic_free(pic, buf);
+
+  return pic_obj_value(str);
+}
+
+static pic_value
+pic_str_make_string(pic_state *pic)
+{
+  size_t len;
+  char c = ' ';
+
+  pic_get_args(pic, "k|c", &len, &c);
+
+  return pic_obj_value(pic_make_str_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_size_value(pic_strlen(str));
+}
+
+static pic_value
+pic_str_string_ref(pic_state *pic)
+{
+  pic_str *str;
+  size_t k;
+
+  pic_get_args(pic, "sk", &str, &k);
+
+  return pic_char_value(pic_str_ref(pic, str, k));
+}
+
+#define DEFINE_STRING_CMP(name, op)                                     \
+  static pic_value                                                      \
+  pic_str_string_##name(pic_state *pic)                                 \
+  {                                                                     \
+    size_t argc, i;                                                     \
+    pic_value *argv;                                                    \
+                                                                        \
+    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;
+  size_t start, end;
+
+  n = pic_get_args(pic, "s|kk", &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_append(pic_state *pic)
+{
+  size_t argc, i;
+  pic_value *argv;
+  pic_str *str;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  str = pic_make_str(pic, NULL, 0);
+  for (i = 0; i < argc; ++i) {
+    if (! pic_str_p(argv[i])) {
+      pic_errorf(pic, "type error");
+    }
+    str = pic_strcat(pic, str, pic_str_ptr(argv[i]));
+  }
+  return pic_obj_value(str);
+}
+
+static pic_value
+pic_str_string_map(pic_state *pic)
+{
+  struct pic_proc *proc;
+  pic_value *argv, vals, val;
+  size_t argc, i, len, j;
+
+  pic_get_args(pic, "l*", &proc, &argc, &argv);
+
+  len = SIZE_MAX;
+  for (i = 0; i < argc; ++i) {
+    pic_assert_type(pic, argv[i], str);
+
+    len = len < pic_strlen(pic_str_ptr(argv[i]))
+      ? len
+      : pic_strlen(pic_str_ptr(argv[i]));
+  }
+  if (len == SIZE_MAX) {
+    pic_errorf(pic, "string-map: one or more strings expected, but got zero");
+  }
+  else {
+    char buf[len];
+
+    for (i = 0; i < len; ++i) {
+      vals = pic_nil_value();
+      for (j = 0; j < argc; ++j) {
+        pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
+      }
+      val = pic_apply(pic, proc, vals);
+
+      pic_assert_type(pic, val, char);
+      buf[i] = pic_char(val);
+    }
+
+    return pic_obj_value(pic_make_str(pic, buf, len));
+  }
+}
+
+static pic_value
+pic_str_string_for_each(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc, len, i, j;
+  pic_value *argv, vals;
+
+  pic_get_args(pic, "l*", &proc, &argc, &argv);
+
+  len = SIZE_MAX;
+  for (i = 0; i < argc; ++i) {
+    pic_assert_type(pic, argv[i], str);
+
+    len = len < pic_strlen(pic_str_ptr(argv[i]))
+      ? len
+      : pic_strlen(pic_str_ptr(argv[i]));
+  }
+  if (len == SIZE_MAX) {
+    pic_errorf(pic, "string-map: one or more strings expected, but got zero");
+  }
+
+  for (i = 0; i < len; ++i) {
+    vals = pic_nil_value();
+    for (j = 0; j < argc; ++j) {
+      pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
+    }
+    pic_apply(pic, proc, vals);
+  }
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_str_list_to_string(pic_state *pic)
+{
+  pic_str *str;
+  pic_value list, e;
+  size_t i = 0;
+
+  pic_get_args(pic, "o", &list);
+
+  if (pic_length(pic, list) == 0) {
+    return pic_obj_value(pic_make_str(pic, NULL, 0));
+  } else {
+    char buf[pic_length(pic, list)];
+
+    pic_for_each (e, list) {
+      pic_assert_type(pic, e, char);
+
+      buf[i++] = pic_char(e);
+    }
+
+    str = pic_make_str(pic, buf, i);
+
+    return pic_obj_value(str);
+  }
+}
+
+static pic_value
+pic_str_string_to_list(pic_state *pic)
+{
+  pic_str *str;
+  pic_value list;
+  int n;
+  size_t start, end, i;
+
+  n = pic_get_args(pic, "s|kk", &str, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = pic_strlen(str);
+  }
+
+  list = pic_nil_value();
+
+  for (i = start; i < end; ++i) {
+    pic_push(pic, pic_char_value(pic_str_ref(pic, str, i)), list);
+  }
+  return pic_reverse(pic, list);
+}
+
+void
+pic_init_str(pic_state *pic)
+{
+  pic_defun(pic, "string?", pic_str_string_p);
+  pic_defun(pic, "string", pic_str_string);
+  pic_defun(pic, "make-string", pic_str_make_string);
+  pic_defun(pic, "string-length", pic_str_string_length);
+  pic_defun(pic, "string-ref", pic_str_string_ref);
+  pic_defun(pic, "string-copy", pic_str_string_copy);
+  pic_defun(pic, "string-append", pic_str_string_append);
+  pic_defun(pic, "string-map", pic_str_string_map);
+  pic_defun(pic, "string-for-each", pic_str_string_for_each);
+  pic_defun(pic, "list->string", pic_str_list_to_string);
+  pic_defun(pic, "string->list", pic_str_string_to_list);
+
+  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);
+}

extlib/benz/symbol.c

@@ -0,0 +1,163 @@
+/**
+ * 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_intern_str(pic_state *pic, pic_str *str)
+{
+  return pic_intern_cstr(pic, pic_str_cstr(str));
+}
+
+pic_sym
+pic_gensym(pic_state *pic, pic_sym base)
+{
+  int uid = pic->uniq_sym_cnt++, len;
+  char *str, mark;
+  pic_sym uniq;
+
+  if (pic_interned_p(pic, base)) {
+    mark = '@';
+  } else {
+    mark = '.';
+  }
+
+  len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
+  str = pic_alloc(pic, (size_t)len + 1);
+  sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
+
+  /* don't put the symbol to pic->syms to keep it uninterned */
+  uniq = pic->sym_cnt++;
+  xh_put_int(&pic->sym_names, uniq, &str);
+
+  return uniq;
+}
+
+pic_sym
+pic_ungensym(pic_state *pic, pic_sym base)
+{
+  const char *name, *occr;
+
+  if (pic_interned_p(pic, base)) {
+    return base;
+  }
+
+  name = pic_symbol_name(pic, base);
+  if ((occr = strrchr(name, '@')) == NULL) {
+    pic_panic(pic, "logic flaw");
+  }
+  return pic_intern(pic, name, (size_t)(occr - name));
+}
+
+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_errorf(pic, "symbol->string: expected symbol");
+  }
+
+  return pic_obj_value(pic_make_str_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_errorf(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_defun(pic, "symbol?", pic_symbol_symbol_p);
+  pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
+  pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);
+
+  pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p);
+}

extlib/benz/system.c

@@ -0,0 +1,134 @@
+/**
+ * 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_make_str_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_make_str_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;
+    size_t i;
+
+    for (i = 0; (*envp)[i] != '='; ++i)
+      ;
+
+    key = pic_make_str(pic, *envp, i);
+    val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key)));
+
+    /* push */
+    data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);
+
+    pic_gc_arena_restore(pic, ai);
+    pic_gc_protect(pic, data);
+  }
+
+  return data;
+}
+
+void
+pic_init_system(pic_state *pic)
+{
+  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);
+}

extlib/benz/time.c

@@ -0,0 +1,47 @@
+/**
+ * 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((int)c); /* The year 2038 problem :-| */
+}
+
+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_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);
+}

extlib/benz/var.c

@@ -0,0 +1,110 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/pair.h"
+#include "picrin/proc.h"
+#include "picrin/dict.h"
+
+static pic_value
+var_lookup(pic_state *pic, pic_value var)
+{
+  pic_value val, env;
+  struct pic_dict *binding;
+
+  val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment");
+  if (pic_eq_p(val, var)) {
+    return pic_false_value();
+  }
+
+  env = pic_apply0(pic, pic_proc_ptr(val));
+  while (! pic_nil_p(env)) {
+    pic_assert_type(pic, pic_car(pic, env), dict);
+
+    binding = pic_dict_ptr(pic_car(pic, env));
+    if (pic_dict_has(pic, binding, var)) {
+      return pic_dict_ref(pic, binding, var);
+    }
+    env = pic_cdr(pic, env);
+  }
+
+  return pic_false_value();
+}
+
+static pic_value
+var_call(pic_state *pic)
+{
+  struct pic_proc *self = pic_get_proc(pic);
+  pic_value val, tmp, box, conv;
+  int n;
+
+  n = pic_get_args(pic, "|oo", &val, &tmp);
+
+  box = var_lookup(pic, pic_obj_value(self));
+  if (! pic_test(box)) {
+    box = pic_attr_ref(pic, pic_obj_value(self), "@@box");
+  }
+
+  switch (n) {
+  case 0:
+    return pic_car(pic, box);
+
+  case 1:
+    conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter");
+    if (pic_test(conv)) {
+      pic_assert_type(pic, conv, proc);
+
+      val = pic_apply1(pic, pic_proc_ptr(conv), val);
+    }
+    pic_set_car(pic, box, val);
+
+    return pic_none_value();
+
+  case 2:
+    assert(pic_false_p(tmp));
+
+    conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter");
+    if (pic_test(conv)) {
+      pic_assert_type(pic, conv, proc);
+
+      return pic_apply1(pic, pic_proc_ptr(conv), val);
+    } else {
+      return val;
+    }
+  }
+  UNREACHABLE();
+}
+
+struct pic_proc *
+pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv)
+{
+  struct pic_proc *var;
+
+  var = pic_make_proc(pic, var_call, "<var-call>");
+  pic_attr_set(pic, pic_obj_value(var), "@@box", pic_list1(pic, init));
+  pic_attr_set(pic, pic_obj_value(var), "@@converter", conv ? pic_obj_value(conv) : pic_false_value());
+
+  return var;
+}
+
+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_make_var(pic, init, conv));
+}
+
+void
+pic_init_var(pic_state *pic)
+{
+  pic_define_noexport(pic, "current-dynamic-environment", pic_false_value());
+
+  pic_defun(pic, "make-parameter", pic_var_make_parameter);
+
+  pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL)));
+}

extlib/benz/vector.c

@@ -0,0 +1,429 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/vector.h"
+#include "picrin/string.h"
+#include "picrin/pair.h"
+
+struct pic_vector *
+pic_make_vec(pic_state *pic, size_t len)
+{
+  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_make_vec_from_list(pic_state *pic, pic_value data)
+{
+  struct pic_vector *vec;
+  size_t len, i;
+
+  len = pic_length(pic, data);
+
+  vec = pic_make_vec(pic, len);
+  for (i = 0; i < len; ++i) {
+    vec->data[i] = pic_car(pic, data);
+    data = pic_cdr(pic, data);
+  }
+  return vec;
+}
+
+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_vector(pic_state *pic)
+{
+  size_t argc, i;
+  pic_value *argv;
+  pic_vec *vec;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  vec = pic_make_vec(pic, (size_t)argc);
+
+  for (i = 0; i < argc; ++i) {
+    vec->data[i] = argv[i];
+  }
+
+  return pic_obj_value(vec);
+}
+
+static pic_value
+pic_vec_make_vector(pic_state *pic)
+{
+  pic_value v;
+  int n;
+  size_t k, i;
+  struct pic_vector *vec;
+
+  n = pic_get_args(pic, "k|o", &k, &v);
+
+  vec = pic_make_vec(pic, k);
+  if (n == 2) {
+    for (i = 0; i < 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_size_value(v->len);
+}
+
+static pic_value
+pic_vec_vector_ref(pic_state *pic)
+{
+  struct pic_vector *v;
+  size_t k;
+
+  pic_get_args(pic, "vk", &v, &k);
+
+  if (v->len <= k) {
+    pic_errorf(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;
+  size_t k;
+  pic_value o;
+
+  pic_get_args(pic, "vko", &v, &k, &o);
+
+  if (v->len <= k) {
+    pic_errorf(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;
+  size_t at, start, end;
+
+  n = pic_get_args(pic, "vkv|kk", &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;
+  size_t start, end, i = 0;
+
+  n = pic_get_args(pic, "v|kk", &vec, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = vec->len;
+  }
+
+  if (end < start) {
+    pic_errorf(pic, "vector-copy: end index must not be less than start index");
+  }
+
+  to = pic_make_vec(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)
+{
+  pic_value *argv;
+  size_t argc, i, j, len;
+  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_make_vec(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;
+  size_t start, end;
+
+  n = pic_get_args(pic, "vo|kk", &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_vector_map(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc, i, len, j;
+  pic_value *argv, vals;
+  pic_vec *vec;
+
+  pic_get_args(pic, "l*", &proc, &argc, &argv);
+
+  len = INT_MAX;
+  for (i = 0; i < argc; ++i) {
+    pic_assert_type(pic, argv[i], vec);
+
+    len = len < pic_vec_ptr(argv[i])->len
+      ? len
+      : pic_vec_ptr(argv[i])->len;
+  }
+
+  vec = pic_make_vec(pic, len);
+
+  for (i = 0; i < len; ++i) {
+    vals = pic_nil_value();
+    for (j = 0; j < argc; ++j) {
+      pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals);
+    }
+    vec->data[i] = pic_apply(pic, proc, vals);
+  }
+
+  return pic_obj_value(vec);
+}
+
+static pic_value
+pic_vec_vector_for_each(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc, i, len, j;
+  pic_value *argv, vals;
+
+  pic_get_args(pic, "l*", &proc, &argc, &argv);
+
+  len = INT_MAX;
+  for (i = 0; i < argc; ++i) {
+    pic_assert_type(pic, argv[i], vec);
+
+    len = len < pic_vec_ptr(argv[i])->len
+      ? len
+      : pic_vec_ptr(argv[i])->len;
+  }
+
+  for (i = 0; i < len; ++i) {
+    vals = pic_nil_value();
+    for (j = 0; j < argc; ++j) {
+      pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals);
+    }
+    pic_apply(pic, proc, vals);
+  }
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_vec_list_to_vector(pic_state *pic)
+{
+  struct pic_vector *vec;
+  pic_value list, e, *data;
+
+  pic_get_args(pic, "o", &list);
+
+  vec = pic_make_vec(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;
+  size_t start, end, i;
+
+  n = pic_get_args(pic, "v|kk", &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);
+}
+
+static pic_value
+pic_vec_vector_to_string(pic_state *pic)
+{
+  pic_vec *vec;
+  char *buf;
+  int n;
+  size_t start, end, i;
+  pic_str *str;
+
+  n = pic_get_args(pic, "v|kk", &vec, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = vec->len;
+  }
+
+  if (end < start) {
+    pic_errorf(pic, "vector->string: end index must not be less than start index");
+  }
+
+  buf = pic_alloc(pic, end - start);
+
+  for (i = start; i < end; ++i) {
+    pic_assert_type(pic, vec->data[i], char);
+
+    buf[i - start] = pic_char(vec->data[i]);
+  }
+
+  str = pic_make_str(pic, buf, end - start);
+  pic_free(pic, buf);
+
+  return pic_obj_value(str);
+}
+
+static pic_value
+pic_vec_string_to_vector(pic_state *pic)
+{
+  pic_str *str;
+  int n;
+  size_t start, end;
+  size_t i;
+  pic_vec *vec;
+
+  n = pic_get_args(pic, "s|kk", &str, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = pic_strlen(str);
+  }
+
+  if (end < start) {
+    pic_errorf(pic, "string->vector: end index must not be less than start index");
+  }
+
+  vec = pic_make_vec(pic, end - start);
+
+  for (i = 0; i < end - start; ++i) {
+    vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + start));
+  }
+  return pic_obj_value(vec);
+}
+
+void
+pic_init_vector(pic_state *pic)
+{
+  pic_defun(pic, "vector?", pic_vec_vector_p);
+  pic_defun(pic, "vector", pic_vec_vector);
+  pic_defun(pic, "make-vector", pic_vec_make_vector);
+  pic_defun(pic, "vector-length", pic_vec_vector_length);
+  pic_defun(pic, "vector-ref", pic_vec_vector_ref);
+  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, "vector-map", pic_vec_vector_map);
+  pic_defun(pic, "vector-for-each", pic_vec_vector_for_each);
+  pic_defun(pic, "list->vector", pic_vec_list_to_vector);
+  pic_defun(pic, "vector->list", pic_vec_vector_to_list);
+  pic_defun(pic, "string->vector", pic_vec_string_to_vector);
+  pic_defun(pic, "vector->string", pic_vec_vector_to_string);
+}

extlib/benz/write.c

@@ -0,0 +1,504 @@
+/**
+ * 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, *it;
+  int c;
+  double 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");
+    for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) {
+      xfprintf(file, " '");
+      write_core(p, xh_key(it, pic_value));
+      xfprintf(file, " '");
+      write_core(p, xh_val(it, 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_xvformat(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_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);
+}

t/issue/234.scm

@@ -0,0 +1,19 @@
+(import (scheme base)
+        (picrin test))
+
+(test-begin)
+
+(define-syntax fard
+  (syntax-rules ()
+    ((fard a b) (- a b))))
+
+(test -1 (fard 1 2))
+
+(define (fard a b)
+  (+ a b))
+
+(test 3 (fard 1 2))
+
+(test 3 (apply fard (list 1 2)))
+
+(test-end)

t/pickle.scm

@@ -1,46 +0,0 @@
-(import (picrin base)
-        (picrin test))
-
-(define (id obj) (unpickle (pickle obj)))
-
-(test #f (id #f))
-(test #t (id #t))
-(test 1 (id 1))
-(test -1 (id -1))
-(test 128 (id 128))
-(test -128 (id -128))
-(test 256 (id 256))
-(test -256 (id -256))
-(test 65536 (id 65536))
-(test -65536 (id -65536))
-(test 4294967296 (id 4294967296 ))
-(test -4294967296 (id -4294967296 ))
-
-(test 1.0 (id 1.0))
-(test -1.0 (id -1.0))
-(test (/ 3) (id (/ 3)))
-(test (/ -3) (id (/ -3)))
-
-(test #\a (id #\a))
-
-(test "" (id ""))
-(test (make-string 1 #\a) (id (make-string 1 #\a)))
-(test (make-string 32 #\a) (id (make-string 32 #\a)))
-(test (make-string 256 #\a) (id (make-string 256 #\a)))
-(test (make-string 65536 #\a) (id (make-string 65536 #\a)))
-
-(test () (id ()))
-(test (make-list 1 1) (id (make-list 1 1)))
-(test (make-list 16 1) (id (make-list 16 1)))
-#;(test (make-list 65536 1) (id (make-list 65536 1)))
-
-(test #() (id #()))
-(test (make-vector 1 1) (id (make-vector 1 1)))
-(test (make-vector 16 1) (id (make-vector 16 1)))
-(test (make-vector 65536 1) (id (make-vector 65536 1)))
-
-(test #u8() (id #u8()))
-(test (make-bytevector 1 1) (id (make-bytevector 1 1)))
-(test (make-bytevector 16 1) (id (make-bytevector 16 1)))
-(test (make-bytevector 256 1) (id (make-bytevector 256 1)))
-(test (make-bytevector 65536 1) (id (make-bytevector 65536 1)))

t/r7rs-tests.scm

@@ -919,6 +919,16 @@
 (test 1 (exact 1.0))
 (test #t (exact? (exact 1.0)))
 
+(test "10" (number->string 10))
+(test "10" (number->string 10 10))
+(test "10" (number->string 2 2))
+(test "10" (number->string 8 8))
+(test "10" (number->string 16 16))
+
+(test "2.3" (number->string 2.3))
+(test "2.3" (number->string 2.30))
+(test "2.301" (number->string 2.301))
+
 (test 100 (string->number "100"))
 (test 256 (string->number "100" 16))
 (test 100.0 (string->number "1e2"))