Merge pull request #237 from picrin-scheme/submodule2subtree

Control benz under git subtree rather than git submodule

.gitmodules

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

extlib/benz

@@ -1 +0,0 @@
-Subproject commit 569b1ace02e6a066b21f94dff23c4e01b8748bf0

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