Status note

Closes https://github.com/picrin-scheme/picrin/issues/355

Signed-off-by: Masanori Ogino <167209+omasanori@users.noreply.github.com>

.gitignore

@@ -1,6 +1,10 @@
 *.o
-src/load_piclib.c
+bin/
+lib/libpicrin.a
+lib/mini-picrin
 src/init_contrib.c
+src/init_lib.c
+src/load_piclib.c
 docs/contrib.rst
 .dir-locals.el
 GPATH

Makefile

@@ -1,34 +1,7 @@
-LIBPICRIN_SRCS = \
-	lib/blob.c\
-	lib/bool.c\
-	lib/char.c\
-	lib/cont.c\
-	lib/data.c\
-	lib/debug.c\
-	lib/dict.c\
-	lib/error.c\
-	lib/gc.c\
-	lib/number.c\
-	lib/pair.c\
-	lib/port.c\
-	lib/proc.c\
-	lib/record.c\
-	lib/state.c\
-	lib/string.c\
-	lib/symbol.c\
-	lib/var.c\
-	lib/vector.c\
-	lib/weak.c\
-	lib/ext/boot.c\
-	lib/ext/eval.c\
-	lib/ext/lib.c\
-	lib/ext/load.c\
-	lib/ext/read.c\
-	lib/ext/write.c
-LIBPICRIN_OBJS = $(LIBPICRIN_SRCS:.c=.o)
-
 PICRIN_SRCS = \
 	src/main.c\
+	src/init_lib.c\
+	src/lib.c\
 	src/load_piclib.c\
 	src/init_contrib.c
 PICRIN_OBJS = \
@@ -37,7 +10,6 @@ PICRIN_OBJS = \
 CONTRIB_SRCS =
 CONTRIB_OBJS = $(CONTRIB_SRCS:.c=.o)
 CONTRIB_LIBS =
-CONTRIB_DEFS =
 CONTRIB_INITS =
 CONTRIB_TESTS =
 CONTRIB_DOCS = $(wildcard contrib/*/docs/*.rst)
@@ -46,22 +18,43 @@ REPL_ISSUE_TESTS = $(wildcard t/issue/*.sh)
 
 TEST_RUNNER = picrin
 
-CFLAGS += -I./lib/include -Wall -Wextra
+CFLAGS += -I./lib/include -I./include -Wall -Wextra
 LDFLAGS += -lm
 
 prefix ?= /usr/local
 
-all: CFLAGS += -O2 -DNDEBUG=1
-all: picrin
+all: CFLAGS += -O2 -g -DNDEBUG=1
+all: bootstrap picrin
 
 debug: CFLAGS += -O0 -g
-debug: picrin
+debug: bootstrap picrin
 
 include $(sort $(wildcard contrib/*/nitro.mk))
 
-picrin: CFLAGS += $(CONTRIB_DEFS)
-picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) $(LIBPICRIN_OBJS)
-	$(CC) $(CFLAGS) -o $@ $(PICRIN_OBJS) $(CONTRIB_OBJS) $(LIBPICRIN_OBJS) $(LDFLAGS)
+bootstrap: bin/picrin-bootstrap
+
+bin/picrin-bootstrap:
+	test -f bin/picrin-bootstrap || { $(MAKE) -C lib mini-picrin && cp lib/mini-picrin bin/picrin-bootstrap; }
+
+lib/mini-picrin: FORCE
+	$(MAKE) -C lib mini-picrin
+
+lib/libpicrin.a: FORCE
+	$(MAKE) -C lib libpicrin.a
+
+ext: lib/ext/eval.c lib/ext/error.c
+
+lib/ext/eval.c: piclib/eval.scm
+	bin/picrin-bootstrap -c eval_rom piclib/eval.scm | bin/picrin-bootstrap tools/mkeval.scm > lib/ext/eval.c
+
+lib/ext/error.c: piclib/error.scm
+	bin/picrin-bootstrap -c error_rom piclib/error.scm | bin/picrin-bootstrap tools/mkerror.scm > lib/ext/error.c
+
+picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) ext lib/libpicrin.a
+	$(CC) $(CFLAGS) -o $@ $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libpicrin.a $(LDFLAGS)
+
+src/init_lib.c: piclib/library.scm
+	bin/picrin-bootstrap -c lib_rom piclib/library.scm | bin/picrin-bootstrap tools/mklib.scm > src/init_lib.c
 
 src/load_piclib.c: $(CONTRIB_LIBS)
 	perl tools/mkloader.pl $(CONTRIB_LIBS) > $@
@@ -69,14 +62,7 @@ src/load_piclib.c: $(CONTRIB_LIBS)
 src/init_contrib.c:
 	perl tools/mkinit.pl $(CONTRIB_INITS) > $@
 
-# FIXME: Undefined symbols error for _emyg_atod and _emyg_dtoa
-# libpicrin.so: $(LIBPICRIN_OBJS)
-# 	$(CC) -shared $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) $(LDFLAGS)
-
-lib/ext/boot.c: piclib/boot.scm piclib/library.scm
-	cat piclib/boot.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c
-
-$(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h
+$(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/*.h lib/include/picrin/*.h lib/*.h include/picrin/*.h
 
 doc: docs/*.rst docs/contrib.rst
 	$(MAKE) -C docs html
@@ -93,8 +79,8 @@ test: test-contribs test-nostdlib test-issue
 
 test-contribs: picrin $(CONTRIB_TESTS)
 
-test-nostdlib: lib/ext/boot.c
-	$(CC) -I./lib -I./lib/include -D'PIC_USE_LIBC=0' -D'PIC_USE_STDIO=0' -D'PIC_USE_WRITE=0' -ffreestanding -nostdlib -Os -fPIC -shared -std=c89 -pedantic -Wall -Wextra -Werror -o libpicrin-tiny.so $(LIBPICRIN_SRCS) etc/libc_polyfill.c -fno-stack-protector
+test-nostdlib: ext
+	$(CC) -I./lib/include -Os -DPIC_USE_LIBC=0 -DPIC_USE_CALLCC=0 -DPIC_USE_FILE=0 -DPIC_USE_READ=0 -DPIC_USE_WRITE=0 -DPIC_USE_EVAL=0 -nostdlib -ffreestanding -fno-stack-protector -shared -pedantic -std=c89 -Wall -Wextra -Werror -o libpicrin-tiny.so $(wildcard lib/*.c)
 	strip libpicrin-tiny.so
 	ls -lh libpicrin-tiny.so
 	rm -f libpicrin-tiny.so
@@ -118,11 +104,13 @@ install: all
 	install -c picrin $(prefix)/bin/picrin
 
 clean:
+	$(MAKE) -C lib clean
 	$(RM) picrin
-	$(RM) src/load_piclib.c src/init_contrib.c lib/ext/boot.c
-	$(RM) libpicrin.so libpicrin-tiny.so
-	$(RM) $(LIBPICRIN_OBJS)
+	$(RM) src/load_piclib.c src/init_contrib.c src/init_lib.c
+	$(RM) libpicrin-tiny.so
 	$(RM) $(PICRIN_OBJS)
 	$(RM) $(CONTRIB_OBJS)
 
-.PHONY: all install clean push test test-r7rs test-contribs test-issue test-picrin-issue test-repl-issue doc $(CONTRIB_TESTS) $(REPL_ISSUE_TESTS)
+FORCE:
+
+.PHONY: all bootstrap ext install clean push test test-r7rs test-contribs test-issue test-picrin-issue test-repl-issue doc $(CONTRIB_TESTS) $(REPL_ISSUE_TESTS)

README.md

@@ -1,5 +1,7 @@
 <img width="500" src="https://raw.githubusercontent.com/picrin-scheme/picrin/master/etc/picrin-logo-fin01-02.png"></img>
 
+# The project is in hiatus and being archived soon...
+
 [![Build Status](https://travis-ci.org/picrin-scheme/picrin.png?branch=master)](https://travis-ci.org/picrin-scheme/picrin)
 [![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/)
 

contrib/10.attribute/attr.scm

@@ -1,13 +1,10 @@
 (define-library (picrin base)
+  (export attribute)
 
-  (define attribute-table (make-ephemeron-table))
+  (define attribute-table (make-attribute))
 
   (define (attribute obj)
-    (let ((r (attribute-table obj)))
-      (if r
-          (cdr r)
-          (let ((dict (make-dictionary)))
-            (attribute-table obj dict)
-            dict))))
-
-  (export attribute))
+    (or (attribute-table obj)
+        (let ((dict (make-dictionary)))
+          (attribute-table obj dict)
+          dict))))

contrib/10.macro/macro.scm

@@ -13,12 +13,13 @@
   ;; simple macro
 
   (export define-syntax
+          let-syntax letrec-syntax
           syntax-quote
           syntax-quasiquote
           syntax-unquote
           syntax-unquote-splicing)
 
-  ;; misc transformers
+  ;; other transformers
 
   (export call-with-current-environment
           make-syntactic-closure
@@ -30,24 +31,184 @@
           ir-macro-transformer)
 
 
+  ;; environment extraction
+
+
   (define-macro call-with-current-environment
     (lambda (form env)
       `(,(cadr form) ',env)))
 
 
+  ;; simple macro
+
+
+  (define-macro define-auxiliary-syntax
+    (lambda (form _)
+      `(define-macro ,(cadr form)
+         (lambda _
+           (error "invalid use of auxiliary syntax" ',(cadr form))))))
+
+  (define-auxiliary-syntax syntax-unquote)
+  (define-auxiliary-syntax syntax-unquote-splicing)
+
+  (define (transformer f)
+    (lambda (form env)
+      (let ((attr1 (make-attribute))
+            (attr2 (make-attribute)))
+        (letrec
+            ((wrap (lambda (var1)
+                     (or (attr1 var1)
+                         (let ((var2 (make-identifier var1 env)))
+                           (attr1 var1 var2)
+                           (attr2 var2 var1)
+                           var2))))
+             (unwrap (lambda (var2)
+                       (or (attr2 var2)
+                           var2)))
+             (walk (lambda (f form)
+                     (cond
+                      ((identifier? form)
+                       (f form))
+                      ((pair? form)
+                       (cons (walk f (car form)) (walk f (cdr form))))
+                      (else
+                       form)))))
+          (let ((form (cdr form)))
+            (walk unwrap (apply f (walk wrap form))))))))
+
+  (define (the var)
+    (call-with-current-environment
+     (lambda (env)
+       (make-identifier var env))))
+
+  (define-macro syntax-quote
+    (lambda (form env)
+      (let ((renames '()))
+        (letrec
+            ((rename (lambda (var)
+                       (let ((x (assq var renames)))
+                         (if x
+                             (cadr x)
+                             (begin
+                               (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
+                               (rename var))))))
+             (walk (lambda (f form)
+                     (cond
+                      ((identifier? form)
+                       (f form))
+                      ((pair? form)
+                       `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))
+                      (else
+                       `(,(the 'quote) ,form))))))
+          (let ((form (walk rename (cadr form))))
+            `(,(the 'let)
+              ,(map cdr renames)
+              ,form))))))
+
+  (define-macro syntax-quasiquote
+    (lambda (form env)
+      (let ((renames '()))
+        (letrec
+            ((rename (lambda (var)
+                       (let ((x (assq var renames)))
+                         (if x
+                             (cadr x)
+                             (begin
+                               (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
+                               (rename var)))))))
+
+          (define (syntax-quasiquote? form)
+            (and (pair? form)
+                 (identifier? (car form))
+                 (identifier=? (the 'syntax-quasiquote) (make-identifier (car form) env))))
+
+          (define (syntax-unquote? form)
+            (and (pair? form)
+                 (identifier? (car form))
+                 (identifier=? (the 'syntax-unquote) (make-identifier (car form) env))))
+
+          (define (syntax-unquote-splicing? form)
+            (and (pair? form)
+                 (pair? (car form))
+                 (identifier? (caar form))
+                 (identifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
+
+          (define (qq depth expr)
+            (cond
+             ;; syntax-unquote
+             ((syntax-unquote? expr)
+              (if (= depth 1)
+                  (car (cdr expr))
+                  (list (the 'list)
+                        (list (the 'quote) (the 'syntax-unquote))
+                        (qq (- depth 1) (car (cdr expr))))))
+             ;; syntax-unquote-splicing
+             ((syntax-unquote-splicing? expr)
+              (if (= depth 1)
+                  (list (the 'append)
+                        (car (cdr (car expr)))
+                        (qq depth (cdr expr)))
+                  (list (the 'cons)
+                        (list (the 'list)
+                              (list (the 'quote) (the 'syntax-unquote-splicing))
+                              (qq (- depth 1) (car (cdr (car expr)))))
+                        (qq depth (cdr expr)))))
+             ;; syntax-quasiquote
+             ((syntax-quasiquote? expr)
+              (list (the 'list)
+                    (list (the 'quote) (the 'quasiquote))
+                    (qq (+ depth 1) (car (cdr expr)))))
+             ;; list
+             ((pair? expr)
+              (list (the 'cons)
+                    (qq depth (car expr))
+                    (qq depth (cdr expr))))
+             ;; identifier
+             ((identifier? expr)
+              (rename expr))
+             ;; simple datum
+             (else
+              (list (the 'quote) expr))))
+
+          (let ((body (qq 1 (cadr form))))
+            `(,(the 'let)
+              ,(map cdr renames)
+              ,body))))))
+
+  (define-macro define-syntax
+    (lambda (form env)
+      (let ((formal (car (cdr form)))
+            (body   (cdr (cdr form))))
+        (if (pair? formal)
+            `(,(the 'define-syntax) ,(car formal) (,(the 'lambda) ,(cdr formal) ,@body))
+            `(,(the 'define-macro) ,formal (,(the 'transformer) (,(the 'begin) ,@body)))))))
+
+  (define-macro letrec-syntax
+    (lambda (form env)
+      (let ((formal (car (cdr form)))
+            (body   (cdr (cdr form))))
+        `(let ()
+           ,@(map (lambda (x)
+                    `(,(the 'define-syntax) ,(car x) ,(cadr x)))
+                  formal)
+           ,@body))))
+
+  (define-macro let-syntax
+    (lambda (form env)
+      `(,(the 'letrec-syntax) ,@(cdr form))))
+
+
   ;; syntactic closure
 
 
   (define (make-syntactic-closure env free form)
     (letrec
-        ((wrap (let ((ephemeron (make-ephemeron-table)))
+        ((wrap (let ((attr (make-attribute)))
                  (lambda (var)
-                   (let ((id (ephemeron var)))
-                     (if id
-                         (cdr id)
-                         (let ((id (make-identifier var env)))
-                           (ephemeron var id)
-                           id))))))
+                   (or (attr var)
+                       (let ((id (make-identifier var env)))
+                         (attr var id)
+                         id)))))
          (walk (lambda (f form)
                  (cond
                   ((identifier? form)
@@ -102,14 +263,12 @@
   (define (er-transformer f)
     (lambda (form use-env mac-env)
       (letrec
-          ((rename (let ((ephemeron (make-ephemeron-table)))
+          ((rename (let ((attr (make-attribute)))
                      (lambda (var)
-                       (let ((id (ephemeron var)))
-                         (if id
-                             (cdr id)
-                             (let ((id (make-identifier var mac-env)))
-                               (ephemeron var id)
-                               id))))))
+                       (or (attr var)
+                           (let ((id (make-identifier var mac-env)))
+                             (attr var id)
+                             id)))))
            (compare (lambda (x y)
                       (identifier=?
                        (make-identifier x use-env)
@@ -118,38 +277,30 @@
 
   (define (ir-transformer f)
     (lambda (form use-env mac-env)
-      (let ((ephemeron1 (make-ephemeron-table))
-            (ephemeron2 (make-ephemeron-table)))
+      (let ((attr1 (make-attribute))
+            (attr2 (make-attribute)))
         (letrec
             ((inject (lambda (var1)
-                       (let ((var2 (ephemeron1 var1)))
-                         (if var2
-                             (cdr var2)
-                             (let ((var2 (make-identifier var1 use-env)))
-                               (ephemeron1 var1 var2)
-                               (ephemeron2 var2 var1)
-                               var2)))))
-             (rename (let ((ephemeron (make-ephemeron-table)))
+                       (or (attr1 var1)
+                           (let ((var2 (make-identifier var1 use-env)))
+                             (attr1 var1 var2)
+                             (attr2 var2 var1)
+                             var2))))
+             (rename (let ((attr (make-attribute)))
                        (lambda (var)
-                         (let ((id (ephemeron var)))
-                           (if id
-                               (cdr id)
-                               (let ((id (make-identifier var mac-env)))
-                                 (ephemeron var id)
-                                 id))))))
+                         (or (attr var)
+                             (let ((id (make-identifier var mac-env)))
+                               (attr var id)
+                               id)))))
              (flip (lambda (var2) ; unwrap if injected, wrap if not injected
-                     (let ((var1 (ephemeron2 var2)))
-                       (if var1
-                           (cdr var1)
-                           (rename var2)))))
+                     (or (attr2 var2)
+                         (rename var2))))
              (walk (lambda (f form)
                      (cond
                       ((identifier? form)
                        (f form))
                       ((pair? form)
                        (cons (walk f (car form)) (walk f (cdr form))))
-                      ((vector? form)
-                       (list->vector (walk f (vector->list form))))
                       (else
                        form))))
              (compare (lambda (x y)

contrib/10.math/math.c

@@ -1,5 +1,6 @@
 #include "picrin.h"
 #include "picrin/extra.h"
+#include "picrin/lib.h"
 
 #include <math.h>
 
@@ -283,7 +284,7 @@ pic_number_expt(pic_state *pic)
 }
 
 void
-pic_init_math(pic_state *pic)
+pic_nitro_init_math(pic_state *pic)
 {
   pic_deflibrary(pic, "picrin.math");
   pic_in_library(pic, "picrin.math");

contrib/10.roundtrip/emyg.c

@@ -0,0 +1,150 @@
+#include "picrin.h"
+
+#include "emyg_dtoa.h"
+#include "emyg_atod.h"
+
+static int
+int2str(long x, int base, char *buf)
+{
+  static const char digits[36] = "0123456789abcdefghijklmnopqrstuvwxyz";
+  int i, neg, len;
+
+  neg = 0;
+  if (x < 0) {
+    neg = 1;
+    x = -x;
+  }
+
+  i = 0;
+  do {
+    buf[i++] = digits[x % base];
+  } while ((x /= base) != 0);
+
+  if (neg) {
+    buf[i++] = '-';
+  }
+  buf[i] = '\0';
+  len = i;
+
+  for (i = 0; i < len / 2; ++i) {
+    char tmp = buf[i];
+    buf[i] = buf[len - i - 1];
+    buf[len - i - 1] = tmp;
+  }
+  return len;
+}
+
+static pic_value
+emyg_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_error(pic, "invalid radix (between 2 and 36, inclusive)", 1, pic_int_value(pic, radix));
+  }
+
+  if (e) {
+    char buf[sizeof(int) * CHAR_BIT + 3];
+    int len = int2str((int) f, radix, buf);
+    return pic_str_value(pic, buf, len);
+  }
+  else {
+    char buf[64];
+    emyg_dtoa(f, buf);
+    return pic_cstr_value(pic, buf);
+  }
+}
+
+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
+string_to_number(pic_state *pic, const char *str)
+{
+  double flt;
+  const char *c = str;
+  bool isint = 1;
+
+  if (*c == '+' || *c == '-')
+    c++;
+
+  if (! isdigit(*c++)) {
+    return pic_false_value(pic);
+  }
+  while (isdigit(*c)) c++;
+
+  if (*c == '.') {
+    isint = false;
+    c++;
+    while (isdigit(*c)) c++;
+  }
+  if (*c == 'e' || *c == 'E') {
+    isint = false;
+    c++;
+    if (*c == '+' || *c == '-')
+      c++;
+    if (! isdigit(*c++)) {
+      return pic_false_value(pic);
+    }
+    while (isdigit(*c)) c++;
+  }
+
+  if (*c != '\0') {
+    return pic_false_value(pic);
+  }
+
+  flt = emyg_atod(str);
+
+  if (isint && INT_MIN <= flt && flt <= INT_MAX) {
+    return pic_int_value(pic, flt);
+  } else {
+    return pic_float_value(pic, flt);
+  }
+}
+
+static pic_value
+emyg_string_to_number(pic_state *pic)
+{
+  const char *str;
+  int radix = 10;
+  long num;
+  char *eptr;
+
+  pic_get_args(pic, "z|i", &str, &radix);
+
+  if (strcaseeq(str, "+inf.0"))
+    return pic_float_value(pic, 1.0 / 0.0);
+  if (strcaseeq(str, "-inf.0"))
+    return pic_float_value(pic, -1.0 / 0.0);
+  if (strcaseeq(str, "+nan.0"))
+    return pic_float_value(pic, 0.0 / 0.0);
+  if (strcaseeq(str, "-nan.0"))
+    return pic_float_value(pic, -0.0 / 0.0);
+
+  num = strtol(str, &eptr, radix);
+  if (*eptr == '\0') {
+    return INT_MIN <= num && num <= INT_MAX ? pic_int_value(pic, num) : pic_float_value(pic, num);
+  }
+
+  return string_to_number(pic, str);
+}
+
+void
+pic_nitro_init_roundtrip(pic_state *PIC_UNUSED(pic))
+{
+  pic_set(pic, "number->string", pic_lambda(pic, emyg_number_to_string, 0));
+  pic_set(pic, "string->number", pic_lambda(pic, emyg_string_to_number, 0));
+}

contrib/10.roundtrip/nitro.mk

@@ -1,7 +1,8 @@
-CONTRIB_DEFS += -DPIC_CSTRING_TO_DOUBLE=emyg_atod -DPIC_DOUBLE_TO_CSTRING=emyg_dtoa
+CONTRIB_INITS += roundtrip
 
 CONTRIB_SRCS += contrib/10.roundtrip/emyg_dtoa.c \
-                contrib/10.roundtrip/emyg_atod.c
+                contrib/10.roundtrip/emyg_atod.c \
+		contrib/10.roundtrip/emyg.c
 
 CONTRIB_TESTS += test-roundtrip
 

contrib/20.r7rs/nitro.mk

@@ -2,7 +2,6 @@ CONTRIB_INITS += r7rs
 
 CONTRIB_SRCS += \
 	contrib/20.r7rs/src/r7rs.c\
-	contrib/20.r7rs/src/file.c\
 	contrib/20.r7rs/src/load.c\
 	contrib/20.r7rs/src/system.c\
 	contrib/20.r7rs/src/time.c

contrib/20.r7rs/scheme/eval.scm

@@ -1,5 +1,6 @@
 (define-library (scheme eval)
-  (import (picrin base))
+  (import (picrin base)
+          (picrin macro))
 
   (define counter 0)
 

contrib/20.r7rs/scheme/load.scm

@@ -1,4 +1,2 @@
 (define-library (scheme load)
-  (import (picrin base))
-
   (export load))

contrib/20.r7rs/src/file.c

@@ -1,87 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/extra.h"
-
-#include <stdio.h>
-
-PIC_NORETURN static void
-file_error(pic_state *pic, const char *msg)
-{
-  pic_raise(pic, pic_make_error(pic, "file", msg, pic_nil_value(pic)));
-}
-
-static pic_value
-open_file(pic_state *pic, const char *fname, const char *mode)
-{
-  FILE *fp;
-
-  if ((fp = fopen(fname, mode)) == NULL) {
-    file_error(pic, "could not open file...");
-  }
-  return pic_fopen(pic, fp, mode);
-}
-
-pic_value
-pic_file_open_input_file(pic_state *pic)
-{
-  char *fname;
-
-  pic_get_args(pic, "z", &fname);
-
-  return open_file(pic, fname, "r");
-}
-
-pic_value
-pic_file_open_output_file(pic_state *pic)
-{
-  char *fname;
-
-  pic_get_args(pic, "z", &fname);
-
-  return open_file(pic, fname, "w");
-}
-
-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(pic);
-  } else {
-    return pic_false_value(pic);
-  }
-}
-
-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_undef_value(pic);
-}
-
-void
-pic_init_file(pic_state *pic)
-{
-  pic_defun(pic, "scheme.base:open-input-file", pic_file_open_input_file); /* for `include' */
-  pic_defun(pic, "scheme.file:open-input-file", pic_file_open_input_file);
-  pic_defun(pic, "scheme.file:open-binary-input-file", pic_file_open_input_file);
-  pic_defun(pic, "scheme.file:open-output-file", pic_file_open_output_file);
-  pic_defun(pic, "scheme.file:open-binary-output-file", pic_file_open_output_file);
-  pic_defun(pic, "scheme.file:file-exists?", pic_file_exists_p);
-  pic_defun(pic, "scheme.file:delete-file", pic_file_delete);
-}

contrib/20.r7rs/src/load.c

@@ -10,7 +10,7 @@
 static pic_value
 pic_load_load(pic_state *pic)
 {
-  pic_value envid, port;
+  pic_value envid, port, e;
   char *fn;
   FILE *fp;
 
@@ -22,16 +22,28 @@ pic_load_load(pic_state *pic)
   }
 
   port = pic_fopen(pic, fp, "r");
+  pic_try {
+    size_t ai = pic_enter(pic);
 
-  pic_load(pic, port);
-
+    while (1) {
+      pic_value form = pic_funcall(pic, "read", 1, port);
+      if (pic_eof_p(pic, form))
+        break;
+      pic_funcall(pic, "eval", 1, form);
+      pic_leave(pic, ai);
+    }
+  }
+  pic_catch (e) {
+    pic_fclose(pic, port);
+    pic_raise(pic, e);
+  }
   pic_fclose(pic, port);
 
   return pic_undef_value(pic);
 }
 
 void
-pic_init_load(pic_state *pic)
+pic_nitro_init_load(pic_state *pic)
 {
   pic_defun(pic, "scheme.load:load", pic_load_load);
 }

contrib/20.r7rs/src/r7rs.c

@@ -4,18 +4,16 @@
 
 #include "picrin.h"
 
-void pic_init_file(pic_state *);
-void pic_init_load(pic_state *);
-void pic_init_system(pic_state *);
-void pic_init_time(pic_state *);
+void pic_nitro_init_load(pic_state *);
+void pic_nitro_init_system(pic_state *);
+void pic_nitro_init_time(pic_state *);
 
 void
-pic_init_r7rs(pic_state *pic)
+pic_nitro_init_r7rs(pic_state *pic)
 {
-  pic_init_file(pic);
-  pic_init_load(pic);
-  pic_init_system(pic);
-  pic_init_time(pic);
+  pic_nitro_init_load(pic);
+  pic_nitro_init_system(pic);
+  pic_nitro_init_time(pic);
 
   pic_add_feature(pic, "r7rs");
 }

contrib/20.r7rs/src/system.c

@@ -99,7 +99,7 @@ pic_system_getenvs(pic_state *pic)
       ;
 
     key = pic_str_value(pic, *envp, i);
-    val = pic_cstr_value(pic, getenv(pic_str(pic, key, NULL)));
+    val = pic_cstr_value(pic, getenv(pic_cstr(pic, key, NULL)));
 
     /* push */
     data = pic_cons(pic, pic_cons(pic, key, val), data);
@@ -112,7 +112,7 @@ pic_system_getenvs(pic_state *pic)
 }
 
 void
-pic_init_system(pic_state *pic)
+pic_nitro_init_system(pic_state *pic)
 {
   pic_defun(pic, "scheme.process-context:command-line", pic_system_cmdline);
   pic_defun(pic, "scheme.process-context:exit", pic_system_exit);

contrib/20.r7rs/src/time.c

@@ -40,7 +40,7 @@ pic_jiffies_per_second(pic_state *pic)
 }
 
 void
-pic_init_time(pic_state *pic)
+pic_nitro_init_time(pic_state *pic)
 {
   pic_defun(pic, "scheme.time:current-second", pic_current_second);
   pic_defun(pic, "scheme.time:current-jiffy", pic_current_jiffy);

contrib/30.random/src/random.c

@@ -1,5 +1,6 @@
 #include "picrin.h"
 #include "picrin/extra.h"
+#include "picrin/lib.h"
 
 double genrand_real3(void);
 
@@ -12,7 +13,7 @@ pic_random_real(pic_state *pic)
 }
 
 void
-pic_init_random(pic_state *pic)
+pic_nitro_init_random(pic_state *pic)
 {
   pic_deflibrary(pic, "srfi.27");
   pic_in_library(pic, "srfi.27");

contrib/30.readline/src/readline.c

@@ -7,6 +7,7 @@ forget to use the C++ extern "C" to get it to compile.
 */
 #include "picrin.h"
 #include "picrin/extra.h"
+#include "picrin/lib.h"
 
 #include <editline/readline.h>
 
@@ -241,7 +242,7 @@ pic_rl_history_expand(pic_state *pic)
 }
 
 void
-pic_init_readline(pic_state *pic){
+pic_nitro_init_readline(pic_state *pic){
   using_history();
 
   pic_deflibrary(pic, "picrin.readline");

contrib/30.regexp/src/regexp.c

@@ -1,5 +1,6 @@
 #include "picrin.h"
 #include "picrin/extra.h"
+#include "picrin/lib.h"
 
 #include <regex.h>
 
@@ -165,7 +166,7 @@ pic_regexp_regexp_replace(pic_state *pic)
 }
 
 void
-pic_init_regexp(pic_state *pic)
+pic_nitro_init_regexp(pic_state *pic)
 {
   pic_deflibrary(pic, "picrin.regexp");
   pic_in_library(pic, "picrin.regexp");

contrib/40.srfi/src/0.c

@@ -1,7 +1,7 @@
 #include "picrin.h"
 
 void
-pic_init_srfi_0(pic_state *pic)
+pic_nitro_init_srfi_0(pic_state *pic)
 {
     pic_add_feature(pic, "srfi-0");
     pic_add_feature(pic, "srfi-1");

contrib/40.srfi/src/106.c

@@ -353,7 +353,7 @@ pic_socket_call_with_socket(pic_state *pic)
 }
 
 void
-pic_init_srfi_106(pic_state *pic)
+pic_nitro_init_srfi_106(pic_state *pic)
 {
   pic_defun(pic, "srfi.106:socket?", pic_socket_socket_p);
   pic_defun(pic, "srfi.106:make-socket", pic_socket_make_socket);

contrib/60.repl/repl.c

@@ -12,7 +12,7 @@ pic_repl_tty_p(pic_state *pic)
 }
 
 void
-pic_init_repl(pic_state *pic)
+pic_nitro_init_repl(pic_state *pic)
 {
   pic_defun(pic, "picrin.repl:tty?", pic_repl_tty_p);
 }

contrib/60.repl/repl.scm

@@ -20,8 +20,10 @@
         #f))))
 
   (define (init-env)
+    (current-library '(picrin user))
     (eval
-     '(import (scheme base)
+     '(import (picrin base)
+              (scheme base)
               (scheme load)
               (scheme process-context)
               (scheme read)
@@ -33,6 +35,7 @@
               (scheme time)
               (scheme eval)
               (scheme r5rs)
+              (picrin pretty-print)
               (picrin macro))
      '(picrin user)))
 

contrib/70.main/main.scm

@@ -5,7 +5,6 @@
           (scheme process-context)
           (scheme load)
           (scheme eval)
-          (picrin base)
           (picrin repl))
 
   (define (print-help)
@@ -41,7 +40,7 @@
       (lambda (in)
         (let loop ((expr (read in)))
           (unless (eof-object? expr)
-            (eval expr (find-library "picrin.user"))
+            (eval expr '(picrin user))
             (loop (read in)))))))
 
   (define (main)

docs/intro.rst

@@ -26,11 +26,6 @@ Documentation
 
 See http://picrin.readthedocs.org/
 
-IRC
----
-
-There is a chat room on chat.freenode.org, channel #picrin. IRC logs here: https://botbot.me/freenode/picrin/
-
 LICENSE
 -------
 

include/picrin/lib.h

@@ -0,0 +1,24 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#ifndef PICRIN_LIB_H
+#define PICRIN_LIB_H
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+/*
+ * library
+ */
+
+void pic_deflibrary(pic_state *, const char *lib);
+void pic_in_library(pic_state *, const char *lib);
+void pic_export(pic_state *, int n, ...);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

lib/Makefile

@@ -0,0 +1,52 @@
+LIBPICRIN_SRCS = \
+	attr.c\
+	blob.c\
+	bool.c\
+	char.c\
+	data.c\
+	dict.c\
+	gc.c\
+	number.c\
+	pair.c\
+	proc.c\
+	record.c\
+	state.c\
+	string.c\
+	symbol.c\
+	value.c\
+	var.c\
+	vector.c\
+	ext/cont.c\
+	ext/eval.c\
+	ext/port.c\
+	ext/read.c\
+	ext/write.c\
+	ext/file.c\
+	ext/error.c
+LIBPICRIN_OBJS = \
+	$(LIBPICRIN_SRCS:.c=.o)
+
+LIBPICRIN_HEADERS = \
+	include/picrin.h\
+	include/picconf.h\
+	include/picrin/extra.h\
+	include/picrin/setup.h\
+	khash.h\
+	object.h\
+	value.h\
+	state.h
+
+override CFLAGS += -I./include -Wall -Wextra -g
+
+mini-picrin: ext/main.o libpicrin.a
+	$(CC) $(CFLAGS) -o $@ ext/main.o libpicrin.a
+
+libpicrin.a: $(LIBPICRIN_OBJS)
+	$(AR) $(ARFLAGS) $@ $(LIBPICRIN_OBJS)
+
+$(LIBPICRIN_OBJS): $(LIBPICRIN_HEADERS)
+
+clean:
+	$(RM) $(LIBPICRIN_OBJS) ext/main.o mini-picrin libpicrin.a
+
+.PHONY: clean

lib/attr.c

@@ -0,0 +1,108 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <picrin.h>
+#include "value.h"
+#include "object.h"
+
+KHASH_DEFINE(attr, struct object *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
+
+static pic_value
+attr_call(pic_state *pic)
+{
+  pic_value self, key, val;
+  int n;
+
+  n = pic_get_args(pic, "&o|o", &self, &key, &val);
+
+  if (! pic_obj_p(pic, key)) {
+    pic_error(pic, "attempted to set a non-object key", 1, key);
+  }
+
+  if (n == 1) {
+    if (! pic_attr_has(pic, self, key)) {
+      return pic_false_value(pic);
+    }
+    return pic_attr_ref(pic, self, key);
+  } else {
+    if (pic_false_p(pic, val)) {
+      if (pic_attr_has(pic, self, key)) {
+        pic_attr_del(pic, self, key);
+      }
+    } else {
+      pic_attr_set(pic, self, key, val);
+    }
+    return pic_undef_value(pic);
+  }
+}
+
+pic_value
+pic_make_attr(pic_state *pic)
+{
+  struct attr *attr;
+
+  attr = (struct attr *)pic_obj_alloc(pic, PIC_TYPE_ATTR);
+  attr->prev = NULL;
+  kh_init(attr, &attr->hash);
+  return pic_lambda(pic, attr_call, 1, obj_value(pic, attr));
+}
+
+pic_value
+pic_attr_ref(pic_state *pic, pic_value attr, pic_value key)
+{
+  khash_t(attr) *h = &attr_ptr(pic, proc_ptr(pic, attr)->env->regs[0])->hash;
+  int it;
+
+  it = kh_get(attr, h, pic_ptr(pic, key));
+  if (it == kh_end(h)) {
+    pic_error(pic, "element not found for given key", 1, key);
+  }
+  return kh_val(h, it);
+}
+
+void
+pic_attr_set(pic_state *pic, pic_value attr, pic_value key, pic_value val)
+{
+  khash_t(attr) *h = &attr_ptr(pic, proc_ptr(pic, attr)->env->regs[0])->hash;
+  int ret;
+  int it;
+
+  it = kh_put(attr, h, pic_ptr(pic, key), &ret);
+  kh_val(h, it) = val;
+}
+
+bool
+pic_attr_has(pic_state *pic, pic_value attr, pic_value key)
+{
+  khash_t(attr) *h = &attr_ptr(pic, proc_ptr(pic, attr)->env->regs[0])->hash;
+
+  return kh_get(attr, h, pic_ptr(pic, key)) != kh_end(h);
+}
+
+void
+pic_attr_del(pic_state *pic, pic_value attr, pic_value key)
+{
+  khash_t(attr) *h = &attr_ptr(pic, proc_ptr(pic, attr)->env->regs[0])->hash;
+  int it;
+
+  it = kh_get(attr, h, pic_ptr(pic, key));
+  if (it == kh_end(h)) {
+    pic_error(pic, "element not found for given key", 1, key);
+  }
+  kh_del(attr, h, it);
+}
+
+static pic_value
+pic_attr_make_attribute(pic_state *pic)
+{
+  pic_get_args(pic, "");
+
+  return pic_make_attr(pic);
+}
+
+void
+pic_init_attr(pic_state *pic)
+{
+  pic_defun(pic, "make-attribute", pic_attr_make_attribute);
+}

lib/blob.c

@@ -2,15 +2,223 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 
+static void dump1(unsigned char c, unsigned char *buf, int *len) {
+  if (buf) {
+    buf[*len] = c;
+  }
+  *len = *len + 1;
+}
+
+static void dump4(unsigned long n, unsigned char *buf, int *len) {
+  assert(sizeof(long) * CHAR_BIT <= 32 || n <= 0xfffffffful);
+
+  dump1((n & 0xff), buf, len);
+  dump1((n & 0xff00) >> 8, buf, len);
+  dump1((n & 0xff0000) >> 16, buf, len);
+  dump1((n & 0xff000000) >> 24, buf, len);
+}
+
+static void dump_obj(pic_state *pic, pic_value obj, unsigned char *buf, int *len);
+
+#define IREP_FLAGS_MASK (IREP_VARG)
+
+static void
+dump_irep(pic_state *pic, struct irep *irep, unsigned char *buf, int *len)
+{
+  size_t i;
+  dump1(irep->argc, buf, len);
+  dump1(irep->flags & IREP_FLAGS_MASK, buf, len);
+  dump1(irep->frame_size, buf, len);
+  dump1(irep->irepc, buf, len);
+  dump1(irep->objc, buf, len);
+  dump4(irep->codec, buf, len);
+  for (i = 0; i < irep->objc; ++i) {
+    dump_obj(pic, irep->obj[i], buf, len);
+  }
+  for (i = 0; i < irep->codec; ++i) {
+    dump1(irep->code[i], buf, len);
+  }
+  for (i = 0; i < irep->irepc; ++i) {
+    dump_irep(pic, irep->irep[i], buf, len);
+  }
+}
+
+static void
+dump_obj(pic_state *pic, pic_value obj, unsigned char *buf, int *len)
+{
+  if (pic_int_p(pic, obj)) {
+    dump1(0x00, buf, len);
+    dump4(pic_int(pic, obj), buf, len);
+  } else if (pic_str_p(pic, obj)) {
+    int l, i;
+    const char *str = pic_str(pic, obj, &l);
+    dump1(0x01, buf, len);
+    dump4(l, buf, len);
+    for (i = 0; i < l; ++i) {
+      dump1(str[i], buf, len);
+    }
+    dump1(0, buf, len);
+  } else if (pic_sym_p(pic, obj)) {
+    int l, i;
+    const char *str = pic_str(pic, pic_sym_name(pic, obj), &l);
+    dump1(0x02, buf, len);
+    dump4(l, buf, len);
+    for (i = 0; i < l; ++i) {
+      dump1(str[i], buf, len);
+    }
+    dump1(0, buf, len);
+  } else if (pic_proc_p(pic, obj)) {
+    if (pic_proc_func_p(pic, obj)) {
+      pic_error(pic, "dump: c function procedure serialization unsupported", 1, obj);
+    }
+    if (proc_ptr(pic, obj)->env) {
+      pic_error(pic, "dump: local procedure serialization unsupported", 1, obj);
+    }
+    dump1(0x03, buf, len);
+    dump_irep(pic, proc_ptr(pic, obj)->u.irep, buf, len);
+  } else if (pic_char_p(pic, obj)) {
+    dump1(0x04, buf, len);
+    dump1(pic_char(pic, obj), buf, len);
+  } else {
+    pic_error(pic, "dump: unsupported object", 1, obj);
+  }
+}
+
+pic_value
+pic_serialize(pic_state *pic, pic_value obj)
+{
+  int len = 0;
+  pic_value blob;
+  dump_obj(pic, obj, NULL, &len);
+  blob = pic_blob_value(pic, NULL, len);
+  len = 0;
+  dump_obj(pic, obj, pic_blob(pic, blob, NULL), &len);
+  return blob;
+}
+
+static void loadn(pic_state *pic, unsigned char *dst, size_t size, const unsigned char **buf, const unsigned char *end) {
+  if (*buf + size > end) {
+    pic_error(pic, "malformed bytevector", 0);
+  }
+  memcpy(dst, *buf, size);
+  *buf = *buf + size;
+}
+
+static unsigned char load1(pic_state *pic, const unsigned char **buf, const unsigned char *end) {
+  unsigned char c;
+  loadn(pic, &c, 1, buf, end);
+  return c;
+}
+
+static unsigned long load4(pic_state *pic, const unsigned char **buf, const unsigned char *end) {
+  unsigned long x = load1(pic, buf, end);
+  x += load1(pic, buf, end) << 8;
+  x += load1(pic, buf, end) << 16;
+  x += load1(pic, buf, end) << 24;
+  return x;
+}
+
+static pic_value load_obj(pic_state *pic, const unsigned char **buf, const unsigned char *end);
+
+static struct irep *
+load_irep(pic_state *pic, const unsigned char **buf, const unsigned char *end)
+{
+  unsigned char argc, flags, frame_size, irepc, objc;
+  size_t codec, i;
+  pic_value *obj;
+  unsigned char *code;
+  struct irep **irep, *ir;
+  size_t ai = pic_enter(pic);
+
+  argc = load1(pic, buf, end);
+  flags = load1(pic, buf, end);
+  frame_size = load1(pic, buf, end);
+  irepc = load1(pic, buf, end);
+  objc = load1(pic, buf, end);
+  codec = load4(pic, buf, end);
+  obj = pic_malloc(pic, sizeof(pic_value) * objc);
+  for (i = 0; i < objc; ++i) {
+    obj[i] = load_obj(pic, buf, end);
+  }
+  code = pic_malloc(pic, codec); /* TODO */
+  loadn(pic, code, codec, buf, end);
+  irep = pic_malloc(pic, sizeof(struct irep *) * irepc);
+  for (i = 0; i < irepc; ++i) {
+    irep[i] = load_irep(pic, buf, end);
+  }
+  ir = (struct irep *) pic_obj_alloc(pic, PIC_TYPE_IREP);
+  ir->argc = argc;
+  ir->flags = flags;
+  ir->frame_size = frame_size;
+  ir->irepc = irepc;
+  ir->objc = objc;
+  ir->codec = codec;
+  ir->obj = obj;
+  ir->code = code;
+  ir->irep = irep;
+  pic_leave(pic, ai);
+  pic_protect(pic, obj_value(pic, ir));
+  return ir;
+}
+
+static pic_value
+load_obj(pic_state *pic, const unsigned char **buf, const unsigned char *end)
+{
+  int type, l;
+  pic_value obj;
+  char *dat, c;
+  struct irep *irep;
+  struct proc *proc;
+  type = load1(pic, buf, end);
+  switch (type) {
+  case 0x00:
+    return pic_int_value(pic, load4(pic, buf, end));
+  case 0x01:
+    l = load4(pic, buf, end);
+    dat = pic_malloc(pic, l + 1); /* TODO */
+    loadn(pic, (unsigned char *) dat, l + 1, buf, end);
+    obj = pic_str_value(pic, dat, l);
+    pic_free(pic, dat);
+    return obj;
+  case 0x02:
+    l = load4(pic, buf, end);
+    dat = pic_malloc(pic, l + 1); /* TODO */
+    loadn(pic, (unsigned char *) dat, l + 1, buf, end);
+    obj = pic_intern_str(pic, dat, l);
+    pic_free(pic, dat);
+    return obj;
+  case 0x03:
+    irep = load_irep(pic, buf, end);
+    proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
+    proc->u.irep = irep;
+    proc->env = NULL;
+    return obj_value(pic, proc);
+  case 0x04:
+    c = load1(pic, buf, end);
+    return pic_char_value(pic, c);
+  default:
+    pic_error(pic, "load: unsupported object", 1, pic_int_value(pic, type));
+  }
+}
+
+pic_value
+pic_deserialize(pic_state *pic, pic_value blob)
+{
+  int len;
+  const unsigned char *buf = pic_blob(pic, blob, &len);
+  return load_obj(pic, &buf, buf + len);
+}
+
 pic_value
 pic_blob_value(pic_state *pic, const unsigned char *buf, int len)
 {
   struct blob *bv;
 
-  bv = (struct blob *)pic_obj_alloc(pic, sizeof(struct blob), PIC_TYPE_BLOB);
+  bv = (struct blob *)pic_obj_alloc(pic, PIC_TYPE_BLOB);
   bv->data = pic_malloc(pic, len);
   bv->len = len;
   if (buf) {
@@ -22,10 +230,11 @@ pic_blob_value(pic_state *pic, const unsigned char *buf, int len)
 unsigned char *
 pic_blob(pic_state *pic, pic_value blob, int *len)
 {
+  struct blob *bv = blob_ptr(pic, blob);
   if (len) {
-    *len = pic_blob_ptr(pic, blob)->len;
+    *len = bv->len;
   }
-  return pic_blob_ptr(pic, blob)->data;
+  return bv->data;
 }
 
 static pic_value
@@ -55,7 +264,7 @@ pic_blob_bytevector(pic_state *pic)
     TYPE_CHECK(pic, argv[i], int);
 
     if (pic_int(pic, argv[i]) < 0 || pic_int(pic, argv[i]) > 255) {
-      pic_error(pic, "byte out of range", 0);
+      pic_error(pic, "byte out of range", 1, argv[i]);
     }
 
     *data++ = (unsigned char)pic_int(pic, argv[i]);
@@ -73,7 +282,7 @@ pic_blob_make_bytevector(pic_state *pic)
   pic_get_args(pic, "i|i", &k, &b);
 
   if (b < 0 || b > 255)
-    pic_error(pic, "byte out of range", 0);
+    pic_error(pic, "byte out of range", 1, pic_int_value(pic, b));
 
   if (k < 0) {
     pic_error(pic, "make-bytevector: negative length given", 1, pic_int_value(pic, k));
@@ -118,7 +327,7 @@ pic_blob_bytevector_u8_set(pic_state *pic)
   pic_get_args(pic, "bii", &buf, &len, &k, &v);
 
   if (v < 0 || v > 255)
-    pic_error(pic, "byte out of range", 0);
+    pic_error(pic, "byte out of range", 1, pic_int_value(pic, v));
 
   VALID_INDEX(pic, len, k);
 
@@ -247,6 +456,28 @@ pic_blob_bytevector_to_list(pic_state *pic)
   return pic_reverse(pic, list);
 }
 
+static pic_value
+pic_blob_object_to_bytevector(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+
+  return pic_serialize(pic, obj);
+}
+
+static pic_value
+pic_blob_bytevector_to_object(pic_state *pic)
+{
+  pic_value blob;
+
+  pic_get_args(pic, "o", &blob);
+
+  TYPE_CHECK(pic, blob, blob);
+
+  return pic_deserialize(pic, blob);
+}
+
 void
 pic_init_blob(pic_state *pic)
 {
@@ -261,4 +492,6 @@ pic_init_blob(pic_state *pic)
   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);
+  pic_defun(pic, "bytevector->object", pic_blob_bytevector_to_object);
+  pic_defun(pic, "object->bytevector", pic_blob_object_to_bytevector);
 }

lib/bool.c

@@ -2,73 +2,26 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
-
-#if !PIC_NAN_BOXING
+#include "state.h"
 
 bool
 pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
 {
-  if (pic_type(pic, x) != pic_type(pic, y))
-    return false;
-
-  switch (pic_type(pic, x)) {
-  case PIC_TYPE_NIL:
-    return true;
-  case PIC_TYPE_TRUE: case PIC_TYPE_FALSE:
-    return pic_type(pic, x) == pic_type(pic, y);
-  default:
-    return obj_ptr(pic, x) == obj_ptr(pic, y);
-  }
+  return value_eq_p(&x, &y);
 }
 
 bool
 pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
 {
-  if (pic_type(pic, x) != pic_type(pic, y))
-    return false;
-
-  switch (pic_type(pic, x)) {
-  case PIC_TYPE_NIL:
-    return true;
-  case PIC_TYPE_TRUE: case PIC_TYPE_FALSE:
-    return pic_type(pic, x) == pic_type(pic, y);
-  case PIC_TYPE_FLOAT:
-    return pic_float(pic, x) == pic_float(pic, y);
-  case PIC_TYPE_INT:
-    return pic_int(pic, x) == pic_int(pic, y);
-  default:
-    return obj_ptr(pic, x) == obj_ptr(pic, y);
-  }
+  return value_eq_p(&x, &y);
 }
 
-#endif
-
-KHASH_DECLARE(m, void *, int)
-KHASH_DEFINE2(m, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal)
-
-static bool
-internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) *h)
+bool
+pic_equal_p(pic_state *pic, pic_value x, pic_value y)
 {
-  pic_value localx = pic_nil_value(pic);
-  pic_value localy = pic_nil_value(pic);
-  int cx = 0;
-  int cy = 0;
-
-  if (depth > 10) {
-    if (depth > 200) {
-      pic_error(pic, "stack overflow in equal", 0);
-    }
-    if (pic_pair_p(pic, x) || pic_vec_p(pic, x)) {
-      int ret;
-      kh_put(m, h, obj_ptr(pic, x), &ret);
-      if (ret != 0) {
-        return true;            /* `x' was seen already.  */
-      }
-    }
-  }
-
  LOOP:
 
   if (pic_eqv_p(pic, x, y)) {
@@ -79,18 +32,6 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
   }
 
   switch (pic_type(pic, x)) {
-  case PIC_TYPE_ID: {
-    struct identifier *id1, *id2;
-    pic_value s1, s2;
-
-    id1 = pic_id_ptr(pic, x);
-    id2 = pic_id_ptr(pic, y);
-
-    s1 = pic_find_identifier(pic, obj_value(pic, id1->u.id), obj_value(pic, id1->env));
-    s2 = pic_find_identifier(pic, obj_value(pic, id2->u.id), obj_value(pic, id2->env));
-
-    return pic_eq_p(pic, s1, s2);
-  }
   case PIC_TYPE_STRING: {
     int xlen, ylen;
     const char *xstr, *ystr;
@@ -101,7 +42,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
     if (xlen != ylen) {
       return false;
     }
-    return strcmp(xstr, ystr) == 0;
+    return memcmp(xstr, ystr, xlen) == 0;
   }
   case PIC_TYPE_BLOB: {
     int xlen, ylen;
@@ -116,36 +57,11 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
     return memcmp(xbuf, ybuf, xlen) == 0;
   }
   case PIC_TYPE_PAIR: {
-    if (! internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, h))
+    if (! pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y))) {
       return false;
-
-    /* Floyd's cycle-finding algorithm */
-    if (pic_nil_p(pic, localx)) {
-      localx = x;
     }
     x = pic_cdr(pic, x);
-    cx++;
-    if (pic_nil_p(pic, localy)) {
-      localy = y;
-    }
     y = pic_cdr(pic, y);
-    cy++;
-    if (cx == 2) {
-      cx = 0;
-      localx = pic_cdr(pic, localx);
-      if (pic_eq_p(pic, localx, x)) {
-        if (cy < 0 ) return true; /* both lists circular */
-        cx = INT_MIN; /* found a cycle on x */
-      }
-    }
-    if (cy == 2) {
-      cy = 0;
-      localy = pic_cdr(pic, localy);
-      if (pic_eq_p(pic, localy, y)) {
-        if (cx < 0 ) return true; /* both lists circular */
-        cy = INT_MIN; /* found a cycle on y */
-      }
-    }
     goto LOOP;                  /* tail-call optimization */
   }
   case PIC_TYPE_VECTOR: {
@@ -158,11 +74,34 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
       return false;
     }
     for (i = 0; i < xlen; ++i) {
-      if (! internal_equal_p(pic, pic_vec_ref(pic, x, i), pic_vec_ref(pic, y, i), depth + 1, h))
+      if (! pic_equal_p(pic, pic_vec_ref(pic, x, i), pic_vec_ref(pic, y, i)))
         return false;
     }
     return true;
   }
+  case PIC_TYPE_DICT: {
+    int it = 0;
+    pic_value key, val;
+
+    if (pic_dict_size(pic, x) != pic_dict_size(pic, y)) {
+      return false;
+    }
+    while (pic_dict_next(pic, x, &it, &key, &val)) {
+      if (! pic_dict_has(pic, y, key))
+        return false;
+      if (! pic_equal_p(pic, val, pic_dict_ref(pic, y, key)))
+        return false;
+    }
+    return true;
+  }
+  case PIC_TYPE_RECORD: {
+    if (! pic_eq_p(pic, pic_record_type(pic, x), pic_record_type(pic, y))) {
+      return false;
+    }
+    x = pic_record_datum(pic, x);
+    y = pic_record_datum(pic, y);
+    goto LOOP;
+  }
   case PIC_TYPE_DATA: {
     return pic_data(pic, x) == pic_data(pic, y);
   }
@@ -171,16 +110,6 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
   }
 }
 
-bool
-pic_equal_p(pic_state *pic, pic_value x, pic_value y)
-{
-  khash_t(m) h;
-
-  kh_init(m, &h);
-
-  return internal_equal_p(pic, x, y, 0, &h);
-}
-
 static pic_value
 pic_bool_eq_p(pic_state *pic)
 {

lib/char.c

@@ -2,7 +2,8 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 
 static pic_value

lib/cont.c

@@ -1,227 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "object.h"
-#include "state.h"
-
-struct cont {
-  PIC_JMPBUF *jmp;
-
-  ptrdiff_t sp_offset;
-  ptrdiff_t ci_offset;
-  size_t arena_idx;
-  const struct code *ip;
-  pic_value dyn_env;
-
-  int retc;
-  pic_value *retv;
-
-  struct cont *prev;
-};
-
-static const pic_data_type cont_type = { "cont", NULL };
-
-void
-pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp)
-{
-  cont->jmp = jmp;
-
-  /* save runtime context */
-  cont->sp_offset = pic->sp - pic->stbase;
-  cont->ci_offset = pic->ci - pic->cibase;
-  cont->arena_idx = pic->arena_idx;
-  cont->dyn_env = pic->dyn_env;
-  cont->ip = pic->ip;
-  cont->prev = pic->cc;
-  cont->retc = 0;
-  cont->retv = NULL;
-
-  pic->cc = cont;
-}
-
-void
-pic_load_point(pic_state *pic, struct cont *cont)
-{
-  pic_vm_tear_off(pic);
-
-  /* load runtime context */
-  pic->sp = pic->stbase + cont->sp_offset;
-  pic->ci = pic->cibase + cont->ci_offset;
-  pic->arena_idx = cont->arena_idx;
-  pic->dyn_env = cont->dyn_env;
-  pic->ip = cont->ip;
-  pic->cc = cont->prev;
-}
-
-void
-pic_exit_point(pic_state *pic)
-{
-  pic->cc = pic->cc->prev;
-}
-
-static pic_value
-cont_call(pic_state *pic)
-{
-  int argc;
-  pic_value *argv;
-  struct cont *cc, *cont;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  cont = pic_data(pic, pic_closure_ref(pic, 0));
-
-  /* check if continuation is alive */
-  for (cc = pic->cc; cc != NULL; cc = cc->prev) {
-    if (cc == cont) {
-      break;
-    }
-  }
-  if (cc == NULL) {
-    pic_error(pic, "calling dead escape continuation", 0);
-  }
-
-  cont->retc = argc;
-  cont->retv = argv;
-
-  pic_load_point(pic, cont);
-
-  PIC_LONGJMP(pic, *cont->jmp, 1);
-  PIC_UNREACHABLE();
-}
-
-pic_value
-pic_make_cont(pic_state *pic, struct cont *cont)
-{
-  return pic_lambda(pic, cont_call, 1, pic_data_value(pic, cont, &cont_type));
-}
-
-struct cont *
-pic_alloca_cont(pic_state *pic)
-{
-  return pic_alloca(pic, sizeof(struct cont));
-}
-
-static pic_value
-values(pic_state *pic, int argc, pic_value *argv)
-{
-  int i;
-
-  for (i = 0; i < argc; ++i) {
-    pic->sp[i] = argv[i];
-  }
-  pic->ci->retc = argc;
-
-  return argc == 0 ? pic_undef_value(pic) : pic->sp[0];
-}
-
-static pic_value
-pic_callcc(pic_state *pic, pic_value proc)
-{
-  PIC_JMPBUF jmp;
-  volatile struct cont *cont = pic_alloca_cont(pic);
-
-  if (PIC_SETJMP(pic, jmp)) {
-    return values(pic, cont->retc, cont->retv);
-  }
-  else {
-    pic_value val;
-
-    pic_save_point(pic, (struct cont *)cont, &jmp);
-
-    val = pic_call(pic, proc, 1, pic_make_cont(pic, (struct cont *)cont));
-
-    pic_exit_point(pic);
-
-    return val;
-  }
-}
-
-pic_value
-pic_values(pic_state *pic, int n, ...)
-{
-  va_list ap;
-  pic_value ret;
-
-  va_start(ap, n);
-  ret = pic_vvalues(pic, n, ap);
-  va_end(ap);
-  return ret;
-}
-
-pic_value
-pic_vvalues(pic_state *pic, int n, va_list ap)
-{
-  pic_value *retv = pic_alloca(pic, sizeof(pic_value) * n);
-  int i;
-
-  for (i = 0; i < n; ++i) {
-    retv[i] = va_arg(ap, pic_value);
-  }
-  return values(pic, n, retv);
-}
-
-int
-pic_receive(pic_state *pic, int n, pic_value *argv)
-{
-  struct callinfo *ci;
-  int i, retc;
-
-  /* take info from discarded frame */
-  ci = pic->ci + 1;
-  retc = ci->retc;
-
-  for (i = 0; i < retc && i < n; ++i) {
-    argv[i] = ci->fp[i];
-  }
-  return retc;
-}
-
-static pic_value
-pic_cont_callcc(pic_state *pic)
-{
-  pic_value f;
-
-  pic_get_args(pic, "l", &f);
-
-  return pic_callcc(pic, f);
-}
-
-static pic_value
-pic_cont_values(pic_state *pic)
-{
-  int argc;
-  pic_value *argv;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  return values(pic, argc, argv);
-}
-
-static pic_value
-pic_cont_call_with_values(pic_state *pic)
-{
-  pic_value producer, consumer, retv[256];
-  int retc;
-
-  pic_get_args(pic, "ll", &producer, &consumer);
-
-  pic_call(pic, producer, 0);
-
-  retc = pic_receive(pic, 256, retv);
-  if (retc > 256) {
-    pic_error(pic, "call-with-values: too many arguments", 1, pic_int_value(pic, retc));
-  }
-
-  return pic_applyk(pic, consumer, retc, retv);
-}
-
-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, "values", pic_cont_values);
-  pic_defun(pic, "call-with-values", pic_cont_call_with_values);
-}

lib/data.c

@@ -2,8 +2,10 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
+#include "state.h"
 
 bool
 pic_data_p(pic_state *pic, pic_value obj, const pic_data_type *type)
@@ -11,13 +13,13 @@ pic_data_p(pic_state *pic, pic_value obj, const pic_data_type *type)
   if (pic_type(pic, obj) != PIC_TYPE_DATA) {
     return false;
   }
-  return type == NULL || pic_data_ptr(pic, obj)->type == type;
+  return type == NULL || data_ptr(pic, obj)->type == type;
 }
 
 void *
-pic_data(pic_state *PIC_UNUSED(pic), pic_value data)
+pic_data(pic_state *pic, pic_value data)
 {
-  return pic_data_ptr(pic, data)->data;
+  return data_ptr(pic, data)->data;
 }
 
 pic_value
@@ -25,7 +27,7 @@ pic_data_value(pic_state *pic, void *userdata, const pic_data_type *type)
 {
   struct data *data;
 
-  data = (struct data *)pic_obj_alloc(pic, sizeof(struct data), PIC_TYPE_DATA);
+  data = (struct data *)pic_obj_alloc(pic, PIC_TYPE_DATA);
   data->type = type;
   data->data = userdata;
 

lib/debug.c

@@ -1,61 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "object.h"
-#include "state.h"
-
-pic_value
-pic_get_backtrace(pic_state *pic)
-{
-  size_t ai = pic_enter(pic);
-  struct callinfo *ci;
-  pic_value trace;
-
-  trace = pic_lit_value(pic, "");
-
-  for (ci = pic->ci; ci != pic->cibase; --ci) {
-    pic_value proc = ci->fp[0];
-
-    trace = pic_str_cat(pic, trace, pic_lit_value(pic, "  at "));
-    trace = pic_str_cat(pic, trace, pic_lit_value(pic, "(anonymous lambda)"));
-
-    if (pic_proc_func_p(pic, proc)) {
-      trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (native function)\n"));
-    } else {
-      trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (unknown location)\n")); /* TODO */
-    }
-  }
-
-  pic_leave(pic, ai);
-  pic_protect(pic, trace);
-
-  return trace;
-}
-
-#if PIC_USE_WRITE
-
-void
-pic_print_error(pic_state *pic, pic_value port, pic_value err)
-{
-  if (! pic_error_p(pic, err)) {
-    pic_fprintf(pic, port, "raise: ~s", err);
-  } else {
-    struct error *e;
-    pic_value elem, it;
-
-    e = pic_error_ptr(pic, err);
-    if (! pic_eq_p(pic, obj_value(pic, e->type), pic_intern_lit(pic, ""))) {
-      pic_fprintf(pic, port, "~s-", obj_value(pic, e->type));
-    }
-    pic_fprintf(pic, port, "error: ~s", obj_value(pic, e->msg));
-
-    pic_for_each (elem, e->irrs, it) { /* print error irritants */
-      pic_fprintf(pic, port, " ~s", elem);
-    }
-    pic_fprintf(pic, port, "\n%s", pic_str(pic, obj_value(pic, e->stack), NULL));
-  }
-}
-
-#endif

lib/dict.c

@@ -2,17 +2,18 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 
-KHASH_DEFINE(dict, symbol *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
+KHASH_DEFINE(dict, struct symbol *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
 
 pic_value
 pic_make_dict(pic_state *pic)
 {
   struct dict *dict;
 
-  dict = (struct dict *)pic_obj_alloc(pic, sizeof(struct dict), PIC_TYPE_DICT);
+  dict = (struct dict *)pic_obj_alloc(pic, PIC_TYPE_DICT);
   kh_init(dict, &dict->hash);
   return obj_value(pic, dict);
 }
@@ -20,10 +21,10 @@ pic_make_dict(pic_state *pic)
 pic_value
 pic_dict_ref(pic_state *pic, pic_value dict, pic_value key)
 {
-  khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash;
+  khash_t(dict) *h = &dict_ptr(pic, dict)->hash;
   int it;
 
-  it = kh_get(dict, h, pic_sym_ptr(pic, key));
+  it = kh_get(dict, h, sym_ptr(pic, key));
   if (it == kh_end(h)) {
     pic_error(pic, "element not found for given key", 1, key);
   }
@@ -33,35 +34,35 @@ pic_dict_ref(pic_state *pic, pic_value dict, pic_value key)
 void
 pic_dict_set(pic_state *pic, pic_value dict, pic_value key, pic_value val)
 {
-  khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash;
+  khash_t(dict) *h = &dict_ptr(pic, dict)->hash;
   int ret;
   int it;
 
-  it = kh_put(dict, h, pic_sym_ptr(pic, key), &ret);
+  it = kh_put(dict, h, sym_ptr(pic, key), &ret);
   kh_val(h, it) = val;
 }
 
 int
-pic_dict_size(pic_state *PIC_UNUSED(pic), pic_value dict)
+pic_dict_size(pic_state *pic, pic_value dict)
 {
-  return kh_size(&pic_dict_ptr(pic, dict)->hash);
+  return kh_size(&dict_ptr(pic, dict)->hash);
 }
 
 bool
 pic_dict_has(pic_state *pic, pic_value dict, pic_value key)
 {
-  khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash;
+  khash_t(dict) *h = &dict_ptr(pic, dict)->hash;
 
-  return kh_get(dict, h, pic_sym_ptr(pic, key)) != kh_end(h);
+  return kh_get(dict, h, sym_ptr(pic, key)) != kh_end(h);
 }
 
 void
 pic_dict_del(pic_state *pic, pic_value dict, pic_value key)
 {
-  khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash;
+  khash_t(dict) *h = &dict_ptr(pic, dict)->hash;
   int it;
 
-  it = kh_get(dict, h, pic_sym_ptr(pic, key));
+  it = kh_get(dict, h, sym_ptr(pic, key));
   if (it == kh_end(h)) {
     pic_error(pic, "element not found for given key", 1, key);
   }
@@ -69,9 +70,9 @@ pic_dict_del(pic_state *pic, pic_value dict, pic_value key)
 }
 
 bool
-pic_dict_next(pic_state *PIC_UNUSED(pic), pic_value dict, int *iter, pic_value *key, pic_value *val)
+pic_dict_next(pic_state *pic, pic_value dict, int *iter, pic_value *key, pic_value *val)
 {
-  khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash;
+  khash_t(dict) *h = &dict_ptr(pic, dict)->hash;
   int it = *iter;
 
   for (it = *iter; it != kh_end(h); ++it) {
@@ -178,11 +179,15 @@ pic_dict_dictionary_map(pic_state *pic)
 {
   pic_value dict, proc, key, ret = pic_nil_value(pic);
   int it = 0;
+  size_t ai;
 
   pic_get_args(pic, "ld", &proc, &dict);
 
+  ai = pic_enter(pic);
   while (pic_dict_next(pic, dict, &it, &key, NULL)) {
     pic_push(pic, pic_call(pic, proc, 1, key), ret);
+    pic_leave(pic, ai);
+    pic_protect(pic, ret);
   }
   return pic_reverse(pic, ret);
 }
@@ -191,12 +196,15 @@ static pic_value
 pic_dict_dictionary_for_each(pic_state *pic)
 {
   pic_value dict, proc, key;
-  int it;
+  int it = 0;
+  size_t ai;
 
   pic_get_args(pic, "ld", &proc, &dict);
 
+  ai = pic_enter(pic);
   while (pic_dict_next(pic, dict, &it, &key, NULL)) {
     pic_call(pic, proc, 1, key);
+    pic_leave(pic, ai);
   }
 
   return pic_undef_value(pic);
@@ -234,39 +242,6 @@ pic_dict_alist_to_dictionary(pic_state *pic)
   return dict;
 }
 
-static pic_value
-pic_dict_dictionary_to_plist(pic_state *pic)
-{
-  pic_value dict, key, val, plist = pic_nil_value(pic);
-  int it = 0;
-
-  pic_get_args(pic, "d", &dict);
-
-  while (pic_dict_next(pic, dict, &it, &key, &val)) {
-    pic_push(pic, val, plist);
-    pic_push(pic, key, plist);
-  }
-
-  return plist;
-}
-
-static pic_value
-pic_dict_plist_to_dictionary(pic_state *pic)
-{
-  pic_value dict, plist, e;
-
-  pic_get_args(pic, "o", &plist);
-
-  dict = pic_make_dict(pic);
-
-  for (e = pic_reverse(pic, plist); ! pic_nil_p(pic, e); e = pic_cddr(pic, e)) {
-    TYPE_CHECK(pic, pic_cadr(pic, e), sym);
-    pic_dict_set(pic, dict, pic_cadr(pic, e), pic_car(pic, e));
-  }
-
-  return dict;
-}
-
 void
 pic_init_dict(pic_state *pic)
 {
@@ -282,6 +257,4 @@ pic_init_dict(pic_state *pic)
   pic_defun(pic, "dictionary-for-each", pic_dict_dictionary_for_each);
   pic_defun(pic, "dictionary->alist", pic_dict_dictionary_to_alist);
   pic_defun(pic, "alist->dictionary", pic_dict_alist_to_dictionary);
-  pic_defun(pic, "dictionary->plist", pic_dict_dictionary_to_plist);
-  pic_defun(pic, "plist->dictionary", pic_dict_plist_to_dictionary);
 }

lib/error.c

@@ -1,270 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "object.h"
-#include "state.h"
-
-void
-pic_panic(pic_state *pic, const char *msg)
-{
-  if (pic->panicf) {
-    pic->panicf(pic, msg);
-  }
-  PIC_ABORT(pic);
-  PIC_UNREACHABLE();
-}
-
-void
-pic_warnf(pic_state *pic, const char *fmt, ...)
-{
-  va_list ap;
-  pic_value err;
-
-  va_start(ap, fmt);
-  err = pic_vstrf_value(pic, fmt, ap);
-  va_end(ap);
-  pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err, NULL));
-}
-
-#define pic_exc(pic) pic_ref(pic, "current-exception-handlers")
-
-static pic_value
-native_exception_handler(pic_state *pic)
-{
-  pic_value err;
-
-  pic_get_args(pic, "o", &err);
-
-  pic->err = err;
-
-  pic_call(pic, pic_closure_ref(pic, 0), 1, pic_false_value(pic));
-
-  PIC_UNREACHABLE();
-}
-
-void
-pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
-{
-  struct cont *cont;
-  pic_value handler;
-  pic_value var, env;
-
-  /* call/cc */
-
-  cont = pic_alloca_cont(pic);
-  pic_save_point(pic, cont, jmp);
-  handler = pic_lambda(pic, native_exception_handler, 1, pic_make_cont(pic, cont));
-
-  /* with-exception-handler */
-
-  var = pic_exc(pic);
-  env = pic_make_weak(pic);
-  pic_weak_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
-  pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
-}
-
-void
-pic_end_try(pic_state *pic)
-{
-  pic->dyn_env = pic_cdr(pic, pic->dyn_env);
-
-  pic_exit_point(pic);
-}
-
-pic_value
-pic_err(pic_state *pic)
-{
-  return pic->err;
-}
-
-pic_value
-pic_make_error(pic_state *pic, const char *type, const char *msg, pic_value irrs)
-{
-  struct error *e;
-  pic_value stack, ty = pic_intern_cstr(pic, type);
-
-  stack = pic_get_backtrace(pic);
-
-  e = (struct error *)pic_obj_alloc(pic, sizeof(struct error), PIC_TYPE_ERROR);
-  e->type = pic_sym_ptr(pic, ty);
-  e->msg = pic_str_ptr(pic, pic_cstr_value(pic, msg));
-  e->irrs = irrs;
-  e->stack = pic_str_ptr(pic, stack);
-
-  return obj_value(pic, e);
-}
-
-static pic_value
-with_exception_handlers(pic_state *pic, pic_value handlers, pic_value thunk)
-{
-  pic_value alist, var = pic_exc(pic);
-  alist = pic_list(pic, 1, pic_cons(pic, var, handlers));
-  return pic_funcall(pic, "with-dynamic-environment", 2, alist, thunk);
-}
-
-static pic_value
-on_raise(pic_state *pic)
-{
-  pic_value handler, err, val;
-  bool continuable;
-
-  pic_get_args(pic, "");
-
-  handler = pic_closure_ref(pic, 0);
-  err = pic_closure_ref(pic, 1);
-  continuable = pic_bool(pic, pic_closure_ref(pic, 2));
-
-  val = pic_call(pic, handler, 1, err);
-  if (! continuable) {
-    pic_error(pic, "handler returned", 2, handler, err);
-  }
-  return val;
-}
-
-pic_value
-pic_raise_continuable(pic_state *pic, pic_value err)
-{
-  pic_value handlers, var = pic_exc(pic), thunk;
-
-  handlers = pic_call(pic, var, 0);
-
-  if (pic_nil_p(pic, handlers)) {
-    pic_panic(pic, "no exception handler");
-  }
-  thunk = pic_lambda(pic, on_raise, 3, pic_car(pic, handlers), err, pic_true_value(pic));
-  return with_exception_handlers(pic, pic_cdr(pic, handlers), thunk);
-}
-
-void
-pic_raise(pic_state *pic, pic_value err)
-{
-  pic_value handlers, var = pic_exc(pic), thunk;
-
-  handlers = pic_call(pic, var, 0);
-
-  if (pic_nil_p(pic, handlers)) {
-    pic_panic(pic, "no exception handler");
-  }
-  thunk = pic_lambda(pic, on_raise, 3, pic_car(pic, handlers), err, pic_false_value(pic));
-  with_exception_handlers(pic, pic_cdr(pic, handlers), thunk);
-  PIC_UNREACHABLE();
-}
-
-void
-pic_error(pic_state *pic, const char *msg, int n, ...)
-{
-  va_list ap;
-  pic_value irrs;
-
-  va_start(ap, n);
-  irrs = pic_vlist(pic, n, ap);
-  va_end(ap);
-  pic_raise(pic, pic_make_error(pic, "", msg, irrs));
-}
-
-static pic_value
-pic_error_with_exception_handler(pic_state *pic)
-{
-  pic_value handler, thunk;
-  pic_value handlers, exc = pic_exc(pic);
-
-  pic_get_args(pic, "ll", &handler, &thunk);
-
-  handlers = pic_call(pic, exc, 0);
-
-  return with_exception_handlers(pic, pic_cons(pic, handler, handlers), thunk);
-}
-
-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);
-}
-
-static pic_value
-pic_error_error(pic_state *pic)
-{
-  const char *cstr;
-  int argc;
-  pic_value *argv;
-
-  pic_get_args(pic, "z*", &cstr, &argc, &argv);
-
-  pic_raise(pic, pic_make_error(pic, "", cstr, pic_make_list(pic, argc, argv)));
-}
-
-static pic_value
-pic_error_error_object_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic, pic_error_p(pic, v));
-}
-
-static pic_value
-pic_error_error_object_message(pic_state *pic)
-{
-  pic_value e;
-
-  pic_get_args(pic, "o", &e);
-
-  TYPE_CHECK(pic, e, error);
-
-  return obj_value(pic, pic_error_ptr(pic, e)->msg);
-}
-
-static pic_value
-pic_error_error_object_irritants(pic_state *pic)
-{
-  pic_value e;
-
-  pic_get_args(pic, "o", &e);
-
-  TYPE_CHECK(pic, e, error);
-
-  return pic_error_ptr(pic, e)->irrs;
-}
-
-static pic_value
-pic_error_error_object_type(pic_state *pic)
-{
-  pic_value e;
-
-  pic_get_args(pic, "o", &e);
-
-  TYPE_CHECK(pic, e, error);
-
-  return obj_value(pic, pic_error_ptr(pic, e)->type);
-}
-
-void
-pic_init_error(pic_state *pic)
-{
-  pic_defvar(pic, "current-exception-handlers", pic_nil_value(pic));
-  pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler);
-  pic_defun(pic, "raise", pic_error_raise);
-  pic_defun(pic, "raise-continuable", pic_error_raise_continuable);
-  pic_defun(pic, "error", pic_error_error);
-  pic_defun(pic, "error-object?", pic_error_error_object_p);
-  pic_defun(pic, "error-object-message", pic_error_error_object_message);
-  pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants);
-  pic_defun(pic, "error-object-type", pic_error_error_object_type);
-}

lib/ext/boot.c

@@ -1,267 +0,0 @@
-#include "picrin.h"
-#include "picrin/extra.h"
-
-static const char boot_rom[][80] = {
-"(core#define-macro call-with-current-environment (core#lambda (form env) (list (",
-"cadr form) env))) (core#define here (call-with-current-environment (core#lambda ",
-"(env) env))) (core#define the (core#lambda (var) (make-identifier var here))) (c",
-"ore#define the-builtin-define (the (core#quote core#define))) (core#define the-b",
-"uiltin-lambda (the (core#quote core#lambda))) (core#define the-builtin-begin (th",
-"e (core#quote core#begin))) (core#define the-builtin-quote (the (core#quote core",
-"#quote))) (core#define the-builtin-set! (the (core#quote core#set!))) (core#defi",
-"ne the-builtin-if (the (core#quote core#if))) (core#define the-builtin-define-ma",
-"cro (the (core#quote core#define-macro))) (core#define the-define (the (core#quo",
-"te define))) (core#define the-lambda (the (core#quote lambda))) (core#define the",
-"-begin (the (core#quote begin))) (core#define the-quote (the (core#quote quote))",
-") (core#define the-set! (the (core#quote set!))) (core#define the-if (the (core#",
-"quote if))) (core#define the-define-macro (the (core#quote define-macro))) (core",
-"#define-macro quote (core#lambda (form env) (core#if (= (length form) 2) (list t",
-"he-builtin-quote (cadr form)) (error \"illegal quote form\" form)))) (core#define-",
-"macro if (core#lambda (form env) ((core#lambda (len) (core#if (= len 4) (cons th",
-"e-builtin-if (cdr form)) (core#if (= len 3) (list the-builtin-if (list-ref form ",
-"1) (list-ref form 2) #undefined) (error \"illegal if form\" form)))) (length form)",
-"))) (core#define-macro begin (core#lambda (form env) ((core#lambda (len) (if (= ",
-"len 1) #undefined (if (= len 2) (cadr form) (if (= len 3) (cons the-builtin-begi",
-"n (cdr form)) (list the-builtin-begin (cadr form) (cons the-begin (cddr form))))",
-"))) (length form)))) (core#define-macro set! (core#lambda (form env) (if (= (len",
-"gth form) 3) (if (identifier? (cadr form)) (cons the-builtin-set! (cdr form)) (e",
-"rror \"illegal set! form\" form)) (error \"illegal set! form\" form)))) (core#define",
-" check-formal (core#lambda (formal) (if (null? formal) #t (if (identifier? forma",
-"l) #t (if (pair? formal) (if (identifier? (car formal)) (check-formal (cdr forma",
-"l)) #f) #f))))) (core#define-macro lambda (core#lambda (form env) (if (= (length",
-" form) 1) (error \"illegal lambda form\" form) (if (check-formal (cadr form)) (lis",
-"t the-builtin-lambda (cadr form) (cons the-begin (cddr form))) (error \"illegal l",
-"ambda form\" form))))) (core#define-macro define (lambda (form env) ((lambda (len",
-") (if (= len 1) (error \"illegal define form\" form) (if (identifier? (cadr form))",
-" (if (= len 3) (cons the-builtin-define (cdr form)) (error \"illegal define form\"",
-" form)) (if (pair? (cadr form)) (list the-define (car (cadr form)) (cons the-lam",
-"bda (cons (cdr (cadr form)) (cddr form)))) (error \"define: binding to non-varaib",
-"le object\" form))))) (length form)))) (core#define-macro define-macro (lambda (f",
-"orm env) (if (= (length form) 3) (if (identifier? (cadr form)) (cons the-builtin",
-"-define-macro (cdr form)) (error \"define-macro: binding to non-variable object\" ",
-"form)) (error \"illegal define-macro form\" form)))) (define-macro syntax-error (l",
-"ambda (form _) (apply error (cdr form)))) (define-macro define-auxiliary-syntax ",
-"(lambda (form _) (define message (string-append \"invalid use of auxiliary syntax",
-": '\" (symbol->string (cadr form)) \"'\")) (list the-define-macro (cadr form) (list",
-" the-lambda '_ (list (the 'error) message))))) (define-auxiliary-syntax else) (d",
-"efine-auxiliary-syntax =>) (define-auxiliary-syntax unquote) (define-auxiliary-s",
-"yntax unquote-splicing) (define-auxiliary-syntax syntax-unquote) (define-auxilia",
-"ry-syntax syntax-unquote-splicing) (define-macro let (lambda (form env) (if (ide",
-"ntifier? (cadr form)) (list (list the-lambda '() (list the-define (cadr form) (c",
-"ons the-lambda (cons (map car (car (cddr form))) (cdr (cddr form))))) (cons (cad",
-"r form) (map cadr (car (cddr form)))))) (cons (cons the-lambda (cons (map car (c",
-"adr form)) (cddr form))) (map cadr (cadr form)))))) (define-macro and (lambda (f",
-"orm env) (if (null? (cdr form)) #t (if (null? (cddr form)) (cadr form) (list the",
-"-if (cadr form) (cons (the 'and) (cddr form)) #f))))) (define-macro or (lambda (",
-"form env) (if (null? (cdr form)) #f (let ((tmp (make-identifier 'it env))) (list",
-" (the 'let) (list (list tmp (cadr form))) (list the-if tmp tmp (cons (the 'or) (",
-"cddr form)))))))) (define-macro cond (lambda (form env) (let ((clauses (cdr form",
-"))) (if (null? clauses) #undefined (let ((clause (car clauses))) (if (and (ident",
-"ifier? (car clause)) (identifier=? (the 'else) (make-identifier (car clause) env",
-"))) (cons the-begin (cdr clause)) (if (null? (cdr clause)) (let ((tmp (make-iden",
-"tifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) (list the-if",
-" tmp tmp (cons (the 'cond) (cdr clauses))))) (if (and (identifier? (cadr clause)",
-") (identifier=? (the '=>) (make-identifier (cadr clause) env))) (let ((tmp (make",
-"-identifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) (list t",
-"he-if tmp (list (car (cddr clause)) tmp) (cons (the 'cond) (cdr clauses))))) (li",
-"st the-if (car clause) (cons the-begin (cdr clause)) (cons (the 'cond) (cdr clau",
-"ses))))))))))) (define-macro quasiquote (lambda (form env) (define (quasiquote? ",
-"form) (and (pair? form) (identifier? (car form)) (identifier=? (the 'quasiquote)",
-" (make-identifier (car form) env)))) (define (unquote? form) (and (pair? form) (",
-"identifier? (car form)) (identifier=? (the 'unquote) (make-identifier (car form)",
-" env)))) (define (unquote-splicing? form) (and (pair? form) (pair? (car form)) (",
-"identifier? (caar form)) (identifier=? (the 'unquote-splicing) (make-identifier ",
-"(caar form) env)))) (define (qq depth expr) (cond ((unquote? expr) (if (= depth ",
-"1) (car (cdr expr)) (list (the 'list) (list (the 'quote) (the 'unquote)) (qq (- ",
-"depth 1) (car (cdr expr)))))) ((unquote-splicing? expr) (if (= depth 1) (list (t",
-"he 'append) (car (cdr (car expr))) (qq depth (cdr expr))) (list (the 'cons) (lis",
-"t (the 'list) (list (the 'quote) (the 'unquote-splicing)) (qq (- depth 1) (car (",
-"cdr (car expr))))) (qq depth (cdr expr))))) ((quasiquote? expr) (list (the 'list",
-") (list (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) ((pa",
-"ir? expr) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr expr)))) ((vect",
-"or? expr) (list (the 'list->vector) (qq depth (vector->list expr)))) (else (list",
-" (the 'quote) expr)))) (let ((x (cadr form))) (qq 1 x)))) (define-macro let* (la",
-"mbda (form env) (let ((bindings (car (cdr form))) (body (cdr (cdr form)))) (if (",
-"null? bindings) `(,(the 'let) () ,@body) `(,(the 'let) ((,(car (car bindings)) ,",
-"@(cdr (car bindings)))) (,(the 'let*) (,@(cdr bindings)) ,@body)))))) (define-ma",
-"cro letrec (lambda (form env) `(,(the 'letrec*) ,@(cdr form)))) (define-macro le",
-"trec* (lambda (form env) (let ((bindings (car (cdr form))) (body (cdr (cdr form)",
-"))) (let ((variables (map (lambda (v) `(,v #f)) (map car bindings))) (initials (",
-"map (lambda (v) `(,(the 'set!) ,@v)) bindings))) `(,(the 'let) (,@variables) ,@i",
-"nitials ,@body))))) (define-macro let-values (lambda (form env) `(,(the 'let*-va",
-"lues) ,@(cdr form)))) (define-macro let*-values (lambda (form env) (let ((formal",
-" (car (cdr form))) (body (cdr (cdr form)))) (if (null? formal) `(,(the 'let) () ",
-",@body) `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal))) (,(the ",
-"'lambda) (,@(car (car formal))) (,(the 'let*-values) (,@(cdr formal)) ,@body))))",
-"))) (define-macro define-values (lambda (form env) (let ((formal (car (cdr form)",
-")) (body (cdr (cdr form)))) (let ((arguments (make-identifier 'arguments here)))",
-" `(,the-begin ,@(let loop ((formal formal)) (if (pair? formal) `((,the-define ,(",
-"car formal) #undefined) ,@(loop (cdr formal))) (if (identifier? formal) `((,the-",
-"define ,formal #undefined)) '()))) (,(the 'call-with-values) (,the-lambda () ,@b",
-"ody) (,the-lambda ,arguments ,@(let loop ((formal formal) (args arguments)) (if ",
-"(pair? formal) `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr form",
-"al) `(,(the 'cdr) ,args))) (if (identifier? formal) `((,the-set! ,formal ,args))",
-" '())))))))))) (define-macro do (lambda (form env) (let ((bindings (car (cdr for",
-"m))) (test (car (car (cdr (cdr form))))) (cleanup (cdr (car (cdr (cdr form))))) ",
-"(body (cdr (cdr (cdr form))))) (let ((loop (make-identifier 'loop here))) `(,(th",
-"e 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings) (,the-if ,test ",
-"(,the-begin ,@cleanup) (,the-begin ,@body (,loop ,@(map (lambda (x) (if (null? (",
-"cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings))))))))) (define-macro when",
-" (lambda (form env) (let ((test (car (cdr form))) (body (cdr (cdr form)))) `(,th",
-"e-if ,test (,the-begin ,@body) #undefined)))) (define-macro unless (lambda (form",
-" env) (let ((test (car (cdr form))) (body (cdr (cdr form)))) `(,the-if ,test #un",
-"defined (,the-begin ,@body))))) (define-macro case (lambda (form env) (let ((key",
-" (car (cdr form))) (clauses (cdr (cdr form)))) (let ((the-key (make-identifier '",
-"key here))) `(,(the 'let) ((,the-key ,key)) ,(let loop ((clauses clauses)) (if (",
-"null? clauses) #undefined (let ((clause (car clauses))) `(,the-if ,(if (and (ide",
-"ntifier? (car clause)) (identifier=? (the 'else) (make-identifier (car clause) e",
-"nv))) #t `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x)",
-")) (car clause)))) ,(if (and (identifier? (cadr clause)) (identifier=? (the '=>)",
-" (make-identifier (cadr clause) env))) `(,(car (cdr (cdr clause))) ,the-key) `(,",
-"the-begin ,@(cdr clause))) ,(loop (cdr clauses))))))))))) (define-macro paramete",
-"rize (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr form))))",
-" `(,(the 'with-dynamic-environment) (,(the 'list) ,@(map (lambda (x) `(,(the 'co",
-"ns) ,(car x) ,(cadr x))) formal)) (,the-lambda () ,@body))))) (define-macro synt",
-"ax-quote (lambda (form env) (let ((renames '())) (letrec ((rename (lambda (var) ",
-"(let ((x (assq var renames))) (if x (cadr x) (begin (set! renames `((,var ,(make",
-"-identifier var env) (,(the 'make-identifier) ',var ',env)) unquote renames)) (r",
-"ename var)))))) (walk (lambda (f form) (cond ((identifier? form) (f form)) ((pai",
-"r? form) `(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) ((vector? form",
-") `(,(the 'list->vector) (walk f (vector->list form)))) (else `(,(the 'quote) ,f",
-"orm)))))) (let ((form (walk rename (cadr form)))) `(,(the 'let) ,(map cdr rename",
-"s) ,form)))))) (define-macro syntax-quasiquote (lambda (form env) (let ((renames",
-" '())) (letrec ((rename (lambda (var) (let ((x (assq var renames))) (if x (cadr ",
-"x) (begin (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifi",
-"er) ',var ',env)) unquote renames)) (rename var))))))) (define (syntax-quasiquot",
-"e? form) (and (pair? form) (identifier? (car form)) (identifier=? (the 'syntax-q",
-"uasiquote) (make-identifier (car form) env)))) (define (syntax-unquote? form) (a",
-"nd (pair? form) (identifier? (car form)) (identifier=? (the 'syntax-unquote) (ma",
-"ke-identifier (car form) env)))) (define (syntax-unquote-splicing? form) (and (p",
-"air? form) (pair? (car form)) (identifier? (caar form)) (identifier=? (the 'synt",
-"ax-unquote-splicing) (make-identifier (caar form) env)))) (define (qq depth expr",
-") (cond ((syntax-unquote? expr) (if (= depth 1) (car (cdr expr)) (list (the 'lis",
-"t) (list (the 'quote) (the 'syntax-unquote)) (qq (- depth 1) (car (cdr expr)))))",
-") ((syntax-unquote-splicing? expr) (if (= depth 1) (list (the 'append) (car (cdr",
-" (car expr))) (qq depth (cdr expr))) (list (the 'cons) (list (the 'list) (list (",
-"the 'quote) (the 'syntax-unquote-splicing)) (qq (- depth 1) (car (cdr (car expr)",
-")))) (qq depth (cdr expr))))) ((syntax-quasiquote? expr) (list (the 'list) (list",
-" (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) ((pair? exp",
-"r) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr expr)))) ((vector? exp",
-"r) (list (the 'list->vector) (qq depth (vector->list expr)))) ((identifier? expr",
-") (rename expr)) (else (list (the 'quote) expr)))) (let ((body (qq 1 (cadr form)",
-"))) `(,(the 'let) ,(map cdr renames) ,body)))))) (define (transformer f) (lambda",
-" (form env) (let ((ephemeron1 (make-ephemeron-table)) (ephemeron2 (make-ephemero",
-"n-table))) (letrec ((wrap (lambda (var1) (let ((var2 (ephemeron1 var1))) (if var",
-"2 (cdr var2) (let ((var2 (make-identifier var1 env))) (ephemeron1 var1 var2) (ep",
-"hemeron2 var2 var1) var2))))) (unwrap (lambda (var2) (let ((var1 (ephemeron2 var",
-"2))) (if var1 (cdr var1) var2)))) (walk (lambda (f form) (cond ((identifier? for",
-"m) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form)))) ((vec",
-"tor? form) (list->vector (walk f (vector->list form)))) (else form))))) (let ((f",
-"orm (cdr form))) (walk unwrap (apply f (walk wrap form)))))))) (define-macro def",
-"ine-syntax (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr fo",
-"rm)))) (if (pair? formal) `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(c",
-"dr formal) ,@body)) `(,the-define-macro ,formal (,(the 'transformer) (,the-begin",
-" ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((formal (car",
-" (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(the 'defi",
-"ne-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syntax (lam",
-"bda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (define (mangle name) (wh",
-"en (null? name) (error \"library name should be a list of at least one symbols\" n",
-"ame)) (define (->string n) (cond ((symbol? n) (let ((str (symbol->string n))) (s",
-"tring-for-each (lambda (c) (when (or (char=? c #\\.) (char=? c #\\:)) (error \"elem",
-"ents of library name may not contain '.' or ':'\" n))) str) str)) ((and (number? ",
-"n) (exact? n) (<= 0 n)) (number->string n)) (else (error \"symbol or non-negative",
-" integer is required\" n)))) (define (join strs delim) (let loop ((res (car strs)",
-") (strs (cdr strs))) (if (null? strs) res (loop (string-append res delim (car st",
-"rs)) (cdr strs))))) (if (symbol? name) name (string->symbol (join (map ->string ",
-"name) \".\")))) (define current-library (make-parameter '(picrin base) mangle)) (d",
-"efine *libraries* (make-dictionary)) (define (find-library name) (dictionary-has",
-"? *libraries* (mangle name))) (define (make-library name) (let ((name (mangle na",
-"me))) (let ((env (make-environment (string->symbol (string-append (symbol->strin",
-"g name) \":\")))) (exports (make-dictionary))) (set-identifier! 'define-library 'd",
-"efine-library env) (set-identifier! 'import 'import env) (set-identifier! 'expor",
-"t 'export env) (set-identifier! 'cond-expand 'cond-expand env) (dictionary-set! ",
-"*libraries* name `(,env unquote exports))))) (define (library-environment name) ",
-"(car (dictionary-ref *libraries* (mangle name)))) (define (library-exports name)",
-" (cdr (dictionary-ref *libraries* (mangle name)))) (define (library-import name ",
-"sym alias) (let ((uid (dictionary-ref (library-exports name) sym))) (let ((env (",
-"library-environment (current-library)))) (set-identifier! alias uid env)))) (def",
-"ine (library-export sym alias) (let ((env (library-environment (current-library)",
-")) (exports (library-exports (current-library)))) (dictionary-set! exports alias",
-" (find-identifier sym env)))) (define-macro define-library (lambda (form _) (let",
-" ((name (cadr form)) (body (cddr form))) (or (find-library name) (make-library n",
-"ame)) (parameterize ((current-library name)) (for-each (lambda (expr) (eval expr",
-" name)) body))))) (define-macro cond-expand (lambda (form _) (letrec ((test (lam",
-"bda (form) (or (eq? form 'else) (and (symbol? form) (memq form (features))) (and",
-" (pair? form) (case (car form) ((library) (find-library (cadr form))) ((not) (no",
-"t (test (cadr form)))) ((and) (let loop ((form (cdr form))) (or (null? form) (an",
-"d (test (car form)) (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (a",
-"nd (pair? form) (or (test (car form)) (loop (cdr form)))))) (else #f))))))) (let",
-" loop ((clauses (cdr form))) (if (null? clauses) #undefined (if (test (caar clau",
-"ses)) `(,the-begin ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro im",
-"port (lambda (form _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (la",
-"mbda (prefix symbol) (string->symbol (string-append (symbol->string prefix) (sym",
-"bol->string symbol))))) (getlib (lambda (name) (if (find-library name) name (err",
-"or \"library not found\" name))))) (letrec ((extract (lambda (spec) (case (car spe",
-"c) ((only rename prefix except) (extract (cadr spec))) (else (getlib spec))))) (",
-"collect (lambda (spec) (case (car spec) ((only) (let ((alist (collect (cadr spec",
-")))) (map (lambda (var) (assq var alist)) (cddr spec)))) ((rename) (let ((alist ",
-"(collect (cadr spec))) (renames (map (lambda (x) `(,(car x) unquote (cadr x))) (",
-"cddr spec)))) (map (lambda (s) (or (assq (car s) renames) s)) alist))) ((prefix)",
-" (let ((alist (collect (cadr spec)))) (map (lambda (s) (cons (prefix (caddr spec",
-") (car s)) (cdr s))) alist))) ((except) (let ((alist (collect (cadr spec)))) (le",
-"t loop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cddr spec))",
-" (loop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (dictionary",
-"-map (lambda (x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((imp",
-"ort (lambda (spec) (let ((lib (extract spec)) (alist (collect spec))) (for-each ",
-"(lambda (slot) (library-import lib (cdr slot) (car slot))) alist))))) (for-each ",
-"import (cdr form))))))) (define-macro export (lambda (form _) (letrec ((collect ",
-"(lambda (spec) (cond ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (",
-"= (length spec) 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-",
-"ref spec 2))) (else (error \"malformed export\"))))) (export (lambda (spec) (let (",
-"(slot (collect spec))) (library-export (car slot) (cdr slot)))))) (for-each expo",
-"rt (cdr form))))) (let () (make-library '(picrin base)) (set-car! (dictionary-re",
-"f *libraries* (mangle '(picrin base))) default-environment) (let ((export-keywor",
-"ds (lambda (keywords) (let ((env (library-environment '(picrin base))) (exports ",
-"(library-exports '(picrin base)))) (for-each (lambda (keyword) (dictionary-set! ",
-"exports keyword keyword)) keywords))))) (export-keywords '(define lambda quote s",
-"et! if begin define-macro let let* letrec letrec* let-values let*-values define-",
-"values quasiquote unquote unquote-splicing and or cond case else => do when unle",
-"ss parameterize define-syntax syntax-quote syntax-unquote syntax-quasiquote synt",
-"ax-unquote-splicing let-syntax letrec-syntax syntax-error)) (export-keywords '(f",
-"eatures eq? eqv? equal? not boolean? boolean=? pair? cons car cdr null? set-car!",
-" set-cdr! caar cadr cdar cddr list? make-list list length append reverse list-ta",
-"il list-ref list-set! list-copy map for-each memq memv member assq assv assoc cu",
-"rrent-input-port current-output-port current-error-port port? input-port? output",
-"-port? port-open? close-port eof-object? eof-object read-u8 peek-u8 read-bytevec",
-"tor! write-u8 write-bytevector flush-output-port open-input-bytevector open-outp",
-"ut-bytevector get-output-bytevector number? exact? inexact? inexact exact = < > ",
-"<= >= + - * / number->string string->number procedure? apply symbol? symbol=? sy",
-"mbol->string string->symbol make-identifier identifier? identifier=? identifier-",
-"base identifier-environment vector? vector make-vector vector-length vector-ref ",
-"vector-set! vector-copy! vector-copy vector-append vector-fill! vector-map vecto",
-"r-for-each list->vector vector->list string->vector vector->string bytevector? b",
-"ytevector make-bytevector bytevector-length bytevector-u8-ref bytevector-u8-set!",
-" bytevector-copy! bytevector-copy bytevector-append bytevector->list list->bytev",
-"ector call-with-current-continuation call/cc values call-with-values char? char-",
-">integer integer->char char=? char<? char>? char<=? char>=? current-exception-ha",
-"ndlers with-exception-handler raise raise-continuable error error-object? error-",
-"object-message error-object-irritants error-object-type string? string make-stri",
-"ng string-length string-ref string-set! string-copy string-copy! string-fill! st",
-"ring-append string-map string-for-each list->string string->list string=? string",
-"<? string>? string<=? string>=? make-parameter with-dynamic-environment read mak",
-"e-dictionary dictionary? dictionary dictionary-has? dictionary-ref dictionary-se",
-"t! dictionary-delete! dictionary-size dictionary-map dictionary-for-each diction",
-"ary->alist alist->dictionary dictionary->plist plist->dictionary make-record rec",
-"ord? record-type record-datum default-environment make-environment find-identifi",
-"er set-identifier! eval make-ephemeron-table write write-simple write-shared dis",
-"play)) (export-keywords '(find-library make-library current-library))) (set! eva",
-"l (let ((e eval)) (lambda (expr . lib) (let ((lib (if (null? lib) (current-libra",
-"ry) (car lib)))) (e expr (library-environment lib)))))) (make-library '(picrin u",
-"ser)) (current-library '(picrin user))) ",
-};
-
-void
-pic_boot(pic_state *pic)
-{
-  pic_load_cstr(pic, &boot_rom[0][0]);
-}

lib/ext/cont.c

@@ -0,0 +1,125 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <picrin.h>
+#include "../value.h"
+#include "../object.h"
+#include "../state.h"
+
+#if PIC_USE_CONT
+
+/*
+ * [(reset e)]k = k ([e] halt ())
+ * [(shift e)]k = [e] halt (\c x, c (k x))
+ */
+
+static pic_value
+pic_cont_reset(pic_state *pic)
+{
+  pic_value thunk, prev = pic_ref(pic, "__picrin_dynenv__");
+  struct context cxt;
+
+  pic_get_args(pic, "l", &thunk);
+
+  CONTEXT_INITK(pic, &cxt, thunk, pic->halt, 0, (pic_value *) NULL);
+  cxt.reset = 1;
+  pic_vm(pic, &cxt);
+  pic_set(pic, "__picrin_dynenv__", prev);
+  return pic_protect(pic, cxt.fp->regs[1]);
+}
+
+static pic_value
+shift_call(pic_state *pic)
+{
+  pic_value x, prev = pic_ref(pic, "__picrin_dynenv__");
+  struct context cxt;
+
+  pic_get_args(pic, "o", &x);
+
+  CONTEXT_INIT(pic, &cxt, pic_closure_ref(pic, 0), 1, &x);
+  cxt.reset = 1;
+  pic_set(pic, "__picrin_dynenv__", pic_closure_ref(pic, 1));
+  pic_vm(pic, &cxt);
+  pic_set(pic, "__picrin_dynenv__", prev);
+  return pic_protect(pic, cxt.fp->regs[1]);
+}
+
+static pic_value
+pic_cont_shift(pic_state *pic)
+{
+  pic_value f, k;
+
+  pic_get_args(pic, "l", &f);
+
+  if (! pic->cxt->reset) {
+    pic_error(pic, "c function call interleaved in delimited continuation", 0);
+  }
+
+  k = pic_lambda(pic, shift_call, 2, pic->cxt->fp->regs[1], pic_ref(pic, "__picrin_dynenv__"));
+  CONTEXT_INITK(pic, pic->cxt, f, pic->halt, 1, &k);
+  return pic_invalid_value(pic);
+}
+
+static pic_value
+cont_call(pic_state *pic)
+{
+  int argc;
+  pic_value *argv, k, dyn_env;
+  struct context *cxt;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  if (! pic_bool(pic, pic_closure_ref(pic, 0))) {
+    pic_error(pic, "calling dead escape continuation", 0);
+  }
+
+  cxt = pic_data(pic, pic_closure_ref(pic, 1));
+  k = pic_closure_ref(pic, 2);
+  dyn_env = pic_closure_ref(pic, 3);
+
+  CONTEXT_INIT(pic, cxt, k, argc, argv);
+
+  while (pic->cxt != cxt) {
+    pic_value c, it;
+    pic_for_each (c, pic->cxt->conts, it) {
+      proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+    }
+    pic->cxt = pic->cxt->prev;
+  }
+  pic_set(pic, "__picrin_dynenv__", dyn_env);
+
+  longjmp(cxt->jmp, 1);
+  PIC_UNREACHABLE();
+}
+
+pic_value
+pic_make_cont(pic_state *pic, pic_value k)
+{
+  static const pic_data_type cxt_type = { "cxt", NULL };
+  pic_value c;
+  c = pic_lambda(pic, cont_call, 4, pic_true_value(pic), pic_data_value(pic, pic->cxt, &cxt_type), k, pic_ref(pic, "__picrin_dynenv__"));
+  pic->cxt->conts = pic_cons(pic, c, pic->cxt->conts);
+  return c;
+}
+
+static pic_value
+pic_cont_callcc(pic_state *pic)
+{
+  pic_value f;
+
+  pic_get_args(pic, "l", &f);
+
+  return pic_callk(pic, f, 1, pic_make_cont(pic, pic->cxt->fp->regs[1]));
+}
+
+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, "shift", pic_cont_shift);
+  pic_defun(pic, "reset", pic_cont_reset);
+}
+
+#endif  /* PIC_USE_CALCC */

lib/ext/error.c

@@ -0,0 +1,409 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <picrin.h>
+#include "../value.h"
+#include "../object.h"
+#include "../state.h"
+
+#if PIC_USE_ERROR
+
+# define pic_exc(pic) pic_ref(pic, "current-exception-handlers")
+
+PIC_JMPBUF *
+pic_prepare_try(pic_state *pic)
+{
+  struct context *cxt = pic_malloc(pic, sizeof(struct context));
+
+  cxt->pc = NULL;
+  cxt->fp = NULL;
+  cxt->sp = NULL;
+  cxt->irep = NULL;
+  cxt->conts = pic_nil_value(pic);
+  cxt->prev = pic->cxt;
+  pic->cxt = cxt;
+  return &cxt->jmp;
+}
+
+static pic_value
+native_exception_handler(pic_state *pic)
+{
+  pic_value err;
+
+  pic_get_args(pic, "o", &err);
+
+  pic_call(pic, pic_closure_ref(pic, 0), 1, err);
+  PIC_UNREACHABLE();
+}
+
+void
+pic_enter_try(pic_state *pic)
+{
+  pic_value cont, handler;
+  pic_value var, env;
+
+  pic->cxt->ai = pic->ai;
+
+  /* call/cc */
+  cont = pic_make_cont(pic, pic_invalid_value(pic));
+  handler = pic_lambda(pic, native_exception_handler, 1, cont);
+  /* with-exception-handler */
+  var = pic_exc(pic);
+  env = pic_make_attr(pic);
+  pic_attr_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
+  pic_set(pic, "__picrin_dynenv__", pic_cons(pic, env, pic_ref(pic, "__picrin_dynenv__")));
+
+  pic_leave(pic, pic->cxt->ai);
+}
+
+void
+pic_exit_try(pic_state *pic)
+{
+  struct context *cxt = pic->cxt;
+  pic_value c, it;
+  pic_set(pic, "__picrin_dynenv__", pic_cdr(pic, pic_ref(pic, "__picrin_dynenv__")));
+  pic_for_each (c, cxt->conts, it) {
+    proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+  }
+  pic->cxt = cxt->prev;
+  pic_free(pic, cxt);
+  /* don't rewind ai here */
+}
+
+pic_value
+pic_abort_try(pic_state *pic)
+{
+  struct context *cxt = pic->cxt;
+  pic_value c, it;
+  pic_value err = cxt->sp->regs[1];
+  pic_for_each (c, cxt->conts, it) {
+    proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+  }
+  pic->cxt = cxt->prev;
+  pic_free(pic, cxt);
+  pic_protect(pic, err);
+  return err;
+}
+
+#endif
+
+#if PIC_USE_ERROR
+static const unsigned char error_rom[] = {
+0x03, 0x01, 0x00, 0x04, 0x02, 0x01, 0x0b, 0x00, 0x00, 0x00, 0x02, 0x05,
+0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x00, 0x02, 0x00, 0x00,
+0x02, 0x01, 0x01, 0x06, 0x02, 0x00, 0x01, 0x02, 0x02, 0x00, 0x04, 0x01,
+0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x04, 0x00, 0x00, 0x00, 0x6c, 0x69,
+0x73, 0x74, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00,
+0x02, 0x01, 0x02, 0x01, 0x00, 0x04, 0x00, 0x01, 0x0d, 0x00, 0x00, 0x00,
+0x02, 0x0e, 0x00, 0x00, 0x00, 0x6d, 0x61, 0x6b, 0x65, 0x2d, 0x70, 0x61,
+0x72, 0x61, 0x6d, 0x65, 0x74, 0x65, 0x72, 0x00, 0x06, 0x00, 0x00, 0x04,
+0x01, 0x01, 0x01, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x01, 0x00, 0x04,
+0x0b, 0x0b, 0x48, 0x00, 0x00, 0x00, 0x02, 0x1a, 0x00, 0x00, 0x00, 0x63,
+0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d, 0x65, 0x78, 0x63, 0x65, 0x70,
+0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x68, 0x61, 0x6e, 0x64, 0x6c, 0x65, 0x72,
+0x73, 0x00, 0x02, 0x05, 0x00, 0x00, 0x00, 0x72, 0x61, 0x69, 0x73, 0x65,
+0x00, 0x02, 0x11, 0x00, 0x00, 0x00, 0x72, 0x61, 0x69, 0x73, 0x65, 0x2d,
+0x63, 0x6f, 0x6e, 0x74, 0x69, 0x6e, 0x75, 0x61, 0x62, 0x6c, 0x65, 0x00,
+0x02, 0x16, 0x00, 0x00, 0x00, 0x77, 0x69, 0x74, 0x68, 0x2d, 0x65, 0x78,
+0x63, 0x65, 0x70, 0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x68, 0x61, 0x6e, 0x64,
+0x6c, 0x65, 0x72, 0x00, 0x02, 0x11, 0x00, 0x00, 0x00, 0x6d, 0x61, 0x6b,
+0x65, 0x2d, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62, 0x6a, 0x65,
+0x63, 0x74, 0x00, 0x02, 0x0d, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f,
+0x72, 0x2d, 0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x3f, 0x00, 0x02, 0x16,
+0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62, 0x6a,
+0x65, 0x63, 0x74, 0x2d, 0x69, 0x72, 0x72, 0x69, 0x74, 0x61, 0x6e, 0x74,
+0x73, 0x00, 0x02, 0x14, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72,
+0x2d, 0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x2d, 0x6d, 0x65, 0x73, 0x73,
+0x61, 0x67, 0x65, 0x00, 0x02, 0x11, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72,
+0x6f, 0x72, 0x2d, 0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x2d, 0x74, 0x79,
+0x70, 0x65, 0x00, 0x02, 0x05, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f,
+0x72, 0x00, 0x02, 0x07, 0x00, 0x00, 0x00, 0x64, 0x69, 0x73, 0x70, 0x6c,
+0x61, 0x79, 0x00, 0x04, 0x00, 0x00, 0x01, 0x07, 0x00, 0x00, 0x02, 0x00,
+0x00, 0x07, 0x00, 0x01, 0x02, 0x00, 0x01, 0x07, 0x00, 0x02, 0x02, 0x00,
+0x02, 0x07, 0x00, 0x03, 0x02, 0x00, 0x03, 0x07, 0x00, 0x04, 0x02, 0x00,
+0x04, 0x07, 0x00, 0x05, 0x02, 0x00, 0x05, 0x07, 0x00, 0x06, 0x02, 0x00,
+0x06, 0x07, 0x00, 0x07, 0x02, 0x00, 0x07, 0x07, 0x00, 0x08, 0x02, 0x00,
+0x08, 0x07, 0x00, 0x09, 0x02, 0x00, 0x09, 0x02, 0x01, 0x0a, 0x06, 0x02,
+0x0a, 0x01, 0x02, 0x02, 0x00, 0x03, 0x01, 0x01, 0x08, 0x00, 0x00, 0x00,
+0x02, 0x1a, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74,
+0x2d, 0x65, 0x78, 0x63, 0x65, 0x70, 0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x68,
+0x61, 0x6e, 0x64, 0x6c, 0x65, 0x72, 0x73, 0x00, 0x06, 0x00, 0x00, 0x02,
+0x01, 0x00, 0x01, 0x01, 0x01, 0x00, 0x04, 0x01, 0x00, 0x0d, 0x00, 0x00,
+0x00, 0x02, 0x00, 0x00, 0x04, 0x01, 0x01, 0x01, 0x04, 0x02, 0x00, 0x01,
+0x01, 0x02, 0x02, 0x00, 0x03, 0x01, 0x01, 0x08, 0x00, 0x00, 0x00, 0x02,
+0x0e, 0x00, 0x00, 0x00, 0x6d, 0x61, 0x6b, 0x65, 0x2d, 0x61, 0x74, 0x74,
+0x72, 0x69, 0x62, 0x75, 0x74, 0x65, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01,
+0x00, 0x01, 0x01, 0x01, 0x00, 0x03, 0x01, 0x01, 0x08, 0x00, 0x00, 0x00,
+0x02, 0x1b, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74,
+0x2d, 0x64, 0x79, 0x6e, 0x61, 0x6d, 0x69, 0x63, 0x2d, 0x65, 0x6e, 0x76,
+0x69, 0x72, 0x6f, 0x6e, 0x6d, 0x65, 0x6e, 0x74, 0x00, 0x06, 0x00, 0x00,
+0x02, 0x01, 0x00, 0x01, 0x01, 0x01, 0x00, 0x05, 0x01, 0x00, 0x11, 0x00,
+0x00, 0x00, 0x02, 0x00, 0x00, 0x04, 0x01, 0x02, 0x01, 0x04, 0x02, 0x01,
+0x01, 0x04, 0x03, 0x00, 0x01, 0x01, 0x03, 0x03, 0x00, 0x05, 0x01, 0x01,
+0x10, 0x00, 0x00, 0x00, 0x02, 0x04, 0x00, 0x00, 0x00, 0x63, 0x6f, 0x6e,
+0x73, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x02,
+0x04, 0x03, 0x00, 0x03, 0x01, 0x03, 0x01, 0x00, 0x04, 0x01, 0x01, 0x0c,
+0x00, 0x00, 0x00, 0x02, 0x1b, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72,
+0x65, 0x6e, 0x74, 0x2d, 0x64, 0x79, 0x6e, 0x61, 0x6d, 0x69, 0x63, 0x2d,
+0x65, 0x6e, 0x76, 0x69, 0x72, 0x6f, 0x6e, 0x6d, 0x65, 0x6e, 0x74, 0x00,
+0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02,
+0x01, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x03, 0x00,
+0x00, 0x00, 0x63, 0x64, 0x72, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00,
+0x04, 0x02, 0x05, 0x02, 0x01, 0x02, 0x01, 0x00, 0x04, 0x01, 0x01, 0x0c,
+0x00, 0x00, 0x00, 0x02, 0x1a, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72,
+0x65, 0x6e, 0x74, 0x2d, 0x65, 0x78, 0x63, 0x65, 0x70, 0x74, 0x69, 0x6f,
+0x6e, 0x2d, 0x68, 0x61, 0x6e, 0x64, 0x6c, 0x65, 0x72, 0x73, 0x00, 0x06,
+0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x01,
+0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x03, 0x00, 0x00,
+0x00, 0x63, 0x61, 0x72, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04,
+0x02, 0x07, 0x02, 0x01, 0x02, 0x01, 0x00, 0x04, 0x01, 0x00, 0x0d, 0x00,
+0x00, 0x00, 0x04, 0x00, 0x00, 0x01, 0x02, 0x01, 0x00, 0x04, 0x02, 0x0a,
+0x02, 0x01, 0x02, 0x01, 0x00, 0x05, 0x01, 0x02, 0x0f, 0x00, 0x00, 0x00,
+0x02, 0x05, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x00, 0x01,
+0x10, 0x00, 0x00, 0x00, 0x68, 0x61, 0x6e, 0x64, 0x6c, 0x65, 0x72, 0x20,
+0x72, 0x65, 0x74, 0x75, 0x72, 0x6e, 0x65, 0x64, 0x00, 0x06, 0x00, 0x00,
+0x02, 0x01, 0x00, 0x03, 0x02, 0x01, 0x04, 0x03, 0x0b, 0x02, 0x01, 0x03,
+0x01, 0x00, 0x04, 0x01, 0x00, 0x0d, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00,
+0x04, 0x01, 0x07, 0x01, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x02, 0x00,
+0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x1b, 0x00, 0x00, 0x00,
+0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d, 0x64, 0x79, 0x6e, 0x61,
+0x6d, 0x69, 0x63, 0x2d, 0x65, 0x6e, 0x76, 0x69, 0x72, 0x6f, 0x6e, 0x6d,
+0x65, 0x6e, 0x74, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02,
+0x08, 0x03, 0x01, 0x02, 0x01, 0x00, 0x03, 0x00, 0x00, 0x0a, 0x00, 0x00,
+0x00, 0x04, 0x00, 0x01, 0x01, 0x04, 0x01, 0x01, 0x02, 0x01, 0x01, 0x02,
+0x00, 0x03, 0x01, 0x01, 0x08, 0x00, 0x00, 0x00, 0x02, 0x1a, 0x00, 0x00,
+0x00, 0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d, 0x65, 0x78, 0x63,
+0x65, 0x70, 0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x68, 0x61, 0x6e, 0x64, 0x6c,
+0x65, 0x72, 0x73, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x01, 0x01,
+0x01, 0x00, 0x04, 0x01, 0x00, 0x0d, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00,
+0x04, 0x01, 0x01, 0x01, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x02, 0x00,
+0x03, 0x01, 0x01, 0x08, 0x00, 0x00, 0x00, 0x02, 0x0e, 0x00, 0x00, 0x00,
+0x6d, 0x61, 0x6b, 0x65, 0x2d, 0x61, 0x74, 0x74, 0x72, 0x69, 0x62, 0x75,
+0x74, 0x65, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x01, 0x01, 0x01,
+0x00, 0x03, 0x01, 0x01, 0x08, 0x00, 0x00, 0x00, 0x02, 0x1b, 0x00, 0x00,
+0x00, 0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d, 0x64, 0x79, 0x6e,
+0x61, 0x6d, 0x69, 0x63, 0x2d, 0x65, 0x6e, 0x76, 0x69, 0x72, 0x6f, 0x6e,
+0x6d, 0x65, 0x6e, 0x74, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x01,
+0x01, 0x01, 0x00, 0x05, 0x01, 0x00, 0x11, 0x00, 0x00, 0x00, 0x02, 0x00,
+0x00, 0x04, 0x01, 0x02, 0x01, 0x04, 0x02, 0x01, 0x01, 0x04, 0x03, 0x00,
+0x01, 0x01, 0x03, 0x03, 0x00, 0x05, 0x01, 0x01, 0x10, 0x00, 0x00, 0x00,
+0x02, 0x04, 0x00, 0x00, 0x00, 0x63, 0x6f, 0x6e, 0x73, 0x00, 0x06, 0x00,
+0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x02, 0x04, 0x03, 0x00, 0x03,
+0x01, 0x03, 0x01, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02,
+0x1b, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d,
+0x64, 0x79, 0x6e, 0x61, 0x6d, 0x69, 0x63, 0x2d, 0x65, 0x6e, 0x76, 0x69,
+0x72, 0x6f, 0x6e, 0x6d, 0x65, 0x6e, 0x74, 0x00, 0x06, 0x00, 0x00, 0x02,
+0x01, 0x00, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x01, 0x00, 0x04, 0x01,
+0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x03, 0x00, 0x00, 0x00, 0x63, 0x64,
+0x72, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x05, 0x02,
+0x01, 0x02, 0x01, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02,
+0x1a, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d,
+0x65, 0x78, 0x63, 0x65, 0x70, 0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x68, 0x61,
+0x6e, 0x64, 0x6c, 0x65, 0x72, 0x73, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01,
+0x00, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x01, 0x00, 0x04, 0x01, 0x01,
+0x0c, 0x00, 0x00, 0x00, 0x02, 0x03, 0x00, 0x00, 0x00, 0x63, 0x61, 0x72,
+0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x07, 0x02, 0x01,
+0x02, 0x01, 0x00, 0x04, 0x01, 0x00, 0x0d, 0x00, 0x00, 0x00, 0x04, 0x00,
+0x00, 0x01, 0x02, 0x01, 0x00, 0x04, 0x02, 0x0a, 0x02, 0x01, 0x02, 0x01,
+0x00, 0x04, 0x01, 0x00, 0x0d, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x04,
+0x01, 0x06, 0x01, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x02, 0x00, 0x04,
+0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x1b, 0x00, 0x00, 0x00, 0x63,
+0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d, 0x64, 0x79, 0x6e, 0x61, 0x6d,
+0x69, 0x63, 0x2d, 0x65, 0x6e, 0x76, 0x69, 0x72, 0x6f, 0x6e, 0x6d, 0x65,
+0x6e, 0x74, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x07,
+0x03, 0x01, 0x02, 0x01, 0x00, 0x03, 0x00, 0x00, 0x0a, 0x00, 0x00, 0x00,
+0x04, 0x00, 0x01, 0x01, 0x04, 0x01, 0x01, 0x02, 0x01, 0x01, 0x03, 0x00,
+0x03, 0x01, 0x01, 0x08, 0x00, 0x00, 0x00, 0x02, 0x1a, 0x00, 0x00, 0x00,
+0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d, 0x65, 0x78, 0x63, 0x65,
+0x70, 0x74, 0x69, 0x6f, 0x6e, 0x2d, 0x68, 0x61, 0x6e, 0x64, 0x6c, 0x65,
+0x72, 0x73, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x01, 0x01, 0x01,
+0x00, 0x04, 0x01, 0x00, 0x0d, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x04,
+0x01, 0x01, 0x01, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x02, 0x00, 0x03,
+0x01, 0x01, 0x08, 0x00, 0x00, 0x00, 0x02, 0x0e, 0x00, 0x00, 0x00, 0x6d,
+0x61, 0x6b, 0x65, 0x2d, 0x61, 0x74, 0x74, 0x72, 0x69, 0x62, 0x75, 0x74,
+0x65, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x01, 0x01, 0x01, 0x00,
+0x03, 0x01, 0x01, 0x08, 0x00, 0x00, 0x00, 0x02, 0x1b, 0x00, 0x00, 0x00,
+0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d, 0x64, 0x79, 0x6e, 0x61,
+0x6d, 0x69, 0x63, 0x2d, 0x65, 0x6e, 0x76, 0x69, 0x72, 0x6f, 0x6e, 0x6d,
+0x65, 0x6e, 0x74, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x01, 0x01,
+0x01, 0x00, 0x05, 0x01, 0x00, 0x11, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00,
+0x04, 0x01, 0x02, 0x01, 0x04, 0x02, 0x01, 0x01, 0x04, 0x03, 0x00, 0x01,
+0x01, 0x03, 0x03, 0x00, 0x05, 0x01, 0x01, 0x10, 0x00, 0x00, 0x00, 0x02,
+0x04, 0x00, 0x00, 0x00, 0x63, 0x6f, 0x6e, 0x73, 0x00, 0x06, 0x00, 0x00,
+0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x02, 0x04, 0x03, 0x00, 0x03, 0x01,
+0x03, 0x01, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x1b,
+0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74, 0x2d, 0x64,
+0x79, 0x6e, 0x61, 0x6d, 0x69, 0x63, 0x2d, 0x65, 0x6e, 0x76, 0x69, 0x72,
+0x6f, 0x6e, 0x6d, 0x65, 0x6e, 0x74, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01,
+0x00, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x01, 0x00, 0x05, 0x01, 0x01,
+0x10, 0x00, 0x00, 0x00, 0x02, 0x04, 0x00, 0x00, 0x00, 0x63, 0x6f, 0x6e,
+0x73, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x07, 0x02,
+0x04, 0x03, 0x05, 0x02, 0x01, 0x03, 0x01, 0x00, 0x04, 0x01, 0x01, 0x0c,
+0x00, 0x00, 0x00, 0x02, 0x1a, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72,
+0x65, 0x6e, 0x74, 0x2d, 0x65, 0x78, 0x63, 0x65, 0x70, 0x74, 0x69, 0x6f,
+0x6e, 0x2d, 0x68, 0x61, 0x6e, 0x64, 0x6c, 0x65, 0x72, 0x73, 0x00, 0x06,
+0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x01,
+0x00, 0x03, 0x01, 0x00, 0x09, 0x00, 0x00, 0x00, 0x04, 0x00, 0x09, 0x03,
+0x02, 0x01, 0x00, 0x01, 0x01, 0x01, 0x00, 0x04, 0x01, 0x00, 0x0d, 0x00,
+0x00, 0x00, 0x02, 0x00, 0x00, 0x04, 0x01, 0x05, 0x01, 0x04, 0x02, 0x00,
+0x01, 0x01, 0x02, 0x02, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00,
+0x02, 0x1b, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72, 0x65, 0x6e, 0x74,
+0x2d, 0x64, 0x79, 0x6e, 0x61, 0x6d, 0x69, 0x63, 0x2d, 0x65, 0x6e, 0x76,
+0x69, 0x72, 0x6f, 0x6e, 0x6d, 0x65, 0x6e, 0x74, 0x00, 0x06, 0x00, 0x00,
+0x02, 0x01, 0x00, 0x04, 0x02, 0x06, 0x03, 0x01, 0x02, 0x01, 0x00, 0x03,
+0x00, 0x00, 0x0a, 0x00, 0x00, 0x00, 0x04, 0x00, 0x01, 0x01, 0x04, 0x01,
+0x01, 0x02, 0x01, 0x01, 0x04, 0x00, 0x06, 0x01, 0x01, 0x14, 0x00, 0x00,
+0x00, 0x02, 0x06, 0x00, 0x00, 0x00, 0x76, 0x65, 0x63, 0x74, 0x6f, 0x72,
+0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x02, 0x04,
+0x03, 0x00, 0x03, 0x04, 0x04, 0x00, 0x04, 0x01, 0x04, 0x01, 0x00, 0x05,
+0x00, 0x02, 0x10, 0x00, 0x00, 0x00, 0x02, 0x0b, 0x00, 0x00, 0x00, 0x6d,
+0x61, 0x6b, 0x65, 0x2d, 0x72, 0x65, 0x63, 0x6f, 0x72, 0x64, 0x00, 0x02,
+0x0c, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62,
+0x6a, 0x65, 0x63, 0x74, 0x00, 0x06, 0x00, 0x00, 0x04, 0x01, 0x01, 0x01,
+0x03, 0x02, 0x01, 0x04, 0x03, 0x00, 0x01, 0x01, 0x03, 0x02, 0x00, 0x04,
+0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x07, 0x00, 0x00, 0x00, 0x72,
+0x65, 0x63, 0x6f, 0x72, 0x64, 0x3f, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01,
+0x00, 0x04, 0x02, 0x00, 0x02, 0x01, 0x02, 0x01, 0x00, 0x04, 0x01, 0x01,
+0x1c, 0x00, 0x00, 0x00, 0x02, 0x0b, 0x00, 0x00, 0x00, 0x72, 0x65, 0x63,
+0x6f, 0x72, 0x64, 0x2d, 0x74, 0x79, 0x70, 0x65, 0x00, 0x04, 0x00, 0x00,
+0x01, 0x08, 0x00, 0x10, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04,
+0x02, 0x01, 0x02, 0x01, 0x02, 0x04, 0x00, 0x01, 0x01, 0x0a, 0x01, 0x01,
+0x01, 0x01, 0x00, 0x05, 0x00, 0x02, 0x10, 0x00, 0x00, 0x00, 0x02, 0x03,
+0x00, 0x00, 0x00, 0x65, 0x71, 0x3f, 0x00, 0x02, 0x0c, 0x00, 0x00, 0x00,
+0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74,
+0x00, 0x06, 0x00, 0x00, 0x04, 0x01, 0x02, 0x01, 0x04, 0x02, 0x00, 0x01,
+0x03, 0x03, 0x01, 0x01, 0x03, 0x02, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00,
+0x00, 0x00, 0x02, 0x0d, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72,
+0x2d, 0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x3f, 0x00, 0x06, 0x00, 0x00,
+0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x02, 0x01, 0x02, 0x01, 0x00, 0x06,
+0x01, 0x04, 0x27, 0x00, 0x00, 0x00, 0x02, 0x0c, 0x00, 0x00, 0x00, 0x72,
+0x65, 0x63, 0x6f, 0x72, 0x64, 0x2d, 0x64, 0x61, 0x74, 0x75, 0x6d, 0x00,
+0x02, 0x05, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x00, 0x01,
+0x14, 0x00, 0x00, 0x00, 0x72, 0x65, 0x63, 0x6f, 0x72, 0x64, 0x20, 0x74,
+0x79, 0x70, 0x65, 0x20, 0x6d, 0x69, 0x73, 0x6d, 0x61, 0x74, 0x63, 0x68,
+0x00, 0x02, 0x0c, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d,
+0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x00, 0x04, 0x00, 0x00, 0x01, 0x08,
+0x00, 0x10, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x01,
+0x02, 0x01, 0x02, 0x06, 0x00, 0x01, 0x04, 0x01, 0x01, 0x01, 0x03, 0x02,
+0x02, 0x04, 0x03, 0x01, 0x02, 0x03, 0x04, 0x03, 0x01, 0x04, 0x01, 0x00,
+0x05, 0x00, 0x01, 0x10, 0x00, 0x00, 0x00, 0x02, 0x0a, 0x00, 0x00, 0x00,
+0x76, 0x65, 0x63, 0x74, 0x6f, 0x72, 0x2d, 0x72, 0x65, 0x66, 0x00, 0x06,
+0x00, 0x00, 0x04, 0x01, 0x02, 0x01, 0x04, 0x02, 0x00, 0x01, 0x0d, 0x03,
+0x02, 0x01, 0x03, 0x02, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00,
+0x02, 0x0d, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f,
+0x62, 0x6a, 0x65, 0x63, 0x74, 0x3f, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01,
+0x00, 0x04, 0x02, 0x00, 0x02, 0x01, 0x02, 0x01, 0x00, 0x06, 0x01, 0x04,
+0x27, 0x00, 0x00, 0x00, 0x02, 0x0c, 0x00, 0x00, 0x00, 0x72, 0x65, 0x63,
+0x6f, 0x72, 0x64, 0x2d, 0x64, 0x61, 0x74, 0x75, 0x6d, 0x00, 0x02, 0x05,
+0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x00, 0x01, 0x14, 0x00,
+0x00, 0x00, 0x72, 0x65, 0x63, 0x6f, 0x72, 0x64, 0x20, 0x74, 0x79, 0x70,
+0x65, 0x20, 0x6d, 0x69, 0x73, 0x6d, 0x61, 0x74, 0x63, 0x68, 0x00, 0x02,
+0x0c, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62,
+0x6a, 0x65, 0x63, 0x74, 0x00, 0x04, 0x00, 0x00, 0x01, 0x08, 0x00, 0x10,
+0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x01, 0x02, 0x01,
+0x02, 0x06, 0x00, 0x01, 0x04, 0x01, 0x01, 0x01, 0x03, 0x02, 0x02, 0x04,
+0x03, 0x01, 0x02, 0x03, 0x04, 0x03, 0x01, 0x04, 0x01, 0x00, 0x05, 0x00,
+0x01, 0x10, 0x00, 0x00, 0x00, 0x02, 0x0a, 0x00, 0x00, 0x00, 0x76, 0x65,
+0x63, 0x74, 0x6f, 0x72, 0x2d, 0x72, 0x65, 0x66, 0x00, 0x06, 0x00, 0x00,
+0x04, 0x01, 0x02, 0x01, 0x04, 0x02, 0x00, 0x01, 0x0d, 0x03, 0x01, 0x01,
+0x03, 0x02, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x0d,
+0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62, 0x6a,
+0x65, 0x63, 0x74, 0x3f, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04,
+0x02, 0x00, 0x02, 0x01, 0x02, 0x01, 0x00, 0x06, 0x01, 0x04, 0x27, 0x00,
+0x00, 0x00, 0x02, 0x0c, 0x00, 0x00, 0x00, 0x72, 0x65, 0x63, 0x6f, 0x72,
+0x64, 0x2d, 0x64, 0x61, 0x74, 0x75, 0x6d, 0x00, 0x02, 0x05, 0x00, 0x00,
+0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x00, 0x01, 0x14, 0x00, 0x00, 0x00,
+0x72, 0x65, 0x63, 0x6f, 0x72, 0x64, 0x20, 0x74, 0x79, 0x70, 0x65, 0x20,
+0x6d, 0x69, 0x73, 0x6d, 0x61, 0x74, 0x63, 0x68, 0x00, 0x02, 0x0c, 0x00,
+0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62, 0x6a, 0x65,
+0x63, 0x74, 0x00, 0x04, 0x00, 0x00, 0x01, 0x08, 0x00, 0x10, 0x00, 0x06,
+0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x01, 0x02, 0x01, 0x02, 0x06,
+0x00, 0x01, 0x04, 0x01, 0x01, 0x01, 0x03, 0x02, 0x02, 0x04, 0x03, 0x01,
+0x02, 0x03, 0x04, 0x03, 0x01, 0x04, 0x01, 0x00, 0x05, 0x00, 0x01, 0x10,
+0x00, 0x00, 0x00, 0x02, 0x0a, 0x00, 0x00, 0x00, 0x76, 0x65, 0x63, 0x74,
+0x6f, 0x72, 0x2d, 0x72, 0x65, 0x66, 0x00, 0x06, 0x00, 0x00, 0x04, 0x01,
+0x02, 0x01, 0x04, 0x02, 0x00, 0x01, 0x0d, 0x03, 0x00, 0x01, 0x03, 0x02,
+0x01, 0x06, 0x01, 0x01, 0x12, 0x00, 0x00, 0x00, 0x02, 0x11, 0x00, 0x00,
+0x00, 0x6d, 0x61, 0x6b, 0x65, 0x2d, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d,
+0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01,
+0x00, 0x0a, 0x02, 0x04, 0x03, 0x00, 0x02, 0x04, 0x04, 0x00, 0x03, 0x01,
+0x04, 0x01, 0x00, 0x04, 0x00, 0x01, 0x0d, 0x00, 0x00, 0x00, 0x02, 0x05,
+0x00, 0x00, 0x00, 0x72, 0x61, 0x69, 0x73, 0x65, 0x00, 0x06, 0x00, 0x00,
+0x04, 0x01, 0x01, 0x01, 0x04, 0x02, 0x00, 0x01, 0x01, 0x02, 0x02, 0x00,
+0x03, 0x01, 0x00, 0x09, 0x00, 0x00, 0x00, 0x04, 0x00, 0x00, 0x01, 0x02,
+0x01, 0x00, 0x01, 0x01, 0x02, 0x01, 0x03, 0x02, 0x00, 0x08, 0x00, 0x00,
+0x00, 0x02, 0x00, 0x00, 0x02, 0x01, 0x01, 0x01, 0x01, 0x01, 0x00, 0x04,
+0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x05, 0x00, 0x00, 0x00, 0x6e,
+0x75, 0x6c, 0x6c, 0x3f, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04,
+0x02, 0x01, 0x03, 0x01, 0x02, 0x01, 0x00, 0x04, 0x00, 0x02, 0x1e, 0x00,
+0x00, 0x00, 0x02, 0x12, 0x00, 0x00, 0x00, 0x63, 0x75, 0x72, 0x72, 0x65,
+0x6e, 0x74, 0x2d, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x70, 0x6f, 0x72,
+0x74, 0x00, 0x02, 0x03, 0x00, 0x00, 0x00, 0x63, 0x61, 0x72, 0x00, 0x04,
+0x00, 0x00, 0x01, 0x08, 0x00, 0x0d, 0x00, 0x06, 0x00, 0x00, 0x04, 0x01,
+0x01, 0x01, 0x01, 0x01, 0x06, 0x00, 0x01, 0x04, 0x01, 0x01, 0x01, 0x04,
+0x02, 0x02, 0x03, 0x01, 0x02, 0x01, 0x00, 0x04, 0x01, 0x00, 0x0d, 0x00,
+0x00, 0x00, 0x02, 0x00, 0x00, 0x04, 0x01, 0x01, 0x01, 0x04, 0x02, 0x00,
+0x01, 0x01, 0x02, 0x02, 0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00,
+0x02, 0x0d, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f,
+0x62, 0x6a, 0x65, 0x63, 0x74, 0x3f, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01,
+0x00, 0x04, 0x02, 0x02, 0x02, 0x01, 0x02, 0x01, 0x00, 0x05, 0x01, 0x00,
+0x23, 0x00, 0x00, 0x00, 0x04, 0x00, 0x00, 0x01, 0x08, 0x00, 0x0d, 0x00,
+0x02, 0x00, 0x00, 0x04, 0x01, 0x01, 0x01, 0x01, 0x01, 0x04, 0x00, 0x04,
+0x02, 0x04, 0x01, 0x01, 0x01, 0x04, 0x02, 0x03, 0x02, 0x04, 0x03, 0x01,
+0x02, 0x01, 0x03, 0x01, 0x00, 0x03, 0x02, 0x00, 0x08, 0x00, 0x00, 0x00,
+0x02, 0x00, 0x00, 0x02, 0x01, 0x01, 0x01, 0x01, 0x01, 0x00, 0x04, 0x01,
+0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x11, 0x00, 0x00, 0x00, 0x65, 0x72,
+0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x2d, 0x74,
+0x79, 0x70, 0x65, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02,
+0x05, 0x02, 0x01, 0x02, 0x01, 0x00, 0x04, 0x01, 0x01, 0x1c, 0x00, 0x00,
+0x00, 0x02, 0x11, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d,
+0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x2d, 0x74, 0x79, 0x70, 0x65, 0x00,
+0x04, 0x00, 0x00, 0x01, 0x08, 0x00, 0x10, 0x00, 0x06, 0x00, 0x00, 0x02,
+0x01, 0x00, 0x04, 0x02, 0x06, 0x02, 0x01, 0x02, 0x04, 0x00, 0x01, 0x01,
+0x0c, 0x01, 0x01, 0x01, 0x01, 0x00, 0x05, 0x01, 0x00, 0x11, 0x00, 0x00,
+0x00, 0x04, 0x00, 0x08, 0x02, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00, 0x01,
+0x04, 0x03, 0x05, 0x02, 0x01, 0x03, 0x01, 0x00, 0x05, 0x00, 0x01, 0x11,
+0x00, 0x00, 0x00, 0x01, 0x01, 0x00, 0x00, 0x00, 0x2d, 0x00, 0x04, 0x00,
+0x09, 0x02, 0x04, 0x01, 0x03, 0x01, 0x03, 0x02, 0x00, 0x04, 0x03, 0x06,
+0x02, 0x01, 0x03, 0x01, 0x00, 0x05, 0x01, 0x01, 0x10, 0x00, 0x00, 0x00,
+0x01, 0x08, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x3a, 0x20,
+0x22, 0x00, 0x04, 0x00, 0x06, 0x02, 0x02, 0x01, 0x00, 0x03, 0x02, 0x00,
+0x04, 0x03, 0x03, 0x02, 0x01, 0x03, 0x01, 0x00, 0x04, 0x01, 0x01, 0x0c,
+0x00, 0x00, 0x00, 0x02, 0x14, 0x00, 0x00, 0x00, 0x65, 0x72, 0x72, 0x6f,
+0x72, 0x2d, 0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x2d, 0x6d, 0x65, 0x73,
+0x73, 0x61, 0x67, 0x65, 0x00, 0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04,
+0x02, 0x06, 0x02, 0x01, 0x02, 0x01, 0x00, 0x05, 0x01, 0x00, 0x11, 0x00,
+0x00, 0x00, 0x04, 0x00, 0x08, 0x02, 0x02, 0x01, 0x00, 0x04, 0x02, 0x00,
+0x01, 0x04, 0x03, 0x05, 0x02, 0x01, 0x03, 0x01, 0x00, 0x04, 0x01, 0x01,
+0x0c, 0x00, 0x00, 0x00, 0x01, 0x01, 0x00, 0x00, 0x00, 0x22, 0x00, 0x04,
+0x00, 0x09, 0x02, 0x02, 0x01, 0x00, 0x03, 0x02, 0x00, 0x01, 0x02, 0x01,
+0x00, 0x04, 0x01, 0x01, 0x0c, 0x00, 0x00, 0x00, 0x02, 0x16, 0x00, 0x00,
+0x00, 0x65, 0x72, 0x72, 0x6f, 0x72, 0x2d, 0x6f, 0x62, 0x6a, 0x65, 0x63,
+0x74, 0x2d, 0x69, 0x72, 0x72, 0x69, 0x74, 0x61, 0x6e, 0x74, 0x73, 0x00,
+0x06, 0x00, 0x00, 0x02, 0x01, 0x00, 0x04, 0x02, 0x09, 0x02, 0x01, 0x02,
+0x01, 0x00, 0x05, 0x02, 0x01, 0x0f, 0x00, 0x00, 0x00, 0x02, 0x08, 0x00,
+0x00, 0x00, 0x66, 0x6f, 0x72, 0x2d, 0x65, 0x61, 0x63, 0x68, 0x00, 0x06,
+0x00, 0x00, 0x02, 0x01, 0x00, 0x02, 0x02, 0x01, 0x04, 0x03, 0x00, 0x01,
+0x01, 0x03, 0x01, 0x00, 0x05, 0x00, 0x01, 0x11, 0x00, 0x00, 0x00, 0x01,
+0x01, 0x00, 0x00, 0x00, 0x0a, 0x00, 0x04, 0x00, 0x0c, 0x02, 0x04, 0x01,
+0x07, 0x01, 0x03, 0x02, 0x00, 0x04, 0x03, 0x09, 0x02, 0x01, 0x03, 0x02,
+0x00, 0x05, 0x01, 0x01, 0x10, 0x00, 0x00, 0x00, 0x01, 0x01, 0x00, 0x00,
+0x00, 0x20, 0x00, 0x04, 0x00, 0x0c, 0x02, 0x02, 0x01, 0x00, 0x03, 0x02,
+0x00, 0x04, 0x03, 0x09, 0x02, 0x01, 0x03, 0x01, 0x00, 0x05, 0x00, 0x01,
+0x11, 0x00, 0x00, 0x00, 0x02, 0x05, 0x00, 0x00, 0x00, 0x77, 0x72, 0x69,
+0x74, 0x65, 0x00, 0x06, 0x00, 0x00, 0x04, 0x01, 0x01, 0x01, 0x04, 0x02,
+0x01, 0x02, 0x04, 0x03, 0x0a, 0x02, 0x01, 0x03, 0x01, 0x00, 0x03, 0x00,
+0x01, 0x0f, 0x00, 0x00, 0x00, 0x02, 0x07, 0x00, 0x00, 0x00, 0x64, 0x69,
+0x73, 0x70, 0x6c, 0x61, 0x79, 0x00, 0x04, 0x00, 0x00, 0x01, 0x07, 0x00,
+0x00, 0x04, 0x00, 0x02, 0x01, 0x0c, 0x01, 0x01, 0x01, 
+};
+#endif
+
+void
+pic_init_error(pic_state *PIC_UNUSED(pic))
+{
+#if PIC_USE_ERROR
+  pic_call(pic, pic_deserialize(pic, pic_blob_value(pic, error_rom, sizeof error_rom)), 0);
+#endif
+}

lib/ext/file.c

@@ -0,0 +1,205 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdio.h>
+
+#include <picrin.h>
+#include <picrin/extra.h>
+#include "../value.h"
+#include "../object.h"
+
+#if PIC_USE_FILE
+
+static int
+file_read(pic_state *PIC_UNUSED(pic), void *cookie, char *ptr, int size) {
+  FILE *file = cookie;
+  int r;
+
+  size = 1;                     /* override size */
+
+  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 int
+file_write(pic_state *PIC_UNUSED(pic), 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;
+  }
+  fflush(cookie);
+  return r;
+}
+
+static long
+file_seek(pic_state *PIC_UNUSED(pic), void *cookie, long pos, int whence) {
+  switch (whence) {
+  case PIC_SEEK_CUR:
+    whence = SEEK_CUR;
+    break;
+  case PIC_SEEK_SET:
+    whence = SEEK_SET;
+    break;
+  case PIC_SEEK_END:
+    whence = SEEK_END;
+    break;
+  }
+  if (fseek(cookie, pos, whence) == 0) {
+    return ftell(cookie);
+  }
+  return -1;
+}
+
+static int
+file_close(pic_state *PIC_UNUSED(pic), void *cookie) {
+  return fclose(cookie);
+}
+
+pic_value
+pic_fopen(pic_state *pic, FILE *fp, const char *mode) {
+  static const pic_port_type file_rd = { file_read, 0, file_seek, file_close };
+  static const pic_port_type file_wr = { 0, file_write, file_seek, file_close };
+
+  if (*mode == 'r') {
+    return pic_funopen(pic, fp, &file_rd);
+  } else {
+    return pic_funopen(pic, fp, &file_wr);
+  }
+}
+
+#if !PIC_USE_ERROR
+# define file_error pic_error
+#else
+PIC_NORETURN static void
+file_error(pic_state *pic, const char *msg, int n, ...)
+{
+  va_list ap;
+  pic_value e, irrs;
+
+  va_start(ap, n);
+  irrs = pic_vlist(pic, n, ap);
+  va_end(ap);
+
+  e = pic_funcall(pic, "make-error-object", 3, pic_intern_lit(pic, "file"), pic_cstr_value(pic, msg), irrs);
+  pic_funcall(pic, "raise", 1, e);
+  PIC_UNREACHABLE();
+}
+#endif
+
+pic_value
+pic_file_open_input_file(pic_state *pic)
+{
+  const char *fname;
+  FILE *fp;
+
+  pic_get_args(pic, "z", &fname);
+
+  if ((fp = fopen(fname, "r")) == NULL) {
+    file_error(pic, "could not open file", 1, pic_cstr_value(pic, fname));
+  }
+  return pic_fopen(pic, fp, "r");
+}
+
+pic_value
+pic_file_open_output_file(pic_state *pic)
+{
+  const char *fname;
+  FILE *fp;
+
+  pic_get_args(pic, "z", &fname);
+
+  if ((fp = fopen(fname, "w")) == NULL) {
+    file_error(pic, "could not open file", 1, pic_cstr_value(pic, fname));
+  }
+  return pic_fopen(pic, fp, "w");
+}
+
+pic_value
+pic_file_open_binary_input_file(pic_state *pic)
+{
+  const char *fname;
+  FILE *fp;
+
+  pic_get_args(pic, "z", &fname);
+
+  if ((fp = fopen(fname, "rb")) == NULL) {
+    file_error(pic, "could not open file", 1, pic_cstr_value(pic, fname));
+  }
+  return pic_fopen(pic, fp, "rb");
+}
+
+pic_value
+pic_file_open_binary_output_file(pic_state *pic)
+{
+  const char *fname;
+  FILE *fp;
+
+  pic_get_args(pic, "z", &fname);
+
+  if ((fp = fopen(fname, "wb")) == NULL) {
+    file_error(pic, "could not open file", 1, pic_cstr_value(pic, fname));
+  }
+  return pic_fopen(pic, fp, "wb");
+}
+
+pic_value
+pic_file_exists_p(pic_state *pic)
+{
+  const char *fname;
+  FILE *fp;
+
+  pic_get_args(pic, "z", &fname);
+
+  fp = fopen(fname, "r");
+  if (fp) {
+    fclose(fp);
+  }
+  return pic_bool_value(pic, fp != NULL);
+}
+
+pic_value
+pic_file_delete(pic_state *pic)
+{
+  const char *fname;
+
+  pic_get_args(pic, "z", &fname);
+
+  if (remove(fname) != 0) {
+    file_error(pic, "file cannot be deleted", 1, pic_cstr_value(pic, fname));
+  }
+  return pic_undef_value(pic);
+}
+
+void
+pic_init_file(pic_state *pic)
+{
+  pic_value i, o, e;
+
+  i = pic_fopen(pic, stdin, "r");
+  o = pic_fopen(pic, stdout, "w");
+  e = pic_fopen(pic, stderr, "w");
+  pic_setvbuf(pic, i, NULL, PIC_IOLBF, 0);
+  pic_setvbuf(pic, o, NULL, PIC_IOLBF, 0);
+  pic_defvar(pic, "current-input-port", i);
+  pic_defvar(pic, "current-output-port", o);
+  pic_defvar(pic, "current-error-port", e);
+
+  pic_defun(pic, "open-input-file", pic_file_open_input_file);
+  pic_defun(pic, "open-output-file", pic_file_open_output_file);
+  pic_defun(pic, "open-binary-input-file", pic_file_open_binary_input_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);
+}
+
+#endif

lib/ext/load.c

@@ -1,33 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/extra.h"
-
-void
-pic_load(pic_state *pic, pic_value port)
-{
-  pic_value form;
-  size_t ai = pic_enter(pic);
-
-  while (! pic_eof_p(pic, form = pic_read(pic, port))) {
-    pic_funcall(pic, "eval", 1, form);
-    pic_leave(pic, ai);
-  }
-}
-
-void
-pic_load_cstr(pic_state *pic, const char *str)
-{
-  pic_value e, port = pic_fmemopen(pic, str, strlen(str), "r");
-
-  pic_try {
-    pic_load(pic, port);
-  }
-  pic_catch(e) {
-    pic_fclose(pic, port);
-    pic_raise(pic, e);
-  }
-  pic_fclose(pic, port);
-}

lib/ext/main.c

@@ -0,0 +1,78 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <picrin.h>
+#include <picrin/extra.h>
+
+int
+main(int argc, char *argv[])
+{
+  pic_state *pic;
+  pic_value e, port;
+
+  pic = pic_open(pic_default_allocf, NULL, pic_default_panicf);
+
+  pic_try {
+    if (argc == 1) {            /* repl */
+      while (1) {
+        pic_printf(pic, "> ");
+        pic_fflush(pic, pic_stdout(pic));
+        e = pic_funcall(pic, "read", 0);
+        if (pic_eof_p(pic, e))
+          break;
+        pic_funcall(pic, "write", 1, pic_funcall(pic, "eval", 1, e));
+        pic_printf(pic, "\n");
+      }
+    } else if (argc == 2) {     /* load file */
+      FILE *file = fopen(argv[1], "r");
+      if (! file) {
+        fprintf(stderr, "could not open file %s\n", argv[1]);
+        exit(1);
+      }
+      port = pic_fopen(pic, file, "r");
+      while (1) {
+        e = pic_funcall(pic, "read", 1, port);
+        if (pic_eof_p(pic, e))
+          break;
+        pic_void(pic, pic_funcall(pic, "eval", 1, e));
+      }
+    } else if (argc >= 3 && strcmp(argv[1], "-c") == 0) { /* compile */
+      const char *name = argv[2];
+      const unsigned char *bin;
+      int len, i;
+      if (argc == 3) {
+        port = pic_stdin(pic);
+      } else {
+        FILE *file = fopen(argv[3], "r");
+        if (! file) {
+          fprintf(stderr, "could not open file %s\n", argv[3]);
+          exit(1);
+        }
+        port = pic_fopen(pic, file, "r");
+      }
+      bin = pic_blob(pic, pic_serialize(pic, pic_funcall(pic, "compile", 1, pic_funcall(pic, "read", 1, port))), &len);
+      printf("const unsigned char %s[] = {\n", name);
+      for (i = 0; i < len; ++i) {
+        printf("0x%02x,", bin[i]);
+        if ((i + 1) % 12 == 0) {
+          putchar('\n');
+        } else {
+          putchar(' ');
+        }
+      }
+      if (len != 0) {
+        puts("");
+      }
+      printf("};\n");
+    } else {
+      fprintf(stderr, "usage: mini-picrin [-c] [file]\n");
+      exit(1);
+    }
+  }
+  pic_catch(e) {
+    pic_funcall(pic, "display", 2, e, pic_stderr(pic));
+  }
+
+  pic_close(pic);
+}

lib/ext/port.c

@@ -2,78 +2,139 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
-#include "object.h"
-#include "state.h"
+#include <picrin.h>
+#include <picrin/extra.h>
 
-#ifndef EOF
-# define EOF (-1)
-#endif
+#if PIC_USE_PORT
 
-bool
-pic_port_p(pic_state *pic, pic_value obj, const pic_port_type *type)
+enum {
+  FILE_READ   = 01,
+  FILE_WRITE  = 02,
+  FILE_UNBUF  = 04,
+  FILE_EOF    = 010,
+  FILE_ERR    = 020,
+  FILE_LNBUF  = 040,
+  FILE_SETBUF = 0100
+};
+
+struct port {
+  /* buffer */
+  char buf[1];                  /* fallback buffer */
+  long cnt;                     /* characters left */
+  char *ptr;                    /* next character position */
+  char *base;                   /* location of the buffer */
+  /* operators */
+  void *cookie;
+  const pic_port_type *vtable;
+  int flag;                     /* mode of the file access */
+};
+
+#define VALID_RANGE(pic, len, s, e) do {                                \
+    if (s < 0 || len < s)                                               \
+      pic_error(pic, "invalid start index", 1, pic_int_value(pic, s));  \
+    if (e < s || len < e)                                               \
+      pic_error(pic, "invalid end index", 1, pic_int_value(pic, e));    \
+  } while (0)
+
+static int flushbuf(pic_state *, int, struct port *);
+
+static void
+port_dtor(pic_state *pic, void *port)
 {
-  if (pic_type(pic, obj) != PIC_TYPE_PORT) {
-    return false;
-  }
-  return type == NULL || pic_port_ptr(pic, obj)->file.vtable == type;
+  struct port *fp = port;
+  if (fp->flag == 0)
+    return;
+  if ((fp->flag & FILE_WRITE) != 0 && fp->base != NULL)
+    flushbuf(pic, EOF, fp);
+  if (fp->base != fp->buf && (fp->flag & FILE_SETBUF) == 0)
+    pic_free(pic, fp->base);
+  fp->vtable->close(pic, fp->cookie);
+  pic_free(pic, port);
 }
 
+static const pic_data_type port_type = { "port", port_dtor };
+
 pic_value
 pic_funopen(pic_state *pic, void *cookie, const pic_port_type *type)
 {
   struct port *port;
 
-  port = (struct port *)pic_obj_alloc(pic, sizeof(struct port), PIC_TYPE_PORT);
-  port->file.cnt = 0;
-  port->file.base = NULL;
-  port->file.flag = type->read ? FILE_READ : FILE_WRITE;
-  port->file.cookie = cookie;
-  port->file.vtable = type;
+  port = pic_malloc(pic, sizeof(*port));
+  port->cnt = 0;
+  port->base = NULL;
+  port->flag = type->read ? FILE_READ : FILE_WRITE;
+  port->cookie = cookie;
+  port->vtable = type;
 
-  return obj_value(pic, port);
+  return pic_data_value(pic, port, &port_type);
 }
 
 int
 pic_fclose(pic_state *pic, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
+  int r;
 
-  if (fp->flag == 0)
+  if (fp->flag == 0)            /* already closed */
     return 0;
   pic_fflush(pic, port);
-  fp->flag = 0;
-  if (fp->base != fp->buf)
+  if (fp->base != fp->buf && (fp->flag & FILE_SETBUF) == 0)
     pic_free(pic, fp->base);
-  return fp->vtable->close(pic, fp->cookie);
+  if ((r = fp->vtable->close(pic, fp->cookie)) < 0)
+    return r;
+  fp->flag = 0;
+  return r;
 }
 
 void
-pic_clearerr(pic_state *PIC_UNUSED(pic), pic_value port)
+pic_clearerr(pic_state *pic, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
 
   fp->flag &= ~(FILE_EOF | FILE_ERR);
 }
 
 int
-pic_feof(pic_state *PIC_UNUSED(pic), pic_value port)
+pic_feof(pic_state *pic, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
 
   return (fp->flag & FILE_EOF) != 0;
 }
 
 int
-pic_ferror(pic_state *PIC_UNUSED(pic), pic_value port)
+pic_ferror(pic_state *pic, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
 
   return (fp->flag & FILE_ERR) != 0;
 }
 
+int
+pic_setvbuf(pic_state *pic, pic_value port, char *buf, int mode, size_t size)
+{
+  struct port *fp = pic_data(pic, port);
+
+  fp->flag &= ~(FILE_UNBUF | FILE_LNBUF);
+  if (mode == PIC_IOLBF) {
+    fp->flag |= FILE_LNBUF;
+  } else if (mode == PIC_IONBF) {
+    fp->flag |= FILE_UNBUF;
+  }
+
+  if (buf == NULL) {
+    return 0;
+  }
+  if (size < PIC_BUFSIZ) {
+    return EOF;
+  }
+  fp->base = buf;
+  fp->flag |= FILE_SETBUF;
+  return 0;
+}
+
 static int
-fillbuf(pic_state *pic, struct file *fp)
+fillbuf(pic_state *pic, struct port *fp)
 {
   int bufsize;
 
@@ -109,7 +170,7 @@ fillbuf(pic_state *pic, struct file *fp)
 }
 
 static int
-flushbuf(pic_state *pic, int x, struct file *fp)
+flushbuf(pic_state *pic, int x, struct port *fp)
 {
   int num_written=0, bufsize=0;
   char c = x;
@@ -164,7 +225,7 @@ flushbuf(pic_state *pic, int x, struct file *fp)
 int
 pic_fflush(pic_state *pic, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
   int retval;
 
   retval = 0;
@@ -188,7 +249,7 @@ pic_fflush(pic_state *pic, pic_value port)
 int
 pic_fputc(pic_state *pic, int x, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
 
   return putc_(pic, x, fp);
 }
@@ -196,7 +257,7 @@ pic_fputc(pic_state *pic, int x, pic_value port)
 int
 pic_fgetc(pic_state *pic, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
 
   return getc_(pic, fp);
 }
@@ -204,7 +265,7 @@ pic_fgetc(pic_state *pic, pic_value port)
 int
 pic_fputs(pic_state *pic, const char *s, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
 
   const char *ptr = s;
   while(*ptr != '\0') {
@@ -218,7 +279,7 @@ pic_fputs(pic_state *pic, const char *s, pic_value port)
 char *
 pic_fgets(pic_state *pic, char *s, int size, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
   int c = 0;
   char *buf;
 
@@ -238,9 +299,9 @@ pic_fgets(pic_state *pic, char *s, int size, pic_value port)
 }
 
 int
-pic_ungetc(pic_state *PIC_UNUSED(pic), int c, pic_value port)
+pic_ungetc(pic_state *pic, int c, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
   unsigned char uc = c;
 
   if (c == EOF || fp->base == fp->ptr) {
@@ -253,7 +314,7 @@ pic_ungetc(pic_state *PIC_UNUSED(pic), int c, pic_value port)
 size_t
 pic_fread(pic_state *pic, void *ptr, size_t size, size_t count, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
   char *bptr = ptr;
   long nbytes;
   int c;
@@ -279,7 +340,7 @@ pic_fread(pic_state *pic, void *ptr, size_t size, size_t count, pic_value port)
 size_t
 pic_fwrite(pic_state *pic, const void *ptr, size_t size, size_t count, pic_value port)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
   const char *bptr = ptr;
   long nbytes;
 
@@ -302,7 +363,7 @@ pic_fwrite(pic_state *pic, const void *ptr, size_t size, size_t count, pic_value
 long
 pic_fseek(pic_state *pic, pic_value port, long offset, int whence)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
   long s;
 
   pic_fflush(pic, port);
@@ -316,120 +377,35 @@ pic_fseek(pic_state *pic, pic_value port, long offset, int whence)
   return 0;
 }
 
-#if PIC_USE_STDIO
-
-static int
-file_read(pic_state *PIC_UNUSED(pic), void *cookie, char *ptr, int size) {
-  FILE *file = cookie;
-  int r;
-
-  size = 1;                     /* override size */
-
-  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 int
-file_write(pic_state *PIC_UNUSED(pic), 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;
-  }
-  fflush(cookie);
-  return r;
-}
-
-static long
-file_seek(pic_state *PIC_UNUSED(pic), void *cookie, long pos, int whence) {
-  switch (whence) {
-  case PIC_SEEK_CUR:
-    whence = SEEK_CUR;
-    break;
-  case PIC_SEEK_SET:
-    whence = SEEK_SET;
-    break;
-  case PIC_SEEK_END:
-    whence = SEEK_END;
-    break;
-  }
-  if (fseek(cookie, pos, whence) == 0) {
-    return ftell(cookie);
-  }
-  return -1;
-}
-
-static int
-file_close(pic_state *PIC_UNUSED(pic), void *cookie) {
-  return fclose(cookie);
-}
-
-static const pic_port_type file_rd = {
-  file_read, 0, file_seek, file_close
-};
-static const pic_port_type file_wr = {
-  0, file_write, file_seek, file_close
-};
-
-pic_value
-pic_fopen(pic_state *pic, FILE *fp, const char *mode) {
-  if (*mode == 'r') {
-    return pic_funopen(pic, fp, &file_rd);
-  } else {
-    return pic_funopen(pic, fp, &file_wr);
-  }
-}
-
-#else
-
-static int
-null_read(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), char *PIC_UNUSED(ptr), int PIC_UNUSED(size)) {
-  return 0;
-}
-
-static int
-null_write(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), const char *PIC_UNUSED(ptr), int size) {
-  return size;
-}
-
-static long
-null_seek(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) {
-  return 0;
-}
-
-static int
-null_close(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie)) {
-  return 0;
-}
-
-
-static const pic_port_type null_rd = {
-  null_read, 0, null_seek, null_close
-};
-static const pic_port_type null_wr = {
-  0, null_write, null_seek, null_close
-};
-
-static pic_value
-pic_fopen_null(pic_state *PIC_UNUSED(pic), const char *mode)
+int
+pic_vfprintf(pic_state *pic, pic_value port, const char *fmt, va_list ap)
 {
-  switch (*mode) {
-  case 'r':
-    return pic_funopen(pic, 0, &null_rd);
-  default:
-    return pic_funopen(pic, 0, &null_wr);
-  }
+  return pic_fputs(pic, pic_cstr(pic, pic_vstrf_value(pic, fmt, ap), NULL), port);
 }
 
-#endif
+int
+pic_fprintf(pic_state *pic, pic_value port, const char *fmt, ...)
+{
+  va_list ap;
+  int n;
+
+  va_start(ap, fmt);
+  n = pic_vfprintf(pic, port, fmt, ap);
+  va_end(ap);
+  return n;
+}
+
+int
+pic_printf(pic_state *pic, const char *fmt, ...)
+{
+  va_list ap;
+  int n;
+
+  va_start(ap, fmt);
+  n = pic_vfprintf(pic, pic_stdout(pic), fmt, ap);
+  va_end(ap);
+  return n;
+}
 
 typedef struct { char *buf; long pos, end, capa; } xbuf_t;
 
@@ -491,16 +467,11 @@ string_close(pic_state *pic, void *cookie)
   return 0;
 }
 
-static const pic_port_type string_rd = {
-  string_read, 0, string_seek, string_close
-};
-static const pic_port_type string_wr = {
-  0, string_write, string_seek, string_close
-};
-
-pic_value
+static pic_value
 pic_fmemopen(pic_state *pic, const char *data, int size, const char *mode)
 {
+  static const pic_port_type string_rd = { string_read, 0, string_seek, string_close };
+  static const pic_port_type string_wr = { 0, string_write, string_seek, string_close };
   xbuf_t *m;
 
   m = pic_malloc(pic, sizeof(xbuf_t));
@@ -517,10 +488,10 @@ pic_fmemopen(pic_state *pic, const char *data, int size, const char *mode)
   }
 }
 
-int
+static int
 pic_fgetbuf(pic_state *pic, pic_value port, const char **buf, int *len)
 {
-  struct file *fp = &pic_port_ptr(pic, port)->file;
+  struct port *fp = pic_data(pic, port);
   xbuf_t *s;
 
   pic_fflush(pic, port);
@@ -534,6 +505,18 @@ pic_fgetbuf(pic_state *pic, pic_value port, const char **buf, int *len)
   return 0;
 }
 
+bool
+pic_port_p(pic_state *pic, pic_value obj, const pic_port_type *type)
+{
+  struct port *port;
+
+  if (! pic_data_p(pic, obj, &port_type)) {
+    return false;
+  }
+  port = pic_data(pic, obj);
+  return type == NULL || port->vtable == type;
+}
+
 static pic_value
 pic_port_input_port_p(pic_state *pic)
 {
@@ -541,8 +524,9 @@ pic_port_input_port_p(pic_state *pic)
 
   pic_get_args(pic, "o", &v);
 
-  if (pic_port_p(pic, v, NULL) && (pic_port_ptr(pic, v)->file.flag & FILE_READ) != 0) {
-    return pic_true_value(pic);
+  if (pic_port_p(pic, v, NULL)) {
+    struct port *port = pic_data(pic, v);
+    return pic_bool_value(pic, (port->flag & FILE_READ) != 0);
   } else {
     return pic_false_value(pic);
   }
@@ -555,10 +539,10 @@ pic_port_output_port_p(pic_state *pic)
 
   pic_get_args(pic, "o", &v);
 
-  if (pic_port_p(pic, v, NULL) && (pic_port_ptr(pic, v)->file.flag & FILE_WRITE) != 0) {
-    return pic_true_value(pic);
-  }
-  else {
+  if (pic_port_p(pic, v, NULL)) {
+    struct port *port = pic_data(pic, v);
+    return pic_bool_value(pic, (port->flag & FILE_WRITE) != 0);
+  } else {
     return pic_false_value(pic);
   }
 }
@@ -594,39 +578,46 @@ pic_port_eof_object(pic_state *pic)
 static pic_value
 pic_port_port_open_p(pic_state *pic)
 {
-  pic_value port;
+  struct port *port;
 
-  pic_get_args(pic, "p", &port);
+  pic_get_args(pic, "u", &port, &port_type);
 
-  return pic_bool_value(pic, pic_port_ptr(pic, port)->file.flag != 0);
+  return pic_bool_value(pic, port->flag != 0);
 }
 
 static pic_value
 pic_port_close_port(pic_state *pic)
 {
+  void *isport;
   pic_value port;
 
-  pic_get_args(pic, "p", &port);
+  pic_get_args(pic, "u+", &isport, &port_type, &port);
 
   pic_fclose(pic, port);
 
   return pic_undef_value(pic);
 }
 
-#define assert_port_profile(port, flags, caller) do {           \
-    int flag = pic_port_ptr(pic, port)->file.flag;              \
-    if ((flag & (flags)) != (flags)) {                          \
-      switch (flags) {                                          \
-      case FILE_WRITE:                                          \
-        pic_error(pic, caller ": output port required", 0);     \
-      case FILE_READ:                                           \
-        pic_error(pic, caller ": input port required", 0);      \
-      }                                                         \
-    }                                                           \
-    if (flag == 0) {                                            \
-      pic_error(pic, caller ": open port required", 0);         \
-    }                                                           \
-  } while (0)
+static void
+check_port_type(pic_state *pic, pic_value obj, int flags)
+{
+  struct port *port;
+  if (! pic_data_p(pic, obj, &port_type)) {
+    pic_error(pic, "port required", 0);
+  }
+  port = pic_data(pic, obj);
+  if (port->flag == 0) {
+    pic_error(pic, "open port required", 0);
+  }
+  if ((port->flag & flags) != flags) {
+    switch (flags) {
+    case FILE_WRITE:
+      pic_error(pic, "output port required", 0);
+    case FILE_READ:
+      pic_error(pic, "input port required", 0);
+    }
+  }
+}
 
 static pic_value
 pic_port_open_input_bytevector(pic_state *pic)
@@ -654,9 +645,9 @@ pic_port_get_output_bytevector(pic_state *pic)
   const char *buf;
   int len;
 
-  pic_get_args(pic, "|p", &port);
+  pic_get_args(pic, "|o", &port);
 
-  assert_port_profile(port, FILE_WRITE, "get-output-bytevector");
+  check_port_type(pic, port, FILE_WRITE);
 
   if (pic_fgetbuf(pic, port, &buf, &len) < 0) {
     pic_error(pic, "port was not created by open-output-bytevector", 0);
@@ -664,19 +655,58 @@ pic_port_get_output_bytevector(pic_state *pic)
   return pic_blob_value(pic, (unsigned char *)buf, len);
 }
 
+static pic_value
+pic_port_open_input_string(pic_state *pic)
+{
+  pic_value str;
+  const char *buf;
+  int len;
+
+  pic_get_args(pic, "s", &str);
+
+  buf = pic_str(pic, str, &len);
+
+  return pic_fmemopen(pic, buf, len, "r");
+}
+
+static pic_value
+pic_port_open_output_string(pic_state *pic)
+{
+  pic_get_args(pic, "");
+
+  return pic_fmemopen(pic, NULL, 0, "w");
+}
+
+static pic_value
+pic_port_get_output_string(pic_state *pic)
+{
+  pic_value port = pic_stdout(pic);
+  const char *buf;
+  int len;
+
+  pic_get_args(pic, "|o", &port);
+
+  check_port_type(pic, port, FILE_WRITE);
+
+  if (pic_fgetbuf(pic, port, &buf, &len) < 0) {
+    pic_error(pic, "port was not created by open-output-string", 0);
+  }
+  return pic_str_value(pic, buf, len);
+}
+
 static pic_value
 pic_port_read_u8(pic_state *pic)
 {
   pic_value port = pic_stdin(pic);
   int c;
 
-  pic_get_args(pic, "|p", &port);
+  pic_get_args(pic, "|o", &port);
+
+  check_port_type(pic, port, FILE_READ);
 
-  assert_port_profile(port, FILE_READ, "read-u8");
   if ((c = pic_fgetc(pic, port)) == EOF) {
     return pic_eof_object(pic);
   }
-
   return pic_int_value(pic, c);
 }
 
@@ -686,18 +716,50 @@ pic_port_peek_u8(pic_state *pic)
   int c;
   pic_value port = pic_stdin(pic);
 
-  pic_get_args(pic, "|p", &port);
+  pic_get_args(pic, "|o", &port);
 
-  assert_port_profile(port, FILE_READ, "peek-u8");
+  check_port_type(pic, port, FILE_READ);
 
   c = pic_fgetc(pic, port);
   if (c == EOF) {
     return pic_eof_object(pic);
   }
-  else {
-    pic_ungetc(pic, c, port);
-    return pic_int_value(pic, c);
+  pic_ungetc(pic, c, port);
+  return pic_int_value(pic, c);
+}
+
+static pic_value
+pic_port_read_char(pic_state *pic)
+{
+  pic_value port = pic_stdin(pic);
+  int c;
+
+  pic_get_args(pic, "|o", &port);
+
+  check_port_type(pic, port, FILE_READ);
+
+  if ((c = pic_fgetc(pic, port)) == EOF) {
+    return pic_eof_object(pic);
   }
+  return pic_char_value(pic, c);
+}
+
+static pic_value
+pic_port_peek_char(pic_state *pic)
+{
+  int c;
+  pic_value port = pic_stdin(pic);
+
+  pic_get_args(pic, "|o", &port);
+
+  check_port_type(pic, port, FILE_READ);
+
+  c = pic_fgetc(pic, port);
+  if (c == EOF) {
+    return pic_eof_object(pic);
+  }
+  pic_ungetc(pic, c, port);
+  return pic_char_value(pic, c);
 }
 
 static pic_value
@@ -707,7 +769,7 @@ pic_port_read_bytevector_ip(pic_state *pic)
   unsigned char *buf;
   int n, start, end, i, len;
 
-  n = pic_get_args(pic, "b|pii", &buf, &len, &port, &start, &end);
+  n = pic_get_args(pic, "b|oii", &buf, &len, &port, &start, &end);
 
   switch (n) {
   case 1:
@@ -719,7 +781,8 @@ pic_port_read_bytevector_ip(pic_state *pic)
   }
 
   VALID_RANGE(pic, len, start, end);
-  assert_port_profile(port, FILE_READ, "read-bytevector!");
+
+  check_port_type(pic, port, FILE_READ);
 
   i = pic_fread(pic, buf + start, 1, end - start, port);
   if (i == 0) {
@@ -728,20 +791,119 @@ pic_port_read_bytevector_ip(pic_state *pic)
   return pic_int_value(pic, i);
 }
 
+static pic_value
+pic_port_read_bytevector(pic_state *pic)
+{
+  pic_value port = pic_stdin(pic), blob;
+  int n, k, i;
+  unsigned char *buf;
+
+  n = pic_get_args(pic, "i|o", &k, &port);
+
+  check_port_type(pic, port, FILE_READ);
+
+  buf = pic_malloc(pic, k);
+
+  i = pic_fread(pic, buf, 1, k, port);
+  if (i == 0) {
+    pic_free(pic, buf);
+    return pic_eof_object(pic);
+  }
+  blob = pic_blob_value(pic, buf, i);
+  pic_free(pic, buf);
+  return blob;
+}
+
+static pic_value
+pic_port_read_string(pic_state *pic)
+{
+  pic_value port = pic_stdin(pic), blob;
+  int n, k, i;
+  char *buf;
+
+  n = pic_get_args(pic, "i|o", &k, &port);
+
+  check_port_type(pic, port, FILE_READ);
+
+  buf = pic_malloc(pic, k);
+
+  i = pic_fread(pic, buf, 1, k, port);
+  if (i == 0) {
+    pic_free(pic, buf);
+    return pic_eof_object(pic);
+  }
+  blob = pic_str_value(pic, buf, i);
+  pic_free(pic, buf);
+  return blob;
+}
+
+static pic_value
+pic_port_read_line(pic_state *pic)
+{
+  pic_value port = pic_stdin(pic), str;
+  int c;
+  char s[1];
+
+  pic_get_args(pic, "|o", &port);
+
+  check_port_type(pic, port, FILE_READ);
+
+  if ((c = pic_fgetc(pic, port)) == EOF) {
+    return pic_eof_object(pic);
+  }
+  s[0] = c;
+  str = pic_str_value(pic, s, 1);
+
+  while ((c = pic_fgetc(pic, port)) != EOF) {
+    if (c == '\n')
+      break;
+    s[0] = c;
+    str = pic_str_cat(pic, str, pic_str_value(pic, s, 1));
+  }
+  return str;
+}
+
 static pic_value
 pic_port_write_u8(pic_state *pic)
 {
   int i;
   pic_value port = pic_stdout(pic);
 
-  pic_get_args(pic, "i|p", &i, &port);
+  pic_get_args(pic, "i|o", &i, &port);
 
-  assert_port_profile(port, FILE_WRITE, "write-u8");
+  check_port_type(pic, port, FILE_WRITE);
 
   pic_fputc(pic, i, port);
   return pic_undef_value(pic);
 }
 
+static pic_value
+pic_port_write_char(pic_state *pic)
+{
+  char c;
+  pic_value port = pic_stdout(pic);
+
+  pic_get_args(pic, "c|o", &c, &port);
+
+  check_port_type(pic, port, FILE_WRITE);
+
+  pic_fputc(pic, c, port);
+  return pic_undef_value(pic);
+}
+
+static pic_value
+pic_port_newline(pic_state *pic)
+{
+  pic_value port = pic_stdout(pic);
+
+  pic_get_args(pic, "|o", &port);
+
+  check_port_type(pic, port, FILE_WRITE);
+
+  pic_fputc(pic, '\n', port);
+  return pic_undef_value(pic);
+}
+
 static pic_value
 pic_port_write_bytevector(pic_state *pic)
 {
@@ -749,7 +911,7 @@ pic_port_write_bytevector(pic_state *pic)
   unsigned char *buf;
   int n, start, end, len, done;
 
-  n = pic_get_args(pic, "b|pii", &buf, &len, &port, &start, &end);
+  n = pic_get_args(pic, "b|oii", &buf, &len, &port, &start, &end);
 
   switch (n) {
   case 1:
@@ -761,7 +923,40 @@ pic_port_write_bytevector(pic_state *pic)
   }
 
   VALID_RANGE(pic, len, start, end);
-  assert_port_profile(port, FILE_WRITE, "write-bytevector");
+
+  check_port_type(pic, port, FILE_WRITE);
+
+  done = 0;
+  while (done < end - start) {
+    done += pic_fwrite(pic, buf + start + done, 1, end - start - done, port);
+    /* FIXME: error check... */
+  }
+  return pic_undef_value(pic);
+}
+
+static pic_value
+pic_port_write_string(pic_state *pic)
+{
+  pic_value str, port;
+  int n, start, end, len, done;
+  const char *buf;
+
+  n = pic_get_args(pic, "s|oii", &str, &port, &start, &end);
+
+  buf = pic_str(pic, str, &len);
+
+  switch (n) {
+  case 1:
+    port = pic_stdout(pic);
+  case 2:
+    start = 0;
+  case 3:
+    end = len;
+  }
+
+  VALID_RANGE(pic, len, start, end);
+
+  check_port_type(pic, port, FILE_WRITE);
 
   done = 0;
   while (done < end - start) {
@@ -776,9 +971,9 @@ pic_port_flush(pic_state *pic)
 {
   pic_value port = pic_stdout(pic);
 
-  pic_get_args(pic, "|p", &port);
+  pic_get_args(pic, "|o", &port);
 
-  assert_port_profile(port, FILE_WRITE, "flush-output-port");
+  check_port_type(pic, port, FILE_WRITE);
 
   pic_fflush(pic, port);
   return pic_undef_value(pic);
@@ -787,14 +982,10 @@ pic_port_flush(pic_state *pic)
 void
 pic_init_port(pic_state *pic)
 {
-#if PIC_USE_STDIO
-  pic_defvar(pic, "current-input-port", pic_fopen(pic, stdin, "r"));
-  pic_defvar(pic, "current-output-port", pic_fopen(pic, stdout, "w"));
-  pic_defvar(pic, "current-error-port", pic_fopen(pic, stdout, "w"));
-#else
-  pic_defvar(pic, "current-input-port", pic_fopen_null(pic, "r"));
-  pic_defvar(pic, "current-output-port", pic_fopen_null(pic, "w"));
-  pic_defvar(pic, "current-error-port", pic_fopen_null(pic, "w"));
+#if !PIC_USE_FILE
+  pic_defvar(pic, "current-input-port", pic_false_value(pic));
+  pic_defvar(pic, "current-output-port", pic_false_value(pic));
+  pic_defvar(pic, "current-error-port", pic_false_value(pic));
 #endif
 
   pic_defun(pic, "port?", pic_port_port_p);
@@ -809,15 +1000,28 @@ pic_init_port(pic_state *pic)
   /* input */
   pic_defun(pic, "read-u8", pic_port_read_u8);
   pic_defun(pic, "peek-u8", pic_port_peek_u8);
+  pic_defun(pic, "read-char", pic_port_read_char);
+  pic_defun(pic, "peek-char", pic_port_peek_char);
   pic_defun(pic, "read-bytevector!", pic_port_read_bytevector_ip);
+  pic_defun(pic, "read-bytevector", pic_port_read_bytevector);
+  pic_defun(pic, "read-string", pic_port_read_string);
+  pic_defun(pic, "read-line", pic_port_read_line);
 
   /* output */
   pic_defun(pic, "write-u8", pic_port_write_u8);
+  pic_defun(pic, "write-char", pic_port_write_char);
+  pic_defun(pic, "newline", pic_port_newline);
   pic_defun(pic, "write-bytevector", pic_port_write_bytevector);
+  pic_defun(pic, "write-string", pic_port_write_string);
   pic_defun(pic, "flush-output-port", pic_port_flush);
 
   /* string I/O */
   pic_defun(pic, "open-input-bytevector", pic_port_open_input_bytevector);
   pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector);
   pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector);
+  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);
 }
+
+#endif

lib/ext/read.c

@@ -2,10 +2,13 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
-#include "picrin/extra.h"
+#include <picrin.h>
+#include <picrin/extra.h>
+#include "../value.h"
 #include "../object.h"
 
+#if PIC_USE_READ
+
 #undef EOF
 #define EOF (-1)
 
@@ -25,14 +28,27 @@ typedef pic_value (*pic_reader_t)(pic_state *, pic_value port, int c, struct rea
 static pic_reader_t reader_table[256];
 static pic_reader_t reader_dispatch[256];
 
-static pic_value read_value(pic_state *pic, pic_value port, int c, struct reader_control *p);
+static pic_value read_core(pic_state *pic, pic_value port, int c, struct reader_control *p);
 static pic_value read_nullable(pic_state *pic, pic_value port, int c, struct reader_control *p);
 
+#if !PIC_USE_ERROR
+# define read_error pic_error
+#else
 PIC_NORETURN static void
-read_error(pic_state *pic, const char *msg, pic_value irritants)
+read_error(pic_state *pic, const char *msg, int n, ...)
 {
-  pic_raise(pic, pic_make_error(pic, "read", msg, irritants));
+  va_list ap;
+  pic_value e, irrs;
+
+  va_start(ap, n);
+  irrs = pic_vlist(pic, n, ap);
+  va_end(ap);
+
+  e = pic_funcall(pic, "make-error-object", 3, pic_intern_lit(pic, "read"), pic_cstr_value(pic, msg), irrs);
+  pic_funcall(pic, "raise", 1, e);
+  PIC_UNREACHABLE();
 }
+#endif
 
 static int
 skip(pic_state *pic, pic_value port, int c)
@@ -123,7 +139,7 @@ read_block_comment(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct rea
 static pic_value
 read_datum_comment(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
 {
-  read_value(pic, port, next(pic, port), p);
+  read_core(pic, port, next(pic, port), p);
 
   return pic_invalid_value(pic);
 }
@@ -152,13 +168,13 @@ read_directive(pic_state *pic, pic_value port, int c, struct reader_control *p)
 static pic_value
 read_quote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
 {
-  return pic_list(pic, 2, pic_intern_lit(pic, "quote"), read_value(pic, port, next(pic, port), p));
+  return pic_list(pic, 2, pic_intern_lit(pic, "quote"), read_core(pic, port, next(pic, port), p));
 }
 
 static pic_value
 read_quasiquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
 {
-  return pic_list(pic, 2, pic_intern_lit(pic, "quasiquote"), read_value(pic, port, next(pic, port), p));
+  return pic_list(pic, 2, pic_intern_lit(pic, "quasiquote"), read_core(pic, port, next(pic, port), p));
 }
 
 static pic_value
@@ -172,19 +188,19 @@ read_unquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_co
   } else {
     tag = pic_intern_lit(pic, "unquote");
   }
-  return pic_list(pic, 2, tag, read_value(pic, port, next(pic, port), p));
+  return pic_list(pic, 2, tag, read_core(pic, port, next(pic, port), p));
 }
 
 static pic_value
 read_syntax_quote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
 {
-  return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quote"), read_value(pic, port, next(pic, port), p));
+  return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quote"), read_core(pic, port, next(pic, port), p));
 }
 
 static pic_value
 read_syntax_quasiquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
 {
-  return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quasiquote"), read_value(pic, port, next(pic, port), p));
+  return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quasiquote"), read_core(pic, port, next(pic, port), p));
 }
 
 static pic_value
@@ -198,7 +214,7 @@ read_syntax_unquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct re
   } else {
     tag = pic_intern_lit(pic, "syntax-unquote");
   }
-  return pic_list(pic, 2, tag, read_value(pic, port, next(pic, port), p));
+  return pic_list(pic, 2, tag, read_core(pic, port, next(pic, port), p));
 }
 
 static pic_value
@@ -250,7 +266,7 @@ read_uinteger(pic_state *pic, pic_value port, int c, struct reader_control *PIC_
   unsigned u = 0;
 
   if (! isdigit(c)) {
-    read_error(pic, "expected one or more digits", pic_list(pic, 1, pic_char_value(pic, c)));
+    read_error(pic, "expected one or more digits", 1, pic_char_value(pic, c));
   }
 
   u = c - '0';
@@ -266,10 +282,10 @@ read_true(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUS
 {
   if ((c = peek(pic, port)) == 'r') {
     if (! expect(pic, port, "rue")) {
-      read_error(pic, "unexpected character while reading #true", pic_nil_value(pic));
+      read_error(pic, "unexpected character while reading #true", 0);
     }
   } else if (! isdelim(c)) {
-    read_error(pic, "non-delimiter character given after #t", pic_list(pic, 1, pic_char_value(pic, c)));
+    read_error(pic, "non-delimiter character given after #t", 1, pic_char_value(pic, c));
   }
 
   return pic_true_value(pic);
@@ -280,10 +296,10 @@ read_false(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNU
 {
   if ((c = peek(pic, port)) == 'a') {
     if (! expect(pic, port, "alse")) {
-      read_error(pic, "unexpected character while reading #false", pic_nil_value(pic));
+      read_error(pic, "unexpected character while reading #false", 0);
     }
   } else if (! isdelim(c)) {
-    read_error(pic, "non-delimiter character given after #f", pic_list(pic, 1, pic_char_value(pic, c)));
+    read_error(pic, "non-delimiter character given after #f", 1, pic_char_value(pic, c));
   }
 
   return pic_false_value(pic);
@@ -296,7 +312,7 @@ read_char(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUS
 
   if (! isdelim(peek(pic, port))) {
     switch (c) {
-    default: read_error(pic, "unexpected character after char literal", pic_list(pic, 1, pic_char_value(pic, c)));
+    default: read_error(pic, "unexpected character after char literal", 1, pic_char_value(pic, c));
     case 'a': c = '\a'; if (! expect(pic, port, "larm")) goto fail; break;
     case 'b': c = '\b'; if (! expect(pic, port, "ackspace")) goto fail; break;
     case 'd': c = 0x7F; if (! expect(pic, port, "elete")) goto fail; break;
@@ -321,7 +337,7 @@ read_char(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUS
   return pic_char_value(pic, (char)c);
 
  fail:
-  read_error(pic, "unexpected character while reading character literal", pic_list(pic, 1, pic_char_value(pic, c)));
+  read_error(pic, "unexpected character while reading character literal", 1, pic_char_value(pic, c));
 }
 
 static pic_value
@@ -384,7 +400,7 @@ read_pipe(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUS
         i = 0;
         while ((HEX_BUF[i++] = (char)next(pic, port)) != ';') {
           if (i >= sizeof HEX_BUF)
-            read_error(pic, "expected ';'", pic_list(pic, 1, pic_char_value(pic, HEX_BUF[sizeof(HEX_BUF) - 1])));
+            read_error(pic, "expected ';'", 1, pic_char_value(pic, HEX_BUF[sizeof(HEX_BUF) - 1]));
         }
         c = (char)strtol(HEX_BUF, NULL, 16);
         break;
@@ -418,11 +434,11 @@ read_blob(pic_state *pic, pic_value port, int c, struct reader_control *p)
   }
 
   if (nbits != 8) {
-    read_error(pic, "unsupported bytevector bit width", pic_list(pic, 1, pic_int_value(pic, nbits)));
+    read_error(pic, "unsupported bytevector bit width", 1, pic_int_value(pic, nbits));
   }
 
   if (c != '(') {
-    read_error(pic, "expected '(' character", pic_list(pic, 1, pic_char_value(pic, c)));
+    read_error(pic, "expected '(' character", 1, pic_char_value(pic, c));
   }
 
   len = 0;
@@ -431,7 +447,7 @@ read_blob(pic_state *pic, pic_value port, int c, struct reader_control *p)
   while ((c = skip(pic, port, c)) != ')') {
     n = read_uinteger(pic, port, c, p);
     if (n < 0 || (1 << nbits) <= n) {
-      read_error(pic, "invalid element in bytevector literal", pic_list(pic, 1, pic_int_value(pic, n)));
+      read_error(pic, "invalid element in bytevector literal", 1, pic_int_value(pic, n));
     }
     len += 1;
     dat = pic_realloc(pic, dat, len);
@@ -450,12 +466,12 @@ read_undef_or_blob(pic_state *pic, pic_value port, int c, struct reader_control
 {
   if ((c = peek(pic, port)) == 'n') {
     if (! expect(pic, port, "ndefined")) {
-      read_error(pic, "unexpected character while reading #undefined", pic_nil_value(pic));
+      read_error(pic, "unexpected character while reading #undefined", 0);
     }
     return pic_undef_value(pic);
   }
   if (! isdigit(c)) {
-    read_error(pic, "expect #undefined or #u8(...), but illegal character given", pic_list(pic, 1, pic_char_value(pic, c)));
+    read_error(pic, "expect #undefined or #u8(...), but illegal character given", 1, pic_char_value(pic, c));
   }
   return read_blob(pic, port, 'u', p);
 }
@@ -474,14 +490,14 @@ read_pair(pic_state *pic, pic_value port, int c, struct reader_control *p)
     return pic_nil_value(pic);
   }
   if (c == '.' && isdelim(peek(pic, port))) {
-    cdr = read_value(pic, port, next(pic, port), p);
+    cdr = read_core(pic, port, next(pic, port), p);
 
   closing:
     if ((c = skip(pic, port, ' ')) != tCLOSE) {
       if (pic_invalid_p(pic, read_nullable(pic, port, c, p))) {
         goto closing;
       }
-      read_error(pic, "unmatched parenthesis", pic_nil_value(pic));
+      read_error(pic, "unmatched parenthesis", 0);
     }
     return cdr;
   }
@@ -503,7 +519,7 @@ read_vector(pic_state *pic, pic_value port, int c, struct reader_control *p)
   pic_value list, it, elem, vec;
   int i = 0;
 
-  list = read_value(pic, port, c, p);
+  list = read_core(pic, port, c, p);
 
   vec = pic_make_vec(pic, pic_length(pic, list), NULL);
 
@@ -530,9 +546,9 @@ read_label_set(pic_state *pic, pic_value port, int i, struct reader_control *p)
 
       kh_val(h, it) = val = pic_cons(pic, pic_undef_value(pic), pic_undef_value(pic));
 
-      tmp = read_value(pic, port, c, p);
-      pic_pair_ptr(pic, val)->car = pic_car(pic, tmp);
-      pic_pair_ptr(pic, val)->cdr = pic_cdr(pic, tmp);
+      tmp = read_core(pic, port, c, p);
+      pic_set_car(pic, val, pic_car(pic, tmp));
+      pic_set_cdr(pic, val, pic_cdr(pic, tmp));
 
       return val;
     }
@@ -551,9 +567,9 @@ read_label_set(pic_state *pic, pic_value port, int i, struct reader_control *p)
 
         kh_val(h, it) = val = pic_make_vec(pic, 0, NULL);
 
-        tmp = read_value(pic, port, c, p);
-        PIC_SWAP(pic_value *, pic_vec_ptr(pic, tmp)->data, pic_vec_ptr(pic, val)->data);
-        PIC_SWAP(int, pic_vec_ptr(pic, tmp)->len, pic_vec_ptr(pic, val)->len);
+        tmp = read_core(pic, port, c, p);
+        PIC_SWAP(pic_value *, vec_ptr(pic, tmp)->data, vec_ptr(pic, val)->data);
+        PIC_SWAP(int, vec_ptr(pic, tmp)->len, vec_ptr(pic, val)->len);
 
         return val;
       }
@@ -562,7 +578,7 @@ read_label_set(pic_state *pic, pic_value port, int i, struct reader_control *p)
     }
   default:
     {
-      kh_val(h, it) = val = read_value(pic, port, c, p);
+      kh_val(h, it) = val = read_core(pic, port, c, p);
 
       return val;
     }
@@ -577,7 +593,7 @@ read_label_ref(pic_state *pic, pic_value PIC_UNUSED(port), int i, struct reader_
 
   it = kh_get(read, h, i);
   if (it == kh_end(h)) {
-    read_error(pic, "label of given index not defined", pic_list(pic, 1, pic_int_value(pic, i)));
+    read_error(pic, "label of given index not defined", 1, pic_int_value(pic, i));
   }
   return kh_val(h, it);
 }
@@ -598,13 +614,13 @@ read_label(pic_state *pic, pic_value port, int c, struct reader_control *p)
   if (c == '#') {
     return read_label_ref(pic, port, i, p);
   }
-  read_error(pic, "broken label expression", pic_nil_value(pic));
+  read_error(pic, "broken label expression", 0);
 }
 
 static pic_value
 read_unmatch(pic_state *pic, pic_value PIC_UNUSED(port), int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p))
 {
-  read_error(pic, "unmatched parenthesis", pic_nil_value(pic));
+  read_error(pic, "unmatched parenthesis", 0);
 }
 
 static pic_value
@@ -613,11 +629,11 @@ read_dispatch(pic_state *pic, pic_value port, int c, struct reader_control *p)
   c = next(pic, port);
 
   if (c == EOF) {
-    read_error(pic, "unexpected EOF", pic_nil_value(pic));
+    read_error(pic, "unexpected EOF", 0);
   }
 
   if (reader_dispatch[c] == NULL) {
-    read_error(pic, "invalid character at the seeker head", pic_list(pic, 1, pic_char_value(pic, c)));
+    read_error(pic, "invalid character at the seeker head", 1, pic_char_value(pic, c));
   }
 
   return reader_dispatch[c](pic, port, c, p);
@@ -629,18 +645,18 @@ read_nullable(pic_state *pic, pic_value port, int c, struct reader_control *p)
   c = skip(pic, port, c);
 
   if (c == EOF) {
-    read_error(pic, "unexpected EOF", pic_nil_value(pic));
+    read_error(pic, "unexpected EOF", 0);
   }
 
   if (reader_table[c] == NULL) {
-    read_error(pic, "invalid character at the seeker head", pic_list(pic, 1, pic_char_value(pic, c)));
+    read_error(pic, "invalid character at the seeker head", 1, pic_char_value(pic, c));
   }
 
   return reader_table[c](pic, port, c, p);
 }
 
 static pic_value
-read_value(pic_state *pic, pic_value port, int c, struct reader_control *p)
+read_core(pic_state *pic, pic_value port, int c, struct reader_control *p)
 {
   pic_value val;
 
@@ -706,79 +722,62 @@ reader_table_init(void)
 }
 
 static void
-reader_init(pic_state *PIC_UNUSED(pic), struct reader_control *p)
+destroy_reader_control(pic_state *pic, void *ptr)
 {
+  struct reader_control *p = ptr;
+
+  kh_destroy(read, &p->labels);
+  pic_free(pic, ptr);
+}
+
+static struct reader_control *
+make_reader_control(pic_state *pic)
+{
+  struct reader_control *p;
+  static const pic_data_type t = { "pic_reader_control", destroy_reader_control };
+
+  p = pic_malloc(pic, sizeof *p);
   p->typecase = CASE_DEFAULT;
   kh_init(read, &p->labels);
+
+  pic_data_value(pic, p, &t);
+
+  return p;
 }
 
-static void
-reader_destroy(pic_state *pic, struct reader_control *p)
+static pic_value
+read_value(pic_state *pic, pic_value port)
 {
-  kh_destroy(read, &p->labels);
-}
-
-pic_value
-pic_read(pic_state *pic, pic_value port)
-{
-  struct reader_control p;
-  size_t ai = pic_enter(pic);
+  struct reader_control *p = make_reader_control(pic);
+  size_t ai;
   pic_value val;
   int c;
-  pic_value e;
 
-  reader_init(pic, &p);
+  ai = pic_enter(pic);
+  while ((c = skip(pic, port, next(pic, port))) != EOF) {
+    val = read_nullable(pic, port, c, p);
 
-  pic_try {
-    size_t ai = pic_enter(pic);
-    while ((c = skip(pic, port, next(pic, port))) != EOF) {
-      val = read_nullable(pic, port, c, &p);
-
-      if (! pic_invalid_p(pic, val)) {
-        break;
-      }
-      pic_leave(pic, ai);
-    }
-    if (c == EOF) {
-      val = pic_eof_object(pic);
+    if (! pic_invalid_p(pic, val)) {
+      break;
     }
+    pic_leave(pic, ai);
   }
-  pic_catch(e) {
-    reader_destroy(pic, &p);
-    pic_raise(pic, e);
+  if (c == EOF) {
+    val = pic_eof_object(pic);
   }
 
   pic_leave(pic, ai);
   return pic_protect(pic, val);
 }
 
-pic_value
-pic_read_cstr(pic_state *pic, const char *str)
-{
-  pic_value port = pic_fmemopen(pic, str, strlen(str), "r");
-  pic_value form, e;
-
-  pic_try {
-    form = pic_read(pic, port);
-  }
-  pic_catch(e) {
-    pic_fclose(pic, port);
-    pic_raise(pic, e);
-  }
-
-  pic_fclose(pic, port);
-
-  return form;
-}
-
 static pic_value
 pic_read_read(pic_state *pic)
 {
   pic_value port = pic_stdin(pic);
 
-  pic_get_args(pic, "|p", &port);
+  pic_get_args(pic, "|o", &port);
 
-  return pic_read(pic, port);
+  return read_value(pic, port);
 }
 
 void
@@ -788,3 +787,5 @@ pic_init_read(pic_state *pic)
 
   pic_defun(pic, "read", pic_read_read);
 }
+
+#endif

lib/ext/write.c

@@ -2,10 +2,13 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
-#include "picrin/extra.h"
+#include <picrin.h>
+#include <picrin/extra.h>
+#include "../value.h"
 #include "../object.h"
 
+#if PIC_USE_WRITE
+
 struct writer_control {
   int mode;
   int op;
@@ -21,143 +24,14 @@ struct writer_control {
 #define OP_WRITE_SHARED 2
 #define OP_WRITE_SIMPLE 3
 
-#if PIC_USE_WRITE
-static void write_value(pic_state *pic, pic_value obj, pic_value port, int mode, int op);
-#endif
-
-static void
-print_int(pic_state *pic, pic_value port, long x, int base)
-{
-  static const char digits[] = "0123456789abcdef";
-  char buf[20];
-  int i, neg;
-
-  neg = 0;
-  if (x < 0) {
-    neg = 1;
-    x = -x;
-  }
-
-  i = 0;
-  do {
-    buf[i++] = digits[x % base];
-  } while ((x /= base) != 0);
-
-  if (neg) {
-    buf[i++] = '-';
-  }
-
-  while (i-- > 0) {
-    pic_fputc(pic, buf[i], port);
-  }
-}
-
-int
-pic_vfprintf(pic_state *pic, pic_value port, const char *fmt, va_list ap)
-{
-  const char *p;
-  char *sval;
-  int ival;
-  void *vp;
-  long start = pic_fseek(pic, port, 0, PIC_SEEK_CUR);
-
-  for (p = fmt; *p; p++) {
-
-#if PIC_USE_WRITE
-    if (*p == '~') {
-      switch (*++p) {
-      default:
-        pic_fputc(pic, *(p-1), port);
-        break;
-      case '%':
-        pic_fputc(pic, '\n', port);
-        break;
-      case 'a':
-        write_value(pic, va_arg(ap, pic_value), port, DISPLAY_MODE, OP_WRITE);
-        break;
-      case 's':
-        write_value(pic, va_arg(ap, pic_value), port, WRITE_MODE, OP_WRITE);
-        break;
-      }
-      continue;
-    }
-#endif
-
-    if (*p != '%') {
-      pic_fputc(pic, *p, port);
-      continue;
-    }
-    switch (*++p) {
-    case 'd':
-    case 'i':
-      ival = va_arg(ap, int);
-      print_int(pic, port, ival, 10);
-      break;
-    case 'f': {
-      char buf[64];
-      PIC_DOUBLE_TO_CSTRING(va_arg(ap, double), buf);
-      pic_fputs(pic, buf, port);
-      break;
-    }
-    case 'c':
-      ival = va_arg(ap, int);
-      pic_fputc(pic, ival, port);
-      break;
-    case 's':
-      sval = va_arg(ap, char*);
-      pic_fputs(pic, sval, port);
-      break;
-    case 'p':
-      vp = va_arg(ap, void*);
-      pic_fputs(pic, "0x", port);
-      print_int(pic, port, (long)vp, 16);
-      break;
-    case '%':
-      pic_fputc(pic, *(p-1), port);
-      break;
-    default:
-      pic_fputc(pic, '%', port);
-      pic_fputc(pic, *(p-1), port);
-      break;
-    }
-  }
-  return pic_fseek(pic, port, 0, PIC_SEEK_CUR) - start;
-}
-
-int
-pic_fprintf(pic_state *pic, pic_value port, const char *fmt, ...)
-{
-  va_list ap;
-  int n;
-
-  va_start(ap, fmt);
-  n = pic_vfprintf(pic, port, fmt, ap);
-  va_end(ap);
-  return n;
-}
-
-int
-pic_printf(pic_state *pic, const char *fmt, ...)
-{
-  va_list ap;
-  int n;
-
-  va_start(ap, fmt);
-  n = pic_vfprintf(pic, pic_stdout(pic), fmt, ap);
-  va_end(ap);
-  return n;
-}
-
-#if PIC_USE_WRITE
-
 static void
 writer_control_init(pic_state *pic, struct writer_control *p, int mode, int op)
 {
   p->mode = mode;
   p->op = op;
   p->cnt = 0;
-  p->shared = pic_make_weak(pic);
-  p->labels = pic_make_weak(pic);
+  p->shared = pic_make_attr(pic);
+  p->labels = pic_make_attr(pic);
 }
 
 static void
@@ -172,11 +46,12 @@ traverse(pic_state *pic, pic_value obj, struct writer_control *p)
   switch (pic_type(pic, obj)) {
   case PIC_TYPE_PAIR:
   case PIC_TYPE_VECTOR:
-  case PIC_TYPE_DICT: {
+  case PIC_TYPE_DICT:
+  case PIC_TYPE_RECORD: {
 
-    if (! pic_weak_has(pic, shared, obj)) {
+    if (! pic_attr_has(pic, shared, obj)) {
       /* first time */
-      pic_weak_set(pic, shared, obj, pic_int_value(pic, 0));
+      pic_attr_set(pic, shared, obj, pic_int_value(pic, 0));
 
       if (pic_pair_p(pic, obj)) {
         /* pair */
@@ -188,23 +63,26 @@ traverse(pic_state *pic, pic_value obj, struct writer_control *p)
         for (i = 0; i < len; ++i) {
           traverse(pic, pic_vec_ref(pic, obj, i), p);
         }
-      } else {
+      } else if (pic_dict_p(pic, obj)) {
         /* dictionary */
         int it = 0;
         pic_value val;
         while (pic_dict_next(pic, obj, &it, NULL, &val)) {
           traverse(pic, val, p);
         }
+      } else {
+        /* record */
+        traverse(pic, pic_record_datum(pic, obj), p);
       }
 
       if (p->op == OP_WRITE) {
-        if (pic_int(pic, pic_weak_ref(pic, shared, obj)) == 0) {
-          pic_weak_del(pic, shared, obj);
+        if (pic_int(pic, pic_attr_ref(pic, shared, obj)) == 0) {
+          pic_attr_del(pic, shared, obj);
         }
       }
     } else {
       /* second time */
-      pic_weak_set(pic, shared, obj, pic_int_value(pic, 1));
+      pic_attr_set(pic, shared, obj, pic_int_value(pic, 1));
     }
     break;
   }
@@ -217,13 +95,22 @@ static bool
 is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) {
   pic_value shared = p->shared;
 
-  if (! obj_p(pic, obj)) {
+  if (! pic_obj_p(pic, obj)) {
     return false;
   }
-  if (! pic_weak_has(pic, shared, obj)) {
+  if (! pic_attr_has(pic, shared, obj)) {
     return false;
   }
-  return pic_int(pic, pic_weak_ref(pic, shared, obj)) > 0;
+  return pic_int(pic, pic_attr_ref(pic, shared, obj)) > 0;
+}
+
+static void
+write_symbol(pic_state *pic, pic_value sym, pic_value port)
+{
+  int len;
+  const char *buf = pic_str(pic, pic_sym_name(pic, sym), &len);
+
+  pic_fwrite(pic, buf, len, 1, port);
 }
 
 static void
@@ -269,21 +156,21 @@ write_char(pic_state *pic, pic_value ch, pic_value port, struct writer_control *
 static void
 write_str(pic_state *pic, pic_value str, pic_value port, struct writer_control *p)
 {
-  int i;
-  const char *cstr = pic_str(pic, str, NULL);
+  int i, len;
+  const char *buf = pic_str(pic, str, &len);
 
   if (p->mode == DISPLAY_MODE) {
-    pic_fprintf(pic, port, "%s", pic_str(pic, str, NULL));
+    pic_fwrite(pic, buf, len, 1, port);
     return;
   }
-  pic_fprintf(pic, port, "\"");
-  for (i = 0; i < pic_str_len(pic, str); ++i) {
-    if (cstr[i] == '"' || cstr[i] == '\\') {
+  pic_fputc(pic, '"', port);
+  for (i = 0; i < len; ++i) {
+    if (buf[i] == '"' || buf[i] == '\\') {
       pic_fputc(pic, '\\', port);
     }
-    pic_fputc(pic, cstr[i], port);
+    pic_fputc(pic, buf[i], port);
   }
-  pic_fprintf(pic, port, "\"");
+  pic_fputc(pic, '"', port);
 }
 
 static void
@@ -324,8 +211,7 @@ write_pair_help(pic_state *pic, pic_value pair, pic_value port, struct writer_co
   }
 }
 
-#define EQ(sym, lit) (strcmp(pic_str(pic, pic_sym_name(pic, sym), NULL), lit) == 0)
-#define pic_sym(pic,sym) pic_str(pic, pic_sym_name(pic, (sym)), NULL)
+#define EQ(sym, lit) (pic_eq_p(pic, sym, pic_intern_lit(pic, lit)))
 
 static void
 write_pair(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
@@ -403,12 +289,24 @@ write_dict(pic_state *pic, pic_value dict, pic_value port, struct writer_control
 
   pic_fprintf(pic, port, "#.(dictionary");
   while (pic_dict_next(pic, dict, &it, &key, &val)) {
-    pic_fprintf(pic, port, " '%s ", pic_sym(pic, key));
+    pic_fputs(pic, " '", port);
+    write_symbol(pic, key, port);
+    pic_fputc(pic, ' ', port);
     write_core(pic, val, port, p);
   }
   pic_fprintf(pic, port, ")");
 }
 
+static void
+write_record(pic_state *pic, pic_value obj, pic_value port, struct writer_control *p)
+{
+  pic_fprintf(pic, port, "#<");
+  write_core(pic, pic_record_type(pic, obj), port, p);
+  pic_fprintf(pic, port, " ");
+  write_core(pic, pic_record_datum(pic, obj), port, p);
+  pic_fprintf(pic, port, ">");
+}
+
 static const char *
 typename(pic_state *pic, pic_value obj)
 {
@@ -440,27 +338,19 @@ typename(pic_state *pic, pic_value obj)
     return "vector";
   case PIC_TYPE_BLOB:
     return "bytevector";
-  case PIC_TYPE_PORT:
-    return "port";
-  case PIC_TYPE_ERROR:
-    return "error";
-  case PIC_TYPE_ID:
-    return "identifier";
-  case PIC_TYPE_CXT:
-    return "context";
+  case PIC_TYPE_FRAME:
+    return "frame";
   case PIC_TYPE_IREP:
     return "irep";
   case PIC_TYPE_PROC_FUNC:
   case PIC_TYPE_PROC_IREP:
     return "procedure";
-  case PIC_TYPE_ENV:
-    return "environment";
   case PIC_TYPE_DATA:
     return "data";
   case PIC_TYPE_DICT:
     return "dictionary";
-  case PIC_TYPE_WEAK:
-    return "ephemeron";
+  case PIC_TYPE_ATTR:
+    return "attribute";
   case PIC_TYPE_RECORD:
     return "record";
   default:
@@ -476,13 +366,13 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
 
   /* shared objects */
   if (is_shared_object(pic, obj, p)) {
-    if (pic_weak_has(pic, labels, obj)) {
-      pic_fprintf(pic, port, "#%d#", pic_int(pic, pic_weak_ref(pic, labels, obj)));
+    if (pic_attr_has(pic, labels, obj)) {
+      pic_fprintf(pic, port, "#%d#", pic_int(pic, pic_attr_ref(pic, labels, obj)));
       return;
     }
     i = p->cnt++;
     pic_fprintf(pic, port, "#%d=", i);
-    pic_weak_set(pic, labels, obj, pic_int_value(pic, i));
+    pic_attr_set(pic, labels, obj, pic_int_value(pic, i));
   }
 
   switch (pic_type(pic, obj)) {
@@ -498,9 +388,6 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
   case PIC_TYPE_FALSE:
     pic_fprintf(pic, port, "#f");
     break;
-  case PIC_TYPE_ID:
-    pic_fprintf(pic, port, "#<identifier %s>", pic_str(pic, pic_id_name(pic, obj), NULL));
-    break;
   case PIC_TYPE_EOF:
     pic_fprintf(pic, port, "#.(eof-object)");
     break;
@@ -508,7 +395,7 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
     pic_fprintf(pic, port, "%d", pic_int(pic, obj));
     break;
   case PIC_TYPE_SYMBOL:
-    pic_fprintf(pic, port, "%s", pic_sym(pic, obj));
+    write_symbol(pic, obj, port);
     break;
   case PIC_TYPE_FLOAT:
     write_float(pic, obj, port);
@@ -531,14 +418,17 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
   case PIC_TYPE_DICT:
     write_dict(pic, obj, port, p);
     break;
+  case PIC_TYPE_RECORD:
+    write_record(pic, obj, port, p);
+    break;
   default:
-    pic_fprintf(pic, port, "#<%s %p>", typename(pic, obj), obj_ptr(pic, obj));
+    pic_fprintf(pic, port, "#<%s %p>", typename(pic, obj), pic_ptr(pic, obj));
     break;
   }
 
   if (p->op == OP_WRITE) {
     if (is_shared_object(pic, obj, p)) {
-      pic_weak_del(pic, labels, obj);
+      pic_attr_del(pic, labels, obj);
     }
   }
 }
@@ -560,7 +450,7 @@ pic_write_write(pic_state *pic)
 {
   pic_value v, port = pic_stdout(pic);
 
-  pic_get_args(pic, "o|p", &v, &port);
+  pic_get_args(pic, "o|o", &v, &port);
   write_value(pic, v, port, WRITE_MODE, OP_WRITE);
   return pic_undef_value(pic);
 }
@@ -570,7 +460,7 @@ pic_write_write_simple(pic_state *pic)
 {
   pic_value v, port = pic_stdout(pic);
 
-  pic_get_args(pic, "o|p", &v, &port);
+  pic_get_args(pic, "o|o", &v, &port);
   write_value(pic, v, port, WRITE_MODE, OP_WRITE_SIMPLE);
   return pic_undef_value(pic);
 }
@@ -580,7 +470,7 @@ pic_write_write_shared(pic_state *pic)
 {
   pic_value v, port = pic_stdout(pic);
 
-  pic_get_args(pic, "o|p", &v, &port);
+  pic_get_args(pic, "o|o", &v, &port);
   write_value(pic, v, port, WRITE_MODE, OP_WRITE_SHARED);
   return pic_undef_value(pic);
 }
@@ -590,7 +480,7 @@ pic_write_display(pic_state *pic)
 {
   pic_value v, port = pic_stdout(pic);
 
-  pic_get_args(pic, "o|p", &v, &port);
+  pic_get_args(pic, "o|o", &v, &port);
   write_value(pic, v, port, DISPLAY_MODE, OP_WRITE);
   return pic_undef_value(pic);
 }

lib/include/picconf.h

@@ -2,20 +2,26 @@
  * See Copyright Notice in picrin.h
  */
 
-/** enable libc */
+/**
+ * enable libc
+ */
+
 /* #define PIC_USE_LIBC 1 */
 
-/** enable stdio */
-/* #define PIC_USE_STDIO 1 */
+/**
+ * enable specific features
+ */
 
-/** enable specific features */
+/* #define PIC_USE_CONT 1 */
+/* #define PIC_USE_PORT 1 */
+/* #define PIC_USE_READ 1 */
 /* #define PIC_USE_WRITE 1 */
+/* #define PIC_USE_EVAL 1 */
+/* #define PIC_USE_FILE 1 */
+/* #define PIC_USE_ERROR 1 */
 
-/** essential external functions */
-/* #define PIC_JMPBUF jmp_buf */
-/* #define PIC_SETJMP(pic, buf) setjmp(buf) */
-/* #define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val)) */
-/* #define PIC_ABORT(pic) abort() */
+/**
+ * I/O configuration
+ */
 
-/** I/O configuration */
 /* #define PIC_BUFSIZ 1024 */

lib/include/picrin.h

@@ -32,16 +32,16 @@ extern "C" {
 #include <limits.h>
 #include <stdarg.h>
 
-#include "picrin/setup.h"
+#include <picrin/setup.h>
 
 typedef struct pic_state pic_state;
 
-typedef struct {
+typedef struct value {
 #if PIC_NAN_BOXING
   uint64_t v;
 #else
   union {
-    void *data;
+    void *p;
     double f;
     int i;
     char c;
@@ -51,15 +51,13 @@ typedef struct {
 } pic_value;
 
 
-#include "picrin/value.h"       /* inline definitions */
-
-
 /*
  * state manipulation
  */
 
 typedef void *(*pic_allocf)(void *userdata, void *ptr, size_t n);
-pic_state *pic_open(pic_allocf f, void *userdata);
+typedef void (*pic_panicf)(pic_state *, const char *msg, int n, pic_value *args);
+pic_state *pic_open(pic_allocf allocf, void *userdata, pic_panicf panicf);
 void pic_close(pic_state *);
 
 
@@ -89,7 +87,7 @@ bool pic_equal_p(pic_state *, pic_value, pic_value);
 
 
 /*
- * number, boolean, character, string, bytevector, and userdata
+ * number, boolean, character, and userdata
  */
 
 typedef struct {
@@ -103,10 +101,7 @@ bool pic_char_p(pic_state *, pic_value);
 bool pic_true_p(pic_state *, pic_value);
 bool pic_false_p(pic_state *, pic_value);
 bool pic_bool_p(pic_state *, pic_value);
-bool pic_str_p(pic_state *, pic_value);
-bool pic_blob_p(pic_state *, pic_value);
 bool pic_data_p(pic_state *, pic_value, const pic_data_type *);
-/* constructors */
 pic_value pic_undef_value(pic_state *);
 pic_value pic_int_value(pic_state *, int);
 pic_value pic_float_value(pic_state *, double);
@@ -114,23 +109,54 @@ pic_value pic_char_value(pic_state *, char);
 pic_value pic_bool_value(pic_state *, bool);
 pic_value pic_true_value(pic_state *);
 pic_value pic_false_value(pic_state *);
-pic_value pic_str_value(pic_state *, const char *str, int len);
-pic_value pic_cstr_value(pic_state *, const char *str);
-#define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, -((int)sizeof lit - 1))
-pic_value pic_strf_value(pic_state *, const char *fmt, ...);
-pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap);
-pic_value pic_blob_value(pic_state *, const unsigned char *buf, int len);
 pic_value pic_data_value(pic_state *, void *ptr, const pic_data_type *type);
-/* destructors */
 int pic_int(pic_state *, pic_value i);
 double pic_float(pic_state *, pic_value f);
 char pic_char(pic_state *, pic_value c);
-#define pic_bool(pic,b) (! pic_false_p(pic, b))
-const char *pic_str(pic_state *, pic_value str, int *len);
-unsigned char *pic_blob(pic_state *, pic_value blob, int *len);
+#define pic_bool(pic,b) (! pic_false_p(pic, (b)))
 void *pic_data(pic_state *, pic_value data);
 
 
+/*
+ * bytevector
+ */
+
+bool pic_blob_p(pic_state *, pic_value);
+pic_value pic_blob_value(pic_state *, const unsigned char *buf, int len);
+unsigned char *pic_blob(pic_state *, pic_value blob, int *len);
+pic_value pic_serialize(pic_state *pic, pic_value obj);
+pic_value pic_deserialize(pic_state *pic, pic_value blob);
+
+
+/*
+ * string
+ */
+
+bool pic_str_p(pic_state *, pic_value);
+pic_value pic_str_value(pic_state *, const char *str, int len);
+pic_value pic_cstr_value(pic_state *, const char *str);
+#define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, sizeof lit - 1)
+pic_value pic_strf_value(pic_state *, const char *fmt, ...);
+pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap);
+const char *pic_str(pic_state *, pic_value str, int *len);
+const char *pic_cstr(pic_state *, pic_value str, int *len);
+int pic_str_len(pic_state *, pic_value str);
+pic_value pic_str_cat(pic_state *, pic_value str1, pic_value str2);
+pic_value pic_str_sub(pic_state *, pic_value str, int i, int j);
+
+
+/*
+ * symbol
+ */
+
+bool pic_sym_p(pic_state *, pic_value);
+pic_value pic_intern(pic_state *, pic_value str);
+#define pic_intern_str(pic,s,i) pic_intern(pic, pic_str_value(pic, (s), (i)))
+#define pic_intern_cstr(pic,s) pic_intern(pic, pic_cstr_value(pic, (s)))
+#define pic_intern_lit(pic,lit) pic_intern(pic, pic_lit_value(pic, lit))
+pic_value pic_sym_name(pic_state *, pic_value sym);
+
+
 /*
  * pair
  */
@@ -191,36 +217,14 @@ bool pic_dict_next(pic_state *, pic_value dict, int *iter, pic_value *key, pic_v
 
 
 /*
- * ephemeron table
+ * attribute
  */
 
-bool pic_weak_p(pic_state *, pic_value);
-pic_value pic_make_weak(pic_state *);
-pic_value pic_weak_ref(pic_state *, pic_value weak, pic_value key);
-void pic_weak_set(pic_state *, pic_value weak, pic_value key, pic_value val);
-void pic_weak_del(pic_state *, pic_value weak, pic_value key);
-bool pic_weak_has(pic_state *, pic_value weak, pic_value key);
-
-
-/*
- * string
- */
-
-int pic_str_len(pic_state *, pic_value str);
-pic_value pic_str_cat(pic_state *, pic_value str1, pic_value str2);
-pic_value pic_str_sub(pic_state *, pic_value str, int i, int j);
-
-
-/*
- * symbol
- */
-
-bool pic_sym_p(pic_state *, pic_value);
-pic_value pic_intern(pic_state *, pic_value str);
-#define pic_intern_str(pic,s,i) pic_intern(pic, pic_str_value(pic, (s), (i)))
-#define pic_intern_cstr(pic,s) pic_intern(pic, pic_cstr_value(pic, (s)))
-#define pic_intern_lit(pic,lit) pic_intern(pic, pic_lit_value(pic, lit))
-pic_value pic_sym_name(pic_state *, pic_value sym);
+pic_value pic_make_attr(pic_state *);
+pic_value pic_attr_ref(pic_state *, pic_value attr, pic_value key);
+void pic_attr_set(pic_state *, pic_value attr, pic_value key, pic_value val);
+void pic_attr_del(pic_state *, pic_value attr, pic_value key);
+bool pic_attr_has(pic_state *, pic_value attr, pic_value key);
 
 
 /*
@@ -235,90 +239,13 @@ int pic_get_args(pic_state *, const char *fmt, ...);
 pic_value pic_closure_ref(pic_state *, int i);
 void pic_closure_set(pic_state *, int i, pic_value v);
 pic_value pic_call(pic_state *, pic_value proc, int, ...);
+pic_value pic_callk(pic_state *, pic_value proc, int, ...);
 pic_value pic_vcall(pic_state *, pic_value proc, int, va_list);
+pic_value pic_vcallk(pic_state *, pic_value proc, int, va_list);
 pic_value pic_apply(pic_state *, pic_value proc, int n, pic_value *argv);
 pic_value pic_applyk(pic_state *, pic_value proc, int n, pic_value *argv);
 
 
-/*
- * port
- */
-
-typedef struct {
-  int (*read)(pic_state *, void *, char *, int);
-  int (*write)(pic_state *, void *, const char *, int);
-  long (*seek)(pic_state *, void *, long, int);
-  int (*close)(pic_state *, void *);
-} pic_port_type;
-
-#define PIC_SEEK_CUR 0
-#define PIC_SEEK_END 1
-#define PIC_SEEK_SET 2
-
-#define pic_stdin(pic) pic_funcall(pic, "current-input-port", 0)
-#define pic_stdout(pic) pic_funcall(pic, "current-output-port", 0)
-#define pic_stderr(pic) pic_funcall(pic, "current-error-port", 0)
-bool pic_eof_p(pic_state *, pic_value);
-pic_value pic_eof_object(pic_state *);
-bool pic_port_p(pic_state *, pic_value, const pic_port_type *type);
-pic_value pic_funopen(pic_state *, void *cookie, const pic_port_type *type);
-size_t pic_fread(pic_state *, void *ptr, size_t size, size_t count, pic_value port);
-size_t pic_fwrite(pic_state *, const void *ptr, size_t size, size_t count, pic_value port);
-long pic_fseek(pic_state *, pic_value port, long offset, int whence);
-int pic_fclose(pic_state *, pic_value port);
-/* error */
-void pic_clearerr(pic_state *, pic_value port);
-int pic_feof(pic_state *, pic_value port);
-int pic_ferror(pic_state *, pic_value port);
-/* basic I/O */
-int pic_fputc(pic_state *, int c, pic_value port);
-int pic_fgetc(pic_state *, pic_value port);
-int pic_fputs(pic_state *, const char *s, pic_value port);
-char *pic_fgets(pic_state *, char *s, int size, pic_value port);
-int pic_ungetc(pic_state *, int c, pic_value port);
-int pic_fflush(pic_state *, pic_value port);
-/* formatted output */
-int pic_printf(pic_state *, const char *fmt, ...);
-int pic_fprintf(pic_state *, pic_value port, const char *fmt, ...);
-int pic_vfprintf(pic_state *, pic_value port, const char *fmt, va_list ap);
-/* string buffer */
-pic_value pic_fmemopen(pic_state *, const char *buf, int len, const char *mode); /* deprecated */
-int pic_fgetbuf(pic_state *, pic_value port, const char **buf, int *len); /* deprecated */
-
-
-/*
- * error handling
- */
-
-typedef void (*pic_panicf)(pic_state *, const char *msg);
-pic_panicf pic_atpanic(pic_state *, pic_panicf f);
-PIC_NORETURN void pic_panic(pic_state *, const char *msg);
-pic_value pic_raise_continuable(pic_state *pic, pic_value err);
-PIC_NORETURN void pic_raise(pic_state *, pic_value v);
-PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...);
-pic_value pic_make_error(pic_state *, const char *type, const char *msg, pic_value irrs);
-pic_value pic_get_backtrace(pic_state *); /* deprecated */
-#define pic_try pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp))
-#define pic_try_(cont, jmp)                                             \
-  do {                                                                  \
-    extern void pic_start_try(pic_state *, PIC_JMPBUF *);               \
-    extern void pic_end_try(pic_state *);                               \
-    extern pic_value pic_err(pic_state *);                              \
-    PIC_JMPBUF jmp;                                                     \
-    if (PIC_SETJMP(pic, jmp) == 0) {                                    \
-      pic_start_try(pic, &jmp);
-#define pic_catch(e) pic_catch_(e, PIC_GENSYM(label))
-#define pic_catch_(e, label)                              \
-      pic_end_try(pic);                                   \
-    } else {                                              \
-      e = pic_err(pic);                                   \
-      goto label;                                         \
-    }                                                     \
-  } while (0);                                            \
-  if (0)                                                  \
-  label:
-
-
 /*
  * core language features
  */
@@ -333,7 +260,8 @@ void pic_defvar(pic_state *, const char *name, pic_value v);
 pic_value pic_funcall(pic_state *, const char *name, int n, ...);
 pic_value pic_values(pic_state *, int n, ...);
 pic_value pic_vvalues(pic_state *, int n, va_list);
-int pic_receive(pic_state *, int n, pic_value *retv);
+PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...);
+PIC_NORETURN void pic_verror(pic_state *pic, const char *msg, int n, va_list ap);
 
 
 /*

lib/include/picrin/extra.h

@@ -9,35 +9,86 @@
 extern "C" {
 #endif
 
-
 #if PIC_USE_LIBC
 void *pic_default_allocf(void *, void *, size_t);
+void pic_default_panicf(pic_state *, const char *, int, pic_value *);
 #endif
 
-pic_value pic_read(pic_state *, pic_value port);
-pic_value pic_read_cstr(pic_state *, const char *);
+#if PIC_USE_PORT
+typedef struct {
+  int (*read)(pic_state *, void *, char *, int);
+  int (*write)(pic_state *, void *, const char *, int);
+  long (*seek)(pic_state *, void *, long, int);
+  int (*close)(pic_state *, void *);
+} pic_port_type;
 
-void pic_load(pic_state *, pic_value port);
-void pic_load_cstr(pic_state *, const char *);
+#ifndef EOF
+# define EOF (-1)
+#endif
 
-#if PIC_USE_STDIO
+#define PIC_SEEK_CUR 0
+#define PIC_SEEK_END 1
+#define PIC_SEEK_SET 2
+
+#define PIC_IONBF 0
+#define PIC_IOLBF 1
+#define PIC_IOFBF 2
+
+#define pic_stdin(pic) pic_funcall(pic, "current-input-port", 0)
+#define pic_stdout(pic) pic_funcall(pic, "current-output-port", 0)
+#define pic_stderr(pic) pic_funcall(pic, "current-error-port", 0)
+bool pic_eof_p(pic_state *, pic_value);
+pic_value pic_eof_object(pic_state *);
+bool pic_port_p(pic_state *, pic_value, const pic_port_type *type);
+/* basic methods */
+pic_value pic_funopen(pic_state *, void *cookie, const pic_port_type *type);
+size_t pic_fread(pic_state *, void *ptr, size_t size, size_t count, pic_value port);
+size_t pic_fwrite(pic_state *, const void *ptr, size_t size, size_t count, pic_value port);
+long pic_fseek(pic_state *, pic_value port, long offset, int whence);
+int pic_fclose(pic_state *, pic_value port);
+/* error handling */
+void pic_clearerr(pic_state *, pic_value port);
+int pic_feof(pic_state *, pic_value port);
+int pic_ferror(pic_state *, pic_value port);
+/* character I/O */
+int pic_fputc(pic_state *, int c, pic_value port);
+int pic_fgetc(pic_state *, pic_value port);
+int pic_fputs(pic_state *, const char *s, pic_value port);
+char *pic_fgets(pic_state *, char *s, int size, pic_value port);
+int pic_ungetc(pic_state *, int c, pic_value port);
+int pic_fflush(pic_state *, pic_value port);
+int pic_setvbuf(pic_state *, pic_value port, char *buf, int mode, size_t size);
+/* formatted output */
+int pic_printf(pic_state *, const char *fmt, ...);
+int pic_fprintf(pic_state *, pic_value port, const char *fmt, ...);
+int pic_vfprintf(pic_state *, pic_value port, const char *fmt, va_list ap);
+#endif
+
+#if PIC_USE_FILE
 pic_value pic_fopen(pic_state *, FILE *, const char *mode);
 #endif
 
-
-/*
- * library
- */
-
-void pic_deflibrary(pic_state *, const char *lib);
-void pic_in_library(pic_state *, const char *lib);
-void pic_export(pic_state *, int n, ...);
-
-
-/* for debug */
-
-#if PIC_USE_WRITE
-void pic_print_error(pic_state *, pic_value port, pic_value err);
+#if PIC_USE_ERROR
+# define pic_try pic_try_(PIC_GENSYM(jmp))
+# define pic_try_(jmp)                                                  \
+  do {                                                                  \
+    extern PIC_JMPBUF *pic_prepare_try(pic_state *);                    \
+    extern void pic_enter_try(pic_state *);                             \
+    extern void pic_exit_try(pic_state *);                              \
+    extern pic_value pic_abort_try(pic_state *);                        \
+    PIC_JMPBUF *jmp = pic_prepare_try(pic);                             \
+    if (PIC_SETJMP(*jmp) == 0) {                                        \
+      pic_enter_try(pic);
+# define pic_catch(e) pic_catch_(e, PIC_GENSYM(label))
+# define pic_catch_(e, label)                             \
+      pic_exit_try(pic);                                  \
+    } else {                                              \
+      e = pic_abort_try(pic);                             \
+      goto label;                                         \
+    }                                                     \
+  } while (0);                                            \
+  if (0)                                                  \
+  label:
 #endif
 
 #if defined(__cplusplus)

lib/include/picrin/setup.h

@@ -2,38 +2,66 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picconf.h"
+#include <picconf.h>
 
 #ifndef PIC_USE_LIBC
 # define PIC_USE_LIBC 1
 #endif
 
-#ifndef PIC_USE_STDIO
-# define PIC_USE_STDIO 1
+#ifndef PIC_USE_PORT
+# define PIC_USE_PORT 1
+#endif
+
+#ifndef PIC_USE_CONT
+# define PIC_USE_CONT 1
+#endif
+
+#ifndef PIC_USE_READ
+# define PIC_USE_READ 1
 #endif
 
 #ifndef PIC_USE_WRITE
 # define PIC_USE_WRITE 1
 #endif
 
-#ifndef PIC_JMPBUF
+#ifndef PIC_USE_EVAL
+# define PIC_USE_EVAL 1
+#endif
+
+#ifndef PIC_USE_FILE
+# define PIC_USE_FILE 1
+#endif
+
+#ifndef PIC_USE_ERROR
+# define PIC_USE_ERROR 1
+#endif
+
+#if !PIC_USE_PORT && PIC_USE_READ
+# error PIC_USE_READ requires PIC_USE_PORT
+#endif
+#if !PIC_USE_PORT && PIC_USE_WRITE
+# error PIC_USE_WRITE requires PIC_USE_PORT
+#endif
+#if !PIC_USE_PORT && PIC_USE_FILE
+# error PIC_USE_FILE requires PIC_USE_PORT
+#endif
+#if !PIC_USE_LIBC && PIC_USE_FILE
+# error PIC_USE_FILE requires PIC_USE_LIBC
+#endif
+#if !PIC_USE_LIBC && PIC_USE_CONT
+# error PIC_USE_CONT requires PIC_USE_LIBC
+#endif
+#if !PIC_USE_CONT && PIC_USE_ERROR
+# error PIC_USE_ERROR requires PIC_USE_CONT
+#endif
+
+#if PIC_USE_CONT
 # include <setjmp.h>
 # define PIC_JMPBUF jmp_buf
-#endif
-
-#ifndef PIC_SETJMP
-# include <setjmp.h>
-# define PIC_SETJMP(pic, buf) setjmp(buf)
-#endif
-
-#ifndef PIC_LONGJMP
-# include <setjmp.h>
-# define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val))
-#endif
-
-#ifndef PIC_ABORT
-void abort(void);
-# define PIC_ABORT(pic) abort()
+# define PIC_SETJMP(buf) setjmp(buf)
+#else
+# define PIC_JMPBUF char
+# define PIC_SETJMP(buf) ((void)(buf), 0)
 #endif
 
 #ifndef PIC_BUFSIZ
@@ -44,40 +72,8 @@ void abort(void);
 # define PIC_ARENA_SIZE (8 * 1024)
 #endif
 
-#ifndef PIC_HEAP_PAGE_SIZE
-# define PIC_HEAP_PAGE_SIZE (4 * 1024 * 1024)
-#endif
-
-#ifndef PIC_PAGE_REQUEST_THRESHOLD
-# define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100)
-#endif
-
-#ifndef PIC_STACK_SIZE
-# define PIC_STACK_SIZE 2048
-#endif
-
-#ifndef PIC_RESCUE_SIZE
-# define PIC_RESCUE_SIZE 30
-#endif
-
-#ifndef PIC_SYM_POOL_SIZE
-# define PIC_SYM_POOL_SIZE (2 * 1024)
-#endif
-
-#ifndef PIC_IREP_SIZE
-# define PIC_IREP_SIZE 8
-#endif
-
-#ifndef PIC_POOL_SIZE
-# define PIC_POOL_SIZE 8
-#endif
-
-#ifndef PIC_SYMS_SIZE
-# define PIC_SYMS_SIZE 32
-#endif
-
-#ifndef PIC_ISEQ_SIZE
-# define PIC_ISEQ_SIZE 1024
+#ifndef PIC_GC_PERIOD
+# define PIC_GC_PERIOD (8 * 1024 * 1024)
 #endif
 
 /* check compatibility */
@@ -165,7 +161,7 @@ typedef unsigned long uint32_t;
 # define GCC_VERSION (__GNUC__ * 10000 + __GNUC_MINOR__ * 100 + __GNUC_PATCHLEVEL__)
 #endif
 #if GCC_VERSION >= 40500 || __clang__
-# define PIC_UNREACHABLE() (__builtin_unreachable())
+# define PIC_UNREACHABLE() (assert(false), __builtin_unreachable())
 #else
 # define PIC_UNREACHABLE() (assert(false))
 #endif
@@ -401,8 +397,17 @@ atof(const char *nptr)
 
 #endif
 
-#if PIC_USE_STDIO
+PIC_STATIC_INLINE double
+pic_atod(const char *str)
+{
+  return atof(str);
+}
+
+#if PIC_USE_FILE
 # include <stdio.h>
+#endif
+
+#if PIC_USE_LIBC
 
 PIC_STATIC_INLINE void
 pic_dtoa(double dval, char *buf)
@@ -461,16 +466,6 @@ pic_dtoa(double dval, char *buf)
 
 #endif
 
-#ifndef PIC_DOUBLE_TO_CSTRING
-#define PIC_DOUBLE_TO_CSTRING pic_dtoa
-#endif
-void PIC_DOUBLE_TO_CSTRING(double, char *);
-
-#ifndef PIC_CSTRING_TO_DOUBLE
-#define PIC_CSTRING_TO_DOUBLE atof
-#endif
-double PIC_CSTRING_TO_DOUBLE(const char *);
-
 /* optional features available? */
 
 #if (defined(__GNUC__) || defined(__clang__)) && ! defined(__STRICT_ANSI__)
@@ -485,9 +480,3 @@ double PIC_CSTRING_TO_DOUBLE(const char *);
 #else
 # define PIC_NAN_BOXING 0
 #endif
-
-#if PIC_USE_LIBC && (defined (__unix__) || (defined (__APPLE__) && defined (__MACH__)))
-# include <unistd.h>
-# define PIC_MEMALIGN(pic, buf, alignment, size) posix_memalign(buf, alignment, size)
-# define PIC_BITMAP_GC 1
-#endif

lib/include/picrin/value.h

@@ -1,276 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_VALUE_H
-#define PICRIN_VALUE_H
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-enum {
-  PIC_TYPE_INVALID   = 1,
-  PIC_TYPE_FLOAT     = 2,
-  PIC_TYPE_INT       = 3,
-  PIC_TYPE_CHAR      = 4,
-  PIC_TYPE_EOF       = 5,
-  PIC_TYPE_UNDEF     = 6,
-  PIC_TYPE_TRUE      = 8,
-  PIC_TYPE_NIL       = 7,
-  PIC_TYPE_FALSE     = 9,
-  PIC_IVAL_END       = 10,
-/* -------------------- */
-  PIC_TYPE_STRING    = 16,
-  PIC_TYPE_VECTOR    = 17,
-  PIC_TYPE_BLOB      = 18,
-  PIC_TYPE_PORT      = 20,
-  PIC_TYPE_ERROR     = 21,
-  PIC_TYPE_ID        = 22,
-  PIC_TYPE_ENV       = 23,
-  PIC_TYPE_DATA      = 24,
-  PIC_TYPE_DICT      = 25,
-  PIC_TYPE_WEAK      = 26,
-  PIC_TYPE_RECORD    = 27,
-  PIC_TYPE_SYMBOL    = 28,
-  PIC_TYPE_PAIR      = 29,
-  PIC_TYPE_CXT       = 30,
-  PIC_TYPE_PROC_FUNC = 32,
-  PIC_TYPE_PROC_IREP = 33,
-  PIC_TYPE_IREP      = 34,
-  PIC_TYPE_MAX       = 63
-};
-
-PIC_STATIC_INLINE bool pic_int_p(pic_state *, pic_value);
-PIC_STATIC_INLINE bool pic_float_p(pic_state *, pic_value);
-PIC_STATIC_INLINE bool pic_char_p(pic_state *, pic_value);
-
-#if !PIC_NAN_BOXING
-
-PIC_STATIC_INLINE pic_value
-pic_make_value(int type)
-{
-  pic_value v;
-  v.type = type;
-  v.u.data = NULL;
-  return v;
-}
-
-PIC_STATIC_INLINE int
-pic_type(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  return (int)(v.type);
-}
-
-PIC_STATIC_INLINE int
-pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  assert(pic_int_p(pic, v));
-  return v.u.i;
-}
-
-PIC_STATIC_INLINE double
-pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  assert(pic_float_p(v));
-  return v.u.f;
-}
-
-PIC_STATIC_INLINE char
-pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  assert(pic_char_p(v));
-  return v.u.c;
-}
-
-PIC_STATIC_INLINE pic_value
-pic_int_value(pic_state *PIC_UNUSED(pic), int i)
-{
-  pic_value v = pic_make_value(PIC_TYPE_INT);
-  v.u.i = i;
-  return v;
-}
-
-PIC_STATIC_INLINE pic_value
-pic_float_value(pic_state *PIC_UNUSED(pic), double f)
-{
-  pic_value v = pic_make_value(PIC_TYPE_FLOAT);
-  v.u.f = f;
-  return v;
-}
-
-PIC_STATIC_INLINE pic_value
-pic_char_value(pic_state *PIC_UNUSED(pic), char c)
-{
-  pic_value v = pic_make_value(PIC_TYPE_CHAR);
-  v.u.c = c;
-  return v;
-}
-
-#else  /* NAN_BOXING */
-
-/**
- * value representation by nan-boxing:
- *   float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF
- *   ptr   : 111111111111TTTT TTPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP
- *   int   : 111111111111TTTT TT00000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII
- *   char  : 111111111111TTTT TT00000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
- */
-
-PIC_STATIC_INLINE pic_value
-pic_make_value(int type)
-{
-  pic_value v;
-  v.v = 0xfff0000000000000ul | ((uint64_t)(type) << 46);
-  return v;
-}
-
-PIC_STATIC_INLINE int
-pic_type(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  return 0xfff0000000000000ul >= v.v ? PIC_TYPE_FLOAT : ((v.v >> 46) & 0x3f);
-}
-
-PIC_STATIC_INLINE int
-pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  union { int i; unsigned u; } u;
-  assert(pic_int_p(pic, v));
-  u.u = v.v & 0xfffffffful;
-  return u.i;
-}
-
-PIC_STATIC_INLINE double
-pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  union { double f; uint64_t i; } u;
-  assert(pic_float_p(pic, v));
-  u.i = v.v;
-  return u.f;
-}
-
-PIC_STATIC_INLINE char
-pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  assert(pic_char_p(pic, v));
-  return v.v & 0xfffffffful;
-}
-
-PIC_STATIC_INLINE pic_value
-pic_int_value(pic_state *PIC_UNUSED(pic), int i)
-{
-  pic_value v = pic_make_value(PIC_TYPE_INT);
-  v.v |= (unsigned)i;
-  return v;
-}
-
-PIC_STATIC_INLINE pic_value
-pic_float_value(pic_state *PIC_UNUSED(pic), double f)
-{
-  union { double f; uint64_t i; } u;
-  pic_value v;
-
-  if (f != f) {
-    v.v = 0x7ff8000000000000ul;
-  } else {
-    u.f = f;
-    v.v = u.i;
-  }
-  return v;
-}
-
-PIC_STATIC_INLINE pic_value
-pic_char_value(pic_state *PIC_UNUSED(pic), char c)
-{
-  pic_value v = pic_make_value(PIC_TYPE_CHAR);
-  v.v |= (unsigned char)c;
-  return v;
-}
-
-#endif  /* NAN_BOXING end */
-
-#define DEFVAL(name, type)                                              \
-  PIC_STATIC_INLINE pic_value name(pic_state *PIC_UNUSED(pic)) {        \
-    return pic_make_value(type);                                        \
-  }
-
-DEFVAL(pic_nil_value, PIC_TYPE_NIL)
-DEFVAL(pic_eof_object, PIC_TYPE_EOF)
-DEFVAL(pic_true_value, PIC_TYPE_TRUE)
-DEFVAL(pic_false_value, PIC_TYPE_FALSE)
-DEFVAL(pic_undef_value, PIC_TYPE_UNDEF)
-DEFVAL(pic_invalid_value, PIC_TYPE_INVALID)
-
-PIC_STATIC_INLINE pic_value
-pic_bool_value(pic_state *PIC_UNUSED(pic), bool b)
-{
-  return pic_make_value(b ? PIC_TYPE_TRUE : PIC_TYPE_FALSE);
-}
-
-#define DEFPRED(name, type)                                     \
-  PIC_STATIC_INLINE bool name(pic_state *pic, pic_value obj) {  \
-    return pic_type(pic, obj) == type;                          \
-  }
-
-DEFPRED(pic_invalid_p, PIC_TYPE_INVALID)
-DEFPRED(pic_float_p, PIC_TYPE_FLOAT)
-DEFPRED(pic_int_p, PIC_TYPE_INT)
-DEFPRED(pic_char_p, PIC_TYPE_CHAR)
-DEFPRED(pic_eof_p, PIC_TYPE_EOF)
-DEFPRED(pic_undef_p, PIC_TYPE_UNDEF)
-DEFPRED(pic_true_p, PIC_TYPE_TRUE)
-DEFPRED(pic_nil_p, PIC_TYPE_NIL)
-DEFPRED(pic_false_p, PIC_TYPE_FALSE)
-DEFPRED(pic_str_p, PIC_TYPE_STRING)
-DEFPRED(pic_vec_p, PIC_TYPE_VECTOR)
-DEFPRED(pic_blob_p, PIC_TYPE_BLOB)
-DEFPRED(pic_error_p, PIC_TYPE_ERROR)
-DEFPRED(pic_dict_p, PIC_TYPE_DICT)
-DEFPRED(pic_weak_p, PIC_TYPE_WEAK)
-DEFPRED(pic_env_p, PIC_TYPE_ENV)
-DEFPRED(pic_rec_p, PIC_TYPE_RECORD)
-DEFPRED(pic_sym_p, PIC_TYPE_SYMBOL)
-DEFPRED(pic_pair_p, PIC_TYPE_PAIR)
-DEFPRED(pic_proc_func_p, PIC_TYPE_PROC_FUNC)
-DEFPRED(pic_proc_irep_p, PIC_TYPE_PROC_IREP)
-DEFPRED(pic_irep_p, PIC_TYPE_IREP)
-
-PIC_STATIC_INLINE bool
-pic_bool_p(pic_state *pic, pic_value obj)
-{
-  return pic_true_p(pic, obj) || pic_false_p(pic, obj);
-}
-
-PIC_STATIC_INLINE bool
-pic_proc_p(pic_state *pic, pic_value o)
-{
-  return pic_proc_func_p(pic, o) || pic_proc_irep_p(pic, o);
-}
-
-PIC_STATIC_INLINE bool
-pic_id_p(pic_state *pic, pic_value o)
-{
-  return pic_type(pic, o) == PIC_TYPE_ID || pic_sym_p(pic, o);
-}
-
-#if PIC_NAN_BOXING
-
-PIC_STATIC_INLINE bool
-pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
-{
-  return x.v == y.v;
-}
-
-PIC_STATIC_INLINE bool
-pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
-{
-  return x.v == y.v;
-}
-
-#endif
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

lib/number.c

@@ -2,7 +2,8 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 
 static pic_value
@@ -72,7 +73,7 @@ pic_number_exact(pic_state *pic)
     } else if (pic_float_p(pic, a) && pic_int_p(pic, b)) {              \
       return pic_float_value(pic, pic_float(pic, a) op pic_int(pic, b)); \
     } else {                                                            \
-      pic_error(pic, #name ": non-number operand given", 0);              \
+      pic_error(pic, #name ": non-number operand given", 2, a, b);      \
     }                                                                   \
     PIC_UNREACHABLE();                                                  \
   }
@@ -95,7 +96,7 @@ pic_define_aop(pic_div, /, f == (int)f)
     } else if (pic_float_p(pic, a) && pic_int_p(pic, b)) {              \
       return pic_float(pic, a) op pic_int(pic, b);                      \
     } else {                                                            \
-      pic_error(pic, #name ": non-number operand given", 0);              \
+      pic_error(pic, #name ": non-number operand given", 2, a, b);      \
     }                                                                   \
     PIC_UNREACHABLE();                                                  \
   }
@@ -170,45 +171,34 @@ DEFINE_AOP(div, pic_div(pic, pic_int_value(pic, 1), argv[0]), do {
   } while (0))
 
 static int
-number_string_length(int val, int radix)
+int2str(long x, int base, char *buf)
 {
-  unsigned long v = val; /* in case val == INT_MIN */
-  int count = 0;
-  if (val == 0) {
-    return 1;
-  }
-  if (val < 0) {
-    v = -val;
-    count = 1;
-  }
-  while (v > 0) {
-    ++count;
-    v /= radix;
-  }
-  return count;
-}
+  static const char digits[36] = "0123456789abcdefghijklmnopqrstuvwxyz";
+  int i, neg, len;
 
-static void
-number_string(int val, int radix, int length, char *buffer) {
-  const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz";
-  unsigned long v = val;
-  int i;
-  if (val == 0) {
-    buffer[0] = '0';
-    buffer[1] = '\0';
-    return;
-  }
-  if (val < 0) {
-    buffer[0] = '-';
-    v = -val;
+  neg = 0;
+  if (x < 0) {
+    neg = 1;
+    x = -x;
   }
 
-  for(i = length - 1; v > 0; --i) {
-    buffer[i] = digits[v % radix];
-    v /= radix;
+  i = 0;
+  do {
+    buf[i++] = digits[x % base];
+  } while ((x /= base) != 0);
+
+  if (neg) {
+    buf[i++] = '-';
   }
-  buffer[length] = '\0';
-  return;
+  buf[i] = '\0';
+  len = i;
+
+  for (i = 0; i < len / 2; ++i) {
+    char tmp = buf[i];
+    buf[i] = buf[len - i - 1];
+    buf[len - i - 1] = tmp;
+  }
+  return len;
 }
 
 static pic_value
@@ -217,35 +207,23 @@ pic_number_number_to_string(pic_state *pic)
   double f;
   bool e;
   int radix = 10;
-  pic_value str;
 
   pic_get_args(pic, "F|i", &f, &e, &radix);
 
   if (radix < 2 || radix > 36) {
-    pic_error(pic, "number->string: invalid radix (between 2 and 36, inclusive)", 1, pic_int_value(pic, radix));
+    pic_error(pic, "invalid radix (between 2 and 36, inclusive)", 1, pic_int_value(pic, radix));
   }
 
   if (e) {
-    int ival = (int) f;
-    int ilen = number_string_length(ival, radix);
-    char *buf = pic_alloca(pic, ilen + 1);
-
-    number_string(ival, radix, ilen, buf);
-
-    str = pic_str_value(pic, buf, ilen);
+    char buf[sizeof(int) * CHAR_BIT + 3];
+    int len = int2str((int) f, radix, buf);
+    return pic_str_value(pic, buf, len);
   }
   else {
-    pic_value port = pic_fmemopen(pic, NULL, 0, "w");
-    const char *buf;
-    int len;
-
-    pic_fprintf(pic, port, "%f", f);
-    pic_fgetbuf(pic, port, &buf, &len);
-    str = pic_str_value(pic, buf, len);
-    pic_fclose(pic, port);
+    char buf[64];
+    pic_dtoa(f, buf);
+    return pic_cstr_value(pic, buf);
   }
-
-  return str;
 }
 
 static bool
@@ -295,7 +273,7 @@ string_to_number(pic_state *pic, const char *str)
     return pic_false_value(pic);
   }
 
-  flt = PIC_CSTRING_TO_DOUBLE(str);
+  flt = pic_atod(str);
 
   if (isint && INT_MIN <= flt && flt <= INT_MAX) {
     return pic_int_value(pic, flt);

lib/object.h

@@ -11,71 +11,56 @@ extern "C" {
 
 #include "khash.h"
 
-#if PIC_BITMAP_GC
-# define OBJECT_HEADER                           \
+#define OBJECT_HEADER                           \
+  struct object *next;                          \
   unsigned char tt;
-#else
-# define OBJECT_HEADER                           \
-  unsigned char tt;                              \
-  char gc_mark;
-#endif
 
-struct object;              /* defined in gc.c */
+#define TYPE_MASK 0x7f
+#define GC_MARK 0x80
 
-struct basic {
+struct object {
   OBJECT_HEADER
 };
 
-struct identifier {
-  OBJECT_HEADER
-  union {
-    struct string *str;
-    struct identifier *id;
-  } u;
-  struct env *env;
-};
-
-typedef struct identifier symbol;
-
-KHASH_DECLARE(env, struct identifier *, symbol *)
-
-struct env {
-  OBJECT_HEADER
-  khash_t(env) map;
-  struct env *up;
-  struct string *prefix;
-};
-
-struct pair {
-  OBJECT_HEADER
-  pic_value car;
-  pic_value cdr;
-};
-
 struct blob {
   OBJECT_HEADER
   unsigned char *data;
   int len;
 };
 
+#define ROPE_HEADER                             \
+  OBJECT_HEADER                                 \
+  int len;
+
+struct rope {
+  ROPE_HEADER
+};
+
+struct rope_leaf {
+  ROPE_HEADER
+  const char *str;
+};
+
+struct rope_node {
+  ROPE_HEADER
+  struct rope *s1;
+  struct rope *s2;
+};
+
 struct string {
   OBJECT_HEADER
   struct rope *rope;
 };
 
-KHASH_DECLARE(dict, symbol *, pic_value)
-
-struct dict {
+struct symbol {
   OBJECT_HEADER
-  khash_t(dict) hash;
+  struct string *str;
 };
 
-KHASH_DECLARE(weak, struct object *, pic_value)
-
-struct weak {
+struct pair {
   OBJECT_HEADER
-  khash_t(weak) hash;
-  struct weak *prev;         /* for GC */
+  pic_value car;
+  pic_value cdr;
 };
 
 struct vector {
@@ -84,6 +69,21 @@ struct vector {
   int len;
 };
 
+KHASH_DECLARE(dict, struct symbol *, pic_value)
+
+struct dict {
+  OBJECT_HEADER
+  khash_t(dict) hash;
+};
+
+KHASH_DECLARE(attr, struct object *, pic_value)
+
+struct attr {
+  OBJECT_HEADER
+  khash_t(attr) hash;
+  struct attr *prev;         /* for GC */
+};
+
 struct data {
   OBJECT_HEADER
   const pic_data_type *type;
@@ -92,92 +92,66 @@ struct data {
 
 struct record {
   OBJECT_HEADER
-  pic_value type;
+  struct symbol *type;
   pic_value datum;
 };
 
-struct code {
-  int insn;
-  int a;
-  int b;
+enum {
+  OP_HALT  = 0x00,        /* 0x00                 OP_HALT           */
+  OP_CALL  = 0x01,        /* 0x01 0x**            OP_CALL argc      */
+  OP_PROC  = 0x02,        /* 0x02 0x** 0x**       OP_PROC dest irep */
+  OP_LOAD  = 0x03,        /* 0x03 0x** 0x**       OP_LOAD dest i    */
+  OP_LREF  = 0x04,        /* 0x04 0x** 0x** 0x**  OP_LREF dest n i  */
+  OP_LSET  = 0x05,        /* 0x05 0x** 0x** 0x**  OP_LSET src n i   */
+  OP_GREF  = 0x06,        /* 0x06 0x** 0x**       OP_GREF dest i    */
+  OP_GSET  = 0x07,        /* 0x07 0x** 0x**       OP_GSET src i     */
+  OP_COND  = 0x08,        /* 0x08 0x** 0x** 0x**  OP_COND c offset  */
+  OP_LOADT = 0x09,        /* 0x09 0x**            OP_LOADT dest     */
+  OP_LOADF = 0x0A,        /* 0x0A 0x**            OP_LOADF dest     */
+  OP_LOADN = 0x0B,        /* 0x0B 0x**            OP_LOADN dest     */
+  OP_LOADU = 0x0C,        /* 0x0C 0x**            OP_LOADU dest     */
+  OP_LOADI = 0x0D         /* 0x0D 0x** 0x**       OP_LOADI dest i   */
 };
 
+typedef unsigned char code_t;
+
+#define IREP_VARG 1
+#define IREP_CODE_STATIC 2
+
 struct irep {
   OBJECT_HEADER
-  int argc, localc, capturec;
-  bool varg;
-  struct code *code;
+  unsigned char argc;
+  unsigned char flags;
+  unsigned char frame_size;
+  unsigned char irepc, objc;
+  size_t codec;
   struct irep **irep;
-  int *ints;
-  double *nums;
-  struct object **pool;
-  size_t ncode, nirep, nints, nnums, npool;
+  pic_value *obj;
+  const code_t *code;
 };
 
-struct context {
+struct frame {
   OBJECT_HEADER
+  unsigned char regc;
   pic_value *regs;
-  int regc;
-  struct context *up;
-  pic_value storage[1];
+  struct frame *up;
 };
 
 struct proc {
   OBJECT_HEADER
   union {
-    struct {
-      pic_func_t func;
-      int localc;
-    } f;
-    struct {
-      struct irep *irep;
-      struct context *cxt;
-    } i;
+    pic_func_t func;
+    struct irep *irep;
   } u;
-  pic_value locals[1];
-};
-
-enum {
-  FILE_READ  = 01,
-  FILE_WRITE = 02,
-  FILE_UNBUF = 04,
-  FILE_EOF   = 010,
-  FILE_ERR   = 020,
-  FILE_LNBUF = 040
-};
-
-struct port {
-  OBJECT_HEADER
-  struct file {
-    /* buffer */
-    char buf[1];                  /* fallback buffer */
-    long cnt;                     /* characters left */
-    char *ptr;                    /* next character position */
-    char *base;                   /* location of the buffer */
-    /* operators */
-    void *cookie;
-    const pic_port_type *vtable;
-    int flag;                     /* mode of the file access */
-  } file;
-};
-
-struct error {
-  OBJECT_HEADER
-  symbol *type;
-  struct string *msg;
-  pic_value irrs;
-  struct string *stack;
+  struct frame *env;
 };
 
 #define TYPENAME_int   "integer"
 #define TYPENAME_blob  "bytevector"
 #define TYPENAME_char  "character"
 #define TYPENAME_sym   "symbol"
-#define TYPENAME_error "error"
 #define TYPENAME_proc  "procedure"
 #define TYPENAME_str   "string"
-#define TYPENAME_id    "identifier"
-#define TYPENAME_env   "environment"
 #define TYPENAME_vec   "vector"
 
 #define TYPE_CHECK(pic, v, type) do {                           \
@@ -199,104 +173,49 @@ struct error {
   } while (0)
 
 PIC_STATIC_INLINE int
-obj_tt(pic_state *PIC_UNUSED(pic), void *ptr)
+obj_type(void *ptr)
 {
-  return ((struct basic *)ptr)->tt;
-}
-
-#if !PIC_NAN_BOXING
-
-PIC_STATIC_INLINE struct object *
-obj_ptr(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  return (struct object *)(v.u.data);
-}
-
-PIC_STATIC_INLINE bool
-obj_p(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  return v.type > PIC_IVAL_END;
+  return ((struct object *) ptr)->tt & TYPE_MASK;
 }
 
 PIC_STATIC_INLINE pic_value
-obj_value(pic_state *PIC_UNUSED(pic), void *ptr)
+obj_value(pic_state *pic, void *ptr)
 {
-  pic_value v = pic_make_value(obj_tt(pic, ptr));
-  v.u.data = ptr;
-  return v;
+  return pic_obj_value(pic, ptr, obj_type(ptr));
 }
 
-#else  /* NAN_BOXING */
-
-PIC_STATIC_INLINE struct object *
-obj_ptr(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  return (struct object *)((0x3ffffffffffful & v.v) << 2);
-}
-
-PIC_STATIC_INLINE bool
-obj_p(pic_state *PIC_UNUSED(pic), pic_value v)
-{
-  return v.v > ((0x3ffC0ul + (0x3f & PIC_IVAL_END)) << 46);
-}
-
-PIC_STATIC_INLINE pic_value
-obj_value(pic_state *PIC_UNUSED(pic), void *ptr)
-{
-  pic_value v = pic_make_value(obj_tt(pic, ptr));
-  v.v |= 0x3ffffffffffful & ((uint64_t)ptr >> 2);
-  return v;
-}
-
-#endif  /* NAN_BOXING */
-
-#define DEFPTR(name,type)                                               \
-  PIC_STATIC_INLINE type *                                              \
-  pic_##name##_ptr(pic_state *PIC_UNUSED(pic), pic_value o) {           \
-    assert(pic_##name##_p(pic,o));                                      \
-    return (type *) obj_ptr(pic, o);                                    \
+#define DEFPTR(name,type)                       \
+  PIC_STATIC_INLINE type *                      \
+  name##_ptr(pic_state *pic, pic_value o) {     \
+    assert(pic_##name##_p(pic,o));              \
+    return (type *) pic_ptr(pic, o);            \
   }
 
 #define pic_data_p(pic,o) (pic_data_p(pic,o,NULL))
-#define pic_port_p(pic,o) (pic_port_p(pic,o,NULL))
-DEFPTR(id, struct identifier)
-DEFPTR(sym, symbol)
+DEFPTR(sym, struct symbol)
 DEFPTR(str, struct string)
 DEFPTR(blob, struct blob)
 DEFPTR(pair, struct pair)
 DEFPTR(vec, struct vector)
 DEFPTR(dict, struct dict)
-DEFPTR(weak, struct weak)
+DEFPTR(attr, struct attr)
 DEFPTR(data, struct data)
 DEFPTR(proc, struct proc)
-DEFPTR(env, struct env)
-DEFPTR(port, struct port)
-DEFPTR(error, struct error)
 DEFPTR(rec, struct record)
 DEFPTR(irep, struct irep)
 #undef pic_data_p
-#undef pic_port_p
 
-struct object *pic_obj_alloc(pic_state *, size_t, int type);
+struct object *pic_obj_alloc(pic_state *, int type);
+struct object *pic_obj_alloc_unsafe(pic_state *, int type);
 
-pic_value pic_make_identifier(pic_state *, pic_value id, pic_value env);
-pic_value pic_make_proc(pic_state *, pic_func_t, int, pic_value *);
-pic_value pic_make_proc_irep(pic_state *, struct irep *, struct context *);
-pic_value pic_make_env(pic_state *, pic_value prefix);
+struct frame *pic_make_frame_unsafe(pic_state *, int n);
+pic_value pic_make_proc_irep_unsafe(pic_state *, struct irep *, struct frame *);
 pic_value pic_make_record(pic_state *, pic_value type, pic_value datum);
-
-pic_value pic_add_identifier(pic_state *, pic_value id, pic_value env);
-pic_value pic_find_identifier(pic_state *, pic_value id, pic_value env);
-void pic_set_identifier(pic_state *, pic_value id, pic_value uid, pic_value env);
-pic_value pic_id_name(pic_state *, pic_value id);
-
-struct rope *pic_rope_incref(struct rope *);
-void pic_rope_decref(pic_state *, struct rope *);
-
-struct cont *pic_alloca_cont(pic_state *);
-pic_value pic_make_cont(pic_state *, struct cont *);
-void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *);
-void pic_exit_point(pic_state *);
+pic_value pic_record_type(pic_state *pic, pic_value record);
+pic_value pic_record_datum(pic_state *pic, pic_value record);
+pic_value pic_make_cont(pic_state *pic, pic_value k);
+int pic_str_hash(pic_state *pic, pic_value str);
+int pic_str_cmp(pic_state *pic, pic_value str1, pic_value str2);
 
 void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */
 

lib/pair.c

@@ -2,7 +2,8 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 
 pic_value
@@ -10,7 +11,7 @@ pic_cons(pic_state *pic, pic_value car, pic_value cdr)
 {
   struct pair *pair;
 
-  pair = (struct pair *)pic_obj_alloc(pic, sizeof(struct pair), PIC_TYPE_PAIR);
+  pair = (struct pair *)pic_obj_alloc(pic, PIC_TYPE_PAIR);
   pair->car = car;
   pair->cdr = cdr;
 
@@ -23,7 +24,7 @@ pic_car(pic_state *pic, pic_value obj)
   if (! pic_pair_p(pic, obj)) {
     pic_error(pic, "car: pair required", 1, obj);
   }
-  return pic_pair_ptr(pic, obj)->car;
+  return pair_ptr(pic, obj)->car;
 }
 
 pic_value
@@ -32,7 +33,7 @@ pic_cdr(pic_state *pic, pic_value obj)
   if (! pic_pair_p(pic, obj)) {
     pic_error(pic, "cdr: pair required", 1, obj);
   }
-  return pic_pair_ptr(pic, obj)->cdr;
+  return pair_ptr(pic, obj)->cdr;
 }
 
 void
@@ -41,7 +42,7 @@ pic_set_car(pic_state *pic, pic_value obj, pic_value val)
   if (! pic_pair_p(pic, obj)) {
     pic_error(pic, "pair required", 0);
   }
-  pic_pair_ptr(pic, obj)->car = val;
+  pair_ptr(pic, obj)->car = val;
 }
 
 void
@@ -50,7 +51,7 @@ pic_set_cdr(pic_state *pic, pic_value obj, pic_value val)
   if (! pic_pair_p(pic, obj)) {
     pic_error(pic, "pair required", 0);
   }
-  pic_pair_ptr(pic, obj)->cdr = val;
+  pair_ptr(pic, obj)->cdr = val;
 }
 
 pic_value
@@ -91,7 +92,7 @@ pic_list_p(pic_state *pic, pic_value obj)
     /* advance rapid fast-forward; runs 2x faster than local */
     for (i = 0; i < 2; ++i) {
       if (pic_pair_p(pic, rapid)) {
-        rapid = pic_pair_ptr(pic, rapid)->cdr;
+        rapid = pic_cdr(pic, rapid);
       }
       else {
         return pic_nil_p(pic, rapid);
@@ -99,7 +100,7 @@ pic_list_p(pic_state *pic, pic_value obj)
     }
 
     /* advance local */
-    local = pic_pair_ptr(pic, local)->cdr;
+    local = pic_cdr(pic, local);
 
     if (pic_eq_p(pic, local, rapid)) {
       return false;
@@ -153,7 +154,7 @@ pic_list_ref(pic_state *pic, pic_value list, int i)
 void
 pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj)
 {
-  pic_pair_ptr(pic, pic_list_tail(pic, list, i))->car = obj;
+  pic_set_car(pic, pic_list_tail(pic, list, i), obj);
 }
 
 pic_value

lib/record.c

@@ -2,7 +2,8 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 
 pic_value
@@ -10,19 +11,31 @@ pic_make_record(pic_state *pic, pic_value type, pic_value datum)
 {
   struct record *rec;
 
-  rec = (struct record *)pic_obj_alloc(pic, sizeof(struct record), PIC_TYPE_RECORD);
-  rec->type = type;
+  rec = (struct record *)pic_obj_alloc(pic, PIC_TYPE_RECORD);
+  rec->type = sym_ptr(pic, type);
   rec->datum = datum;
 
   return obj_value(pic, rec);
 }
 
+pic_value
+pic_record_type(pic_state *pic, pic_value rec)
+{
+  return obj_value(pic, rec_ptr(pic, rec)->type);
+}
+
+pic_value
+pic_record_datum(pic_state *pic, pic_value rec)
+{
+  return rec_ptr(pic, rec)->datum;
+}
+
 static pic_value
 pic_rec_make_record(pic_state *pic)
 {
   pic_value type, datum;
 
-  pic_get_args(pic, "oo", &type, &datum);
+  pic_get_args(pic, "mo", &type, &datum);
 
   return pic_make_record(pic, type, datum);
 }
@@ -44,7 +57,7 @@ pic_rec_record_type(pic_state *pic)
 
   pic_get_args(pic, "r", &rec);
 
-  return pic_rec_ptr(pic, rec)->type;
+  return pic_record_type(pic, rec);
 }
 
 static pic_value
@@ -54,7 +67,7 @@ pic_rec_record_datum(pic_state *pic)
 
   pic_get_args(pic, "r", &rec);
 
-  return pic_rec_ptr(pic, rec)->datum;
+  return pic_record_datum(pic, rec);
 }
 
 void

lib/state.c

@@ -2,24 +2,369 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
-#include "picrin/extra.h"
+#include <picrin.h>
+#include <picrin/extra.h>
+#include "value.h"
 #include "object.h"
 #include "state.h"
 
+static pic_value pic_state_features(pic_state *);
+
+void
+pic_add_feature(pic_state *pic, const char *feature)
+{
+  pic_value f = pic_ref(pic, "__picrin_features__");
+
+  pic_set(pic, "__picrin_features__", pic_cons(pic, pic_intern_cstr(pic, feature), f));
+}
+
+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_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_var(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_attr(pic_state *);
+void pic_init_file(pic_state *);
+void pic_init_state(pic_state *);
+void pic_init_eval(pic_state *);
+
+#define DONE pic_leave(pic, ai);
+
+static void
+pic_init_core(pic_state *pic)
+{
+  size_t ai = pic_enter(pic);
+
+  pic_define(pic, "__picrin_features__", pic_nil_value(pic));
+  pic_define(pic, "__picrin_dynenv__", pic_list(pic, 1, pic_make_attr(pic)));
+
+  pic_init_bool(pic); DONE;
+  pic_init_pair(pic); DONE;
+  pic_init_number(pic); DONE;
+  pic_init_proc(pic); DONE;
+  pic_init_symbol(pic); DONE;
+  pic_init_vector(pic); DONE;
+  pic_init_blob(pic); DONE;
+  pic_init_char(pic); DONE;
+  pic_init_str(pic); DONE;
+  pic_init_var(pic); DONE;
+  pic_init_dict(pic); DONE;
+  pic_init_record(pic); DONE;
+  pic_init_attr(pic); DONE;
+  pic_init_state(pic); DONE;
+
+#if PIC_USE_CONT
+  pic_init_cont(pic); DONE;
+#endif
+#if PIC_USE_PORT
+  pic_init_port(pic); DONE;
+#endif
+#if PIC_USE_READ
+  pic_init_read(pic); DONE;
+#endif
+#if PIC_USE_WRITE
+  pic_init_write(pic); DONE;
+#endif
+#if PIC_USE_FILE
+  pic_init_file(pic); DONE;
+#endif
+#if PIC_USE_EVAL
+  pic_init_eval(pic); DONE;
+#endif
+#if PIC_USE_ERROR
+  pic_init_error(pic); DONE;
+#endif
+}
+
+pic_state *
+pic_open(pic_allocf allocf, void *userdata, pic_panicf panicf)
+{
+  pic_state *pic;
+
+  pic = allocf(userdata, NULL, sizeof(pic_state));
+
+  if (! pic) {
+    goto EXIT_PIC;
+  }
+
+  /* allocator */
+  pic->allocf = allocf;
+
+  /* user data */
+  pic->userdata = userdata;
+
+  /* panic handler */
+  pic->panicf = panicf;
+
+  /* context */
+  pic->default_cxt.ai = 0;
+  pic->default_cxt.pc = NULL;
+  pic->default_cxt.fp = NULL;
+  pic->default_cxt.sp = NULL;
+  pic->default_cxt.irep = NULL;
+  pic->default_cxt.prev = NULL;
+  pic->default_cxt.conts = pic_nil_value(pic);
+  pic->cxt = &pic->default_cxt;
+
+  /* arena */
+  pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *));
+  pic->arena_size = PIC_ARENA_SIZE;
+  pic->ai = 0;
+
+  if (! pic->arena) {
+    goto EXIT_ARENA;
+  }
+
+  /* turn off GC */
+  pic->gc_enable = false;
+
+  /* gc */
+  pic->gc_head.next = (struct object *) &pic->gc_head;
+  pic->gc_attrs = NULL;
+  pic->gc_count = 0;
+
+  /* symbol table */
+  kh_init(oblist, &pic->oblist);
+
+  /* global variables */
+  pic->globals = pic_make_dict(pic);
+
+  /* top continuation */
+  {
+    static const code_t halt_code[] = { 0x00 };
+    struct irep *irep;
+    struct proc *proc;
+    irep = (struct irep *)pic_obj_alloc(pic, PIC_TYPE_IREP);
+    irep->argc = 1;
+    irep->flags = IREP_CODE_STATIC;
+    irep->frame_size = 1;
+    irep->irepc = 0;
+    irep->objc = 0;
+    irep->irep = NULL;
+    irep->obj = NULL;
+    irep->code = halt_code;
+    irep->codec = sizeof halt_code / sizeof halt_code[0];
+    proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
+    proc->u.irep = irep;
+    proc->env = NULL;
+    pic->halt = obj_value(pic, proc);
+  }
+
+  /* turn on GC */
+  pic->gc_enable = true;
+
+  pic_init_core(pic);
+
+  pic_leave(pic, 0);            /* empty arena */
+
+  return pic;
+
+ EXIT_ARENA:
+  allocf(userdata, pic, 0);
+ EXIT_PIC:
+  return NULL;
+}
+
+void
+pic_close(pic_state *pic)
+{
+  pic_allocf allocf = pic->allocf;
+
+  /* clear out root objects */
+  pic->cxt = &pic->default_cxt;
+  pic->ai = 0;
+  pic->halt = pic_invalid_value(pic);
+  pic->globals = pic_invalid_value(pic);
+
+  assert(pic->cxt->ai == 0);
+  assert(pic->cxt->pc == NULL);
+  assert(pic->cxt->fp == NULL);
+  assert(pic->cxt->sp == NULL);
+  assert(pic->cxt->irep == NULL);
+  assert(pic->cxt->prev == NULL);
+
+  /* free all heap objects */
+  pic_gc(pic);
+
+  assert(pic->gc_head.next == (struct object *) &pic->gc_head);
+
+  /* free global stacks */
+  kh_destroy(oblist, &pic->oblist);
+
+  /* free GC arena */
+  allocf(pic->userdata, pic->arena, 0);
+  allocf(pic->userdata, pic, 0);
+}
+
+void
+pic_warnf(pic_state *PIC_UNUSED(pic), const char *PIC_UNUSED(fmt), ...)
+{
+#if PIC_USE_FILE
+  va_list ap;
+  pic_value err;
+
+  va_start(ap, fmt);
+  err = pic_vstrf_value(pic, fmt, ap);
+  va_end(ap);
+  pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_cstr(pic, err, NULL));
+#endif
+}
+
+pic_value
+pic_global_ref(pic_state *pic, pic_value sym)
+{
+  if (! pic_dict_has(pic, pic->globals, sym)) {
+    pic_error(pic, "undefined variable", 1, sym);
+  }
+  return pic_dict_ref(pic, pic->globals, sym);
+}
+
+void
+pic_global_set(pic_state *pic, pic_value sym, pic_value value)
+{
+  pic_dict_set(pic, pic->globals, sym, value);
+}
+
+pic_value
+pic_ref(pic_state *pic, const char *name)
+{
+  size_t ai = pic_enter(pic);
+  pic_value r = pic_global_ref(pic, pic_intern_cstr(pic, name));
+  pic_leave(pic, ai);
+  return pic_protect(pic, r);
+}
+
+void
+pic_set(pic_state *pic, const char *name, pic_value val)
+{
+  size_t ai = pic_enter(pic);
+  pic_global_set(pic, pic_intern_cstr(pic, name), val);
+  pic_leave(pic, ai);
+}
+
+void
+pic_define(pic_state *pic, const char *name, pic_value val)
+{
+  pic_value sym = pic_intern_cstr(pic, name);
+
+  if (pic_dict_has(pic, pic->globals, sym)) {
+    pic_warnf(pic, "redefining variable: %s", name);
+  }
+  pic_dict_set(pic, pic->globals, sym, val);
+}
+
+void
+pic_defun(pic_state *pic, const char *name, pic_func_t f)
+{
+  pic_define(pic, name, pic_lambda(pic, f, 0));
+}
+
+void
+pic_defvar(pic_state *pic, const char *name, pic_value init)
+{
+  pic_define(pic, name, pic_make_var(pic, init, pic_false_value(pic)));
+}
+
+pic_value
+pic_funcall(pic_state *pic, const char *name, int n, ...)
+{
+  size_t ai = pic_enter(pic);
+  pic_value proc, r;
+  va_list ap;
+
+  proc = pic_ref(pic, name);
+
+  TYPE_CHECK(pic, proc, proc);
+
+  va_start(ap, n);
+  r = pic_vcall(pic, proc, n, ap);
+  va_end(ap);
+
+  pic_leave(pic, ai);
+  return pic_protect(pic, r);
+}
+
+#if PIC_USE_LIBC
+void
+pic_default_panicf(pic_state *PIC_UNUSED(pic), const char *msg, int PIC_UNUSED(n), pic_value *PIC_UNUSED(args))
+{
+  fprintf(stderr, "panic!: %s\n", msg);
+  abort();
+}
+#endif
+
+void
+pic_error(pic_state *pic, const char *msg, int n, ...)
+{
+  va_list ap;
+
+  va_start(ap, n);
+  pic_verror(pic, msg, n, ap);
+  va_end(ap);
+  PIC_UNREACHABLE();
+}
+
+void
+pic_verror(pic_state *pic, const char *msg, int n, va_list ap)
+{
+  pic_value error = pic_ref(pic, "error");
+  int i;
+  pic_value *args;
+
+  args = pic_alloca(pic, sizeof(pic_value) * (n + 1));
+  args[0] = pic_cstr_value(pic, msg);
+  for (i = 0; i < n; ++i) {
+    args[i + 1] = va_arg(ap, pic_value);
+  }
+
+  pic_apply(pic, error, n + 1, args);
+  PIC_UNREACHABLE();
+}
+
 static pic_value
-pic_features(pic_state *pic)
+pic_state_features(pic_state *pic)
 {
   pic_get_args(pic, "");
 
-  return pic->features;
+  return pic_ref(pic, "__picrin_features__");
 }
 
-static void
-pic_init_features(pic_state *pic)
+static pic_value
+pic_state_global_objects(pic_state *pic)
 {
-  pic_defun(pic, "features", pic_features);
+  pic_get_args(pic, "");
 
+  return pic->globals;
+}
+
+static pic_value
+pic_state_error(pic_state *pic)
+{
+  const char *msg;
+  int argc;
+  pic_value *args;
+
+  pic_get_args(pic, "z*", &msg, &argc, &args);
+
+  pic->panicf(pic, msg, argc, args);
+  PIC_UNREACHABLE();
+}
+
+void
+pic_init_state(pic_state *pic)
+{
   pic_add_feature(pic, "picrin");
 
 #if __STDC_IEC_559__
@@ -73,273 +418,8 @@ pic_init_features(pic_state *pic)
   pic_add_feature(pic, "big-endian");
 # endif
 #endif
-}
-
-void
-pic_add_feature(pic_state *pic, const char *feature)
-{
-  pic_push(pic, 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_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_var(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_weak(pic_state *);
-
-void pic_boot(pic_state *);
-
-#define DONE pic_leave(pic, ai);
-
-static void
-pic_init_core(pic_state *pic)
-{
-  size_t ai = pic_enter(pic);
-
-  pic_init_features(pic); DONE;
-  pic_init_bool(pic); DONE;
-  pic_init_pair(pic); DONE;
-  pic_init_port(pic); DONE;
-  pic_init_number(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_var(pic); DONE;
-  pic_init_read(pic); DONE;
-  pic_init_dict(pic); DONE;
-  pic_init_record(pic); DONE;
-  pic_init_eval(pic); DONE;
-  pic_init_weak(pic); DONE;
-
-#if PIC_USE_WRITE
-  pic_init_write(pic); DONE;
-#endif
-
-  pic_boot(pic); DONE;
-}
-
-pic_state *
-pic_open(pic_allocf allocf, void *userdata)
-{
-  pic_state *pic;
-
-  pic = allocf(userdata, NULL, sizeof(pic_state));
-
-  if (! pic) {
-    goto EXIT_PIC;
-  }
-
-  /* allocator */
-  pic->allocf = allocf;
-
-  /* user data */
-  pic->userdata = userdata;
-
-  /* turn off GC */
-  pic->gc_enable = false;
-
-  /* continuation chain */
-  pic->cc = NULL;
-
-  /* prepare VM stack */
-  pic->stbase = pic->sp = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_value));
-  pic->stend = pic->stbase + PIC_STACK_SIZE;
-
-  if (! pic->sp) {
-    goto EXIT_SP;
-  }
-
-  /* callinfo */
-  pic->cibase = pic->ci = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(struct callinfo));
-  pic->ciend = pic->cibase + PIC_STACK_SIZE;
-
-  if (! pic->ci) {
-    goto EXIT_CI;
-  }
-
-  /* GC arena */
-  pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *));
-  pic->arena_size = PIC_ARENA_SIZE;
-  pic->arena_idx = 0;
-
-  if (! pic->arena) {
-    goto EXIT_ARENA;
-  }
-
-  /* memory heap */
-  pic->heap = pic_heap_open(pic);
-
-  /* symbol table */
-  kh_init(oblist, &pic->oblist);
-
-  /* unique symbol count */
-  pic->ucnt = 0;
-
-  /* global variables */
-  pic->globals = pic_invalid_value(pic);
-
-  /* macros */
-  pic->macros = pic_invalid_value(pic);
-
-  /* features */
-  pic->features = pic_nil_value(pic);
-
-  /* dynamic environment */
-  pic->dyn_env = pic_invalid_value(pic);
-
-  /* raised error object */
-  pic->panicf = NULL;
-  pic->err = pic_invalid_value(pic);
-
-  /* root tables */
-  pic->globals = pic_make_dict(pic);
-  pic->macros = pic_make_weak(pic);
-  pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic));
-
-  /* turn on GC */
-  pic->gc_enable = true;
-
-  pic_init_core(pic);
-
-  pic_leave(pic, 0);            /* empty arena */
-
-  return pic;
-
- EXIT_ARENA:
-  allocf(userdata, pic->ci, 0);
- EXIT_CI:
-  allocf(userdata, pic->sp, 0);
- EXIT_SP:
-  allocf(userdata, pic, 0);
- EXIT_PIC:
-  return NULL;
-}
-
-void
-pic_close(pic_state *pic)
-{
-  pic_allocf allocf = pic->allocf;
-
-  /* clear out root objects */
-  pic->sp = pic->stbase;
-  pic->ci = pic->cibase;
-  pic->arena_idx = 0;
-  pic->err = pic_invalid_value(pic);
-  pic->globals = pic_invalid_value(pic);
-  pic->macros = pic_invalid_value(pic);
-  pic->features = pic_invalid_value(pic);
-  pic->dyn_env = pic_invalid_value(pic);
-
-  /* free all heap objects */
-  pic_gc(pic);
-
-  /* free heaps */
-  pic_heap_close(pic, pic->heap);
-
-  /* free runtime context */
-  allocf(pic->userdata, pic->stbase, 0);
-  allocf(pic->userdata, pic->cibase, 0);
-
-  /* free global stacks */
-  kh_destroy(oblist, &pic->oblist);
-
-  /* free GC arena */
-  allocf(pic->userdata, pic->arena, 0);
-
-  allocf(pic->userdata, pic, 0);
-}
-
-pic_value
-pic_global_ref(pic_state *pic, pic_value sym)
-{
-  pic_value val;
-
-  if (! pic_dict_has(pic, pic->globals, sym)) {
-    pic_error(pic, "undefined variable", 1, sym);
-  }
-  val = pic_dict_ref(pic, pic->globals, sym);
-  if (pic_invalid_p(pic, val)) {
-    pic_error(pic, "uninitialized global variable", 1, sym);
-  }
-  return val;
-}
-
-void
-pic_global_set(pic_state *pic, pic_value sym, pic_value value)
-{
-  if (! pic_dict_has(pic, pic->globals, sym)) {
-    pic_error(pic, "undefined variable", 1, sym);
-  }
-  pic_dict_set(pic, pic->globals, sym, value);
-}
-
-pic_value
-pic_ref(pic_state *pic, const char *name)
-{
-  return pic_global_ref(pic, pic_intern_cstr(pic, name));
-}
-
-void
-pic_set(pic_state *pic, const char *name, pic_value val)
-{
-  pic_global_set(pic, pic_intern_cstr(pic, name), val);
-}
-
-void
-pic_define(pic_state *pic, const char *name, pic_value val)
-{
-  pic_value sym = pic_intern_cstr(pic, name);
-
-  if (pic_dict_has(pic, pic->globals, sym)) {
-    pic_warnf(pic, "redefining variable: %s", pic_str(pic, pic_sym_name(pic, sym), NULL));
-  }
-  pic_dict_set(pic, pic->globals, sym, val);
-}
-
-void
-pic_defun(pic_state *pic, const char *name, pic_func_t f)
-{
-  pic_define(pic, name, pic_make_proc(pic, f, 0, NULL));
-}
-
-void
-pic_defvar(pic_state *pic, const char *name, pic_value init)
-{
-  pic_define(pic, name, pic_make_var(pic, init, pic_false_value(pic)));
-}
-
-pic_value
-pic_funcall(pic_state *pic, const char *name, int n, ...)
-{
-  pic_value proc, r;
-  va_list ap;
-
-  proc = pic_ref(pic, name);
-
-  TYPE_CHECK(pic, proc, proc);
-
-  va_start(ap, n);
-  r = pic_vcall(pic, proc, n, ap);
-  va_end(ap);
-
-  return r;
+
+  pic_defun(pic, "features", pic_state_features);
+  pic_defun(pic, "global-objects", pic_state_global_objects);
+  pic_defun(pic, "error", pic_state_error);
 }

lib/state.h

@@ -10,61 +10,109 @@ extern "C" {
 #endif
 
 #include "khash.h"
-#include "vm.h"
+#include "object.h"
 
-struct callinfo {
-  int argc, retc;
-  const struct code *ip;
-  pic_value *fp;
+KHASH_DECLARE(oblist, struct string *, struct symbol *)
+
+struct context {
+  PIC_JMPBUF jmp;
+  size_t ai;
+
+  /* vm */
+  const code_t *pc;
+  struct frame *sp;
+  struct frame *fp;
   struct irep *irep;
-  struct context *cxt;
-  int regc;
-  pic_value *regs;
-  struct context *up;
-};
 
-KHASH_DECLARE(oblist, struct string *, struct identifier *)
+  code_t tmpcode[2];
+  pic_value conts;
+  bool reset;
+
+  struct context *prev;
+};
 
 struct pic_state {
   pic_allocf allocf;
   void *userdata;
 
-  struct cont *cc;
-
-  pic_value *sp;
-  pic_value *stbase, *stend;
-
-  struct callinfo *ci;
-  struct callinfo *cibase, *ciend;
-
-  const struct code *ip;
-
-  pic_value dyn_env;
-
-  pic_value features;
+  struct context *cxt, default_cxt;
+  size_t ai;
 
   khash_t(oblist) oblist;       /* string to symbol */
-  int ucnt;
   pic_value globals;            /* dict */
-  pic_value macros;             /* weak */
+
+  struct object **arena;
+  size_t arena_size;
 
   bool gc_enable;
-  struct heap *heap;
-  struct object **arena;
-  size_t arena_size, arena_idx;
+  struct object gc_head;
+  struct attr *gc_attrs;
+  size_t gc_count;
 
-  pic_value err;
+  pic_value halt;               /* top continuation */
 
   pic_panicf panicf;
 };
 
-struct heap *pic_heap_open(pic_state *);
-void pic_heap_close(pic_state *, struct heap *);
-
 pic_value pic_global_ref(pic_state *pic, pic_value uid);
 void pic_global_set(pic_state *pic, pic_value uid, pic_value value);
 
-void pic_vm_tear_off(pic_state *pic);
+#define MKCALL(cxt,argc)                                                \
+  ((argc) < 256                                                         \
+   ? ((cxt)->tmpcode[0] = OP_CALL, (cxt)->tmpcode[1] = (argc), (cxt)->tmpcode) \
+   : (pic_error(pic, "too many arguments", 1, pic_int_value(pic, (argc))), NULL))
+
+#define CONTEXT_VINITK(pic,cxt,proc,k,n,ap) do {        \
+    int i;                                              \
+    (cxt)->pc = MKCALL((cxt), (n) + 1);                 \
+    (cxt)->sp = pic_make_frame_unsafe(pic, (n) + 3);    \
+    (cxt)->sp->regs[0] = (proc);                        \
+    (cxt)->sp->regs[1] = k;                             \
+    for (i = 0; i < (n); ++i) {                         \
+      (cxt)->sp->regs[i + 2] = va_arg(ap, pic_value);   \
+    }                                                   \
+    (cxt)->fp = NULL;                                   \
+    (cxt)->irep = NULL;                                 \
+  } while (0)
+
+#define CONTEXT_INITK(pic,cxt,proc,k,n,argv) do {       \
+    int i;                                              \
+    (cxt)->pc = MKCALL((cxt), (n) + 1);                 \
+    (cxt)->sp = pic_make_frame_unsafe(pic, (n) + 3);    \
+    (cxt)->sp->regs[0] = (proc);                        \
+    (cxt)->sp->regs[1] = k;                             \
+    for (i = 0; i < (n); ++i) {                         \
+      (cxt)->sp->regs[i + 2] = (argv)[i];               \
+    }                                                   \
+    (cxt)->fp = NULL;                                   \
+    (cxt)->irep = NULL;                                 \
+  } while (0)
+
+#define CONTEXT_VINIT(pic,cxt,proc,n,ap) do {           \
+    int i;                                              \
+    (cxt)->pc = MKCALL((cxt), (n));                     \
+    (cxt)->sp = pic_make_frame_unsafe(pic, (n) + 2);    \
+    (cxt)->sp->regs[0] = (proc);                        \
+    for (i = 0; i < (n); ++i) {                         \
+      (cxt)->sp->regs[i + 1] = va_arg(ap, pic_value);   \
+    }                                                   \
+    (cxt)->fp = NULL;                                   \
+    (cxt)->irep = NULL;                                 \
+  } while (0)
+
+#define CONTEXT_INIT(pic,cxt,proc,n,argv) do {          \
+    int i;                                              \
+    (cxt)->pc = MKCALL((cxt), (n));                     \
+    (cxt)->sp = pic_make_frame_unsafe(pic, (n) + 2);    \
+    (cxt)->sp->regs[0] = (proc);                        \
+    for (i = 0; i < (n); ++i) {                         \
+      (cxt)->sp->regs[i + 1] = (argv)[i];               \
+    }                                                   \
+    (cxt)->fp = NULL;                                   \
+    (cxt)->irep = NULL;                                 \
+  } while (0)
+
+void pic_vm(pic_state *pic, struct context *cxt);
 
 #if defined(__cplusplus)
 }

lib/string.c

@@ -2,215 +2,30 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 
-struct rope {
-  int refcnt;
-  int weight;
-  bool isleaf;
-  union {
-    struct {
-      struct rope *owner;
-      const char *str;          /* always points to zero-term'd buf */
-    } leaf;
-    struct {
-      struct rope *left, *right;
-    } node;
-  } u;
-  char buf[1];
-};
-
-struct rope *
-pic_rope_incref(struct rope *rope) {
-  rope->refcnt++;
-  return rope;
-}
-
-void
-pic_rope_decref(pic_state *pic, struct rope *rope) {
-  if (! --rope->refcnt) {
-    if (rope->isleaf) {
-      if (rope->u.leaf.owner) {
-        pic_rope_decref(pic, rope->u.leaf.owner);
-      }
-    } else {
-      pic_rope_decref(pic, rope->u.node.left);
-      pic_rope_decref(pic, rope->u.node.right);
-    }
-    pic_free(pic, rope);
-  }
-}
-
-static struct rope *
-make_rope_leaf(pic_state *pic, const char *str, int len)
-{
-  struct rope *rope;
-
-  rope = pic_malloc(pic, offsetof(struct rope, buf) + len + 1);
-  rope->refcnt = 1;
-  rope->weight = len;
-  rope->isleaf = true;
-  rope->u.leaf.owner = NULL;
-  rope->u.leaf.str = rope->buf;
-  rope->buf[len] = 0;
-  if (str) {
-    memcpy(rope->buf, str, len);
-  }
-
-  return rope;
-}
-
-static struct rope *
-make_rope_lit(pic_state *pic, const char *str, int len)
-{
-  struct rope *rope;
-
-  rope = pic_malloc(pic, offsetof(struct rope, buf));
-  rope->refcnt = 1;
-  rope->weight = len;
-  rope->isleaf = true;
-  rope->u.leaf.owner = NULL;
-  rope->u.leaf.str = str;
-
-  return rope;
-}
-
-static struct rope *
-make_rope_slice(pic_state *pic, struct rope *owner, int i, int j)
-{
-  struct rope *rope, *real_owner;
-
-  assert(owner->isleaf);
-
-  real_owner = owner->u.leaf.owner == NULL ? owner : owner->u.leaf.owner;
-
-  rope = pic_malloc(pic, offsetof(struct rope, buf));
-  rope->refcnt = 1;
-  rope->weight = j - i;
-  rope->isleaf = true;
-  rope->u.leaf.owner = real_owner;
-  rope->u.leaf.str = owner->u.leaf.str + i;
-
-  pic_rope_incref(real_owner);
-
-  return rope;
-}
-
-static struct rope *
-make_rope_node(pic_state *pic, struct rope *left, struct rope *right)
-{
-  struct rope *rope;
-
-  rope = pic_malloc(pic, sizeof(struct rope));
-  rope->refcnt = 1;
-  rope->weight = left->weight + right->weight;
-  rope->isleaf = false;
-  rope->u.node.left = pic_rope_incref(left);
-  rope->u.node.right = pic_rope_incref(right);
-
-  return rope;
-}
-
-static pic_value
-make_str(pic_state *pic, struct rope *rope)
-{
-  struct string *str;
-
-  str = (struct string *)pic_obj_alloc(pic, sizeof(struct string), PIC_TYPE_STRING);
-  str->rope = rope;             /* delegate ownership */
-
-  return obj_value(pic, str);
-}
-
-static struct rope *
-merge(pic_state *pic, struct rope *left, struct rope *right)
-{
-  if (left == 0)
-    return pic_rope_incref(right);
-  if (right == 0)
-    return pic_rope_incref(left);
-
-  return make_rope_node(pic, left, right);
-}
-
-static struct rope *
-slice(pic_state *pic, struct rope *rope, int i, int j)
-{
-  int lweight;
-
-  if (i == 0 && rope->weight == j) {
-    return pic_rope_incref(rope);
-  }
-
-  if (rope->isleaf) {
-    return make_rope_slice(pic, rope, i, j);
-  }
-
-  lweight = rope->u.node.left->weight;
-
-  if (j <= lweight) {
-    return slice(pic, rope->u.node.left, i, j);
-  } else if (lweight <= i) {
-    return slice(pic, rope->u.node.right, i - lweight, j - lweight);
-  } else {
-    struct rope *r, *l;
-
-    l = slice(pic, rope->u.node.left, i, lweight);
-    r = slice(pic, rope->u.node.right, 0, j - lweight);
-    rope = merge(pic, l, r);
-
-    pic_rope_decref(pic, l);
-    pic_rope_decref(pic, r);
-
-    return rope;
-  }
-}
-
-static void
-flatten(pic_state *pic, struct rope *rope, struct rope *owner, char *buf)
-{
-  if (rope->isleaf) {
-    memcpy(buf, rope->u.leaf.str, rope->weight);
-  } else {
-    flatten(pic, rope->u.node.left, owner, buf);
-    flatten(pic, rope->u.node.right, owner, buf + rope->u.node.left->weight);
-  }
-
-  /* path compression */
-
-  if (! rope->isleaf) {
-    pic_rope_incref(owner);
-    pic_rope_decref(pic, rope->u.node.left);
-    pic_rope_decref(pic, rope->u.node.right);
-    rope->isleaf = true;
-    rope->u.leaf.owner = owner;
-    rope->u.leaf.str = buf;
-  }
-}
-
-static void
-str_update(pic_state *pic, pic_value dst, pic_value src)
-{
-  pic_rope_incref(pic_str_ptr(pic, src)->rope);
-  pic_rope_decref(pic, pic_str_ptr(pic, dst)->rope);
-  pic_str_ptr(pic, dst)->rope = pic_str_ptr(pic, src)->rope;
-}
-
 pic_value
 pic_str_value(pic_state *pic, const char *str, int len)
 {
-  struct rope *r;
+  char *buf;
+  struct rope_leaf *leaf;
+  struct string *s;
 
-  if (len > 0) {
-    r = make_rope_leaf(pic, str, len);
-  } else {
-    if (len == 0) {
-      str = "";
-    }
-    r = make_rope_lit(pic, str, -len);
-  }
-  return make_str(pic, r);
+  assert(str != NULL);
+
+  buf = pic_malloc(pic, len + 1);
+  buf[len] = 0;
+  memcpy(buf, str, len);
+
+  leaf = (struct rope_leaf *) pic_obj_alloc(pic, PIC_TYPE_ROPE_LEAF);
+  leaf->len = len;
+  leaf->str = buf;
+
+  s = (struct string *) pic_obj_alloc(pic, PIC_TYPE_STRING);
+  s->rope = (struct rope *) leaf;
+  return obj_value(pic, s);
 }
 
 pic_value
@@ -228,62 +43,213 @@ pic_strf_value(pic_state *pic, const char *fmt, ...)
   va_start(ap, fmt);
   str = pic_vstrf_value(pic, fmt, ap);
   va_end(ap);
-
   return str;
 }
 
 pic_value
 pic_vstrf_value(pic_state *pic, const char *fmt, va_list ap)
 {
-  pic_value str, port;
-  const char *buf;
-  int len;
+  pic_value str, str2;
+  const char *p;
 
-  port = pic_fmemopen(pic, NULL, 0, "w");
-
-  pic_vfprintf(pic, port, fmt, ap);
-  pic_fgetbuf(pic, port, &buf, &len);
-  str = pic_str_value(pic, buf, len);
-  pic_fclose(pic, port);
-  return str;
+  for (p = fmt; *p; p++) {
+    if (*p == '%')
+      break;
+  }
+  str = pic_str_value(pic, fmt, p - fmt);
+  if (*p == 0) {
+    return str;
+  }
+  p++;                          /* skip '%' */
+  switch (*p++) {
+  case '\0':
+    return pic_str_value(pic, fmt, p - fmt - 1);
+  case 'd':
+  case 'i': {
+    int i = va_arg(ap, int);
+    str2 = pic_funcall(pic, "number->string", 1, pic_int_value(pic, i));
+    break;
+  }
+  case 'f': {
+    double f = va_arg(ap, double);
+    str2 = pic_funcall(pic, "number->string", 1, pic_float_value(pic, f));
+    break;
+  }
+  case 'c': {
+    char c = (char) va_arg(ap, int);
+    str2 = pic_str_value(pic, &c, 1);
+    break;
+  }
+  case 's': {
+    char *sval = va_arg(ap, char*);
+    str2 = pic_cstr_value(pic, sval);
+    break;
+  }
+  case 'p': {
+    static const char digits[] = "0123456789abcdef";
+#define MAXLEN (sizeof(long) * CHAR_BIT / 4)
+    unsigned long vp = (unsigned long) va_arg(ap, void*);
+    char buf[2 + MAXLEN + 1] = "0x", *p = buf + 2;
+    size_t i;
+    for (i = 0; i < MAXLEN; ++i) {
+      p[MAXLEN - i - 2] = digits[vp % 16];
+      vp /= 16;
+    }
+    p[i] = '\0';
+    str2 = pic_cstr_value(pic, buf);
+    break;
+  }
+  case '%':
+    str2 = pic_str_value(pic, &p[-1], 1);
+    break;
+  }
+  return pic_str_cat(pic, str, pic_str_cat(pic, str2, pic_vstrf_value(pic, p, ap)));
 }
 
 int
-pic_str_len(pic_state *PIC_UNUSED(pic), pic_value str)
+pic_str_len(pic_state *pic, pic_value str)
 {
-  return pic_str_ptr(pic, str)->rope->weight;
+  return str_ptr(pic, str)->rope->len;
 }
 
 pic_value
 pic_str_cat(pic_state *pic, pic_value a, pic_value b)
 {
-  return make_str(pic, merge(pic, pic_str_ptr(pic, a)->rope, pic_str_ptr(pic, b)->rope));
+  struct rope *s1 = str_ptr(pic, a)->rope, *s2 = str_ptr(pic, b)->rope;
+  struct rope_node *node;
+  struct string *s;
+
+  node = (struct rope_node *) pic_obj_alloc(pic, PIC_TYPE_ROPE_NODE);
+  node->len = s1->len + s2->len;
+  node->s1 = s1;
+  node->s2 = s2;
+
+  s = (struct string *) pic_obj_alloc(pic, PIC_TYPE_STRING);
+  s->rope = (struct rope *) node;
+  return obj_value(pic, s);
+}
+
+static pic_value
+str_sub(pic_state *pic, struct rope *rope, int i, int j)
+{
+  int lweight;
+  pic_value s1, s2;
+
+  if (i == 0 && rope->len == j) {
+    return obj_value(pic, rope);
+  }
+
+  if (obj_type(rope) == PIC_TYPE_ROPE_LEAF) {
+    return pic_str_value(pic, ((struct rope_leaf *) rope)->str + i, j - i);
+  }
+
+  lweight = ((struct rope_node *) rope)->s1->len;
+
+  if (j <= lweight) {
+    return str_sub(pic, ((struct rope_node *) rope)->s1, i, j);
+  }
+  if (lweight <= i) {
+    return str_sub(pic, ((struct rope_node *) rope)->s2, i - lweight, j - lweight);
+  }
+
+  s1 = str_sub(pic, ((struct rope_node *) rope)->s1, i, lweight);
+  s2 = str_sub(pic, ((struct rope_node *) rope)->s2, 0, j - lweight);
+  return pic_str_cat(pic, s1, s2);
 }
 
 pic_value
 pic_str_sub(pic_state *pic, pic_value str, int s, int e)
 {
-  return make_str(pic, slice(pic, pic_str_ptr(pic, str)->rope, s, e));
+  return str_sub(pic, str_ptr(pic, str)->rope, s, e);
+}
+
+int
+pic_str_hash(pic_state *pic, pic_value str)
+{
+  int len, h = 0;
+  const char *s;
+
+  s = pic_str(pic, str, &len);
+  while (len-- > 0) {
+    h = (h << 5) - h + *s++;
+  }
+  return h;
+}
+
+int
+pic_str_cmp(pic_state *pic, pic_value str1, pic_value str2)
+{
+  int len1, len2, r;
+  const char *buf1, *buf2;
+
+  buf1 = pic_str(pic, str1, &len1);
+  buf2 = pic_str(pic, str2, &len2);
+
+  if (len1 == len2) {
+    return memcmp(buf1, buf2, len1);
+  }
+  r = memcmp(buf1, buf2, (len1 < len2 ? len1 : len2));
+  if (r != 0) {
+    return r;
+  }
+  return len1 - len2;
+}
+
+static void
+str_cstr(pic_state *pic, struct rope *rope, char *buf)
+{
+  if (obj_type(rope) == PIC_TYPE_ROPE_LEAF) {
+    memcpy(buf, ((struct rope_leaf *) rope)->str, rope->len);
+  } else {
+    struct rope_node *r = (struct rope_node *) rope;
+    str_cstr(pic, r->s1, buf);
+    str_cstr(pic, r->s2, buf + r->s1->len);
+  }
 }
 
 const char *
 pic_str(pic_state *pic, pic_value str, int *len)
 {
-  struct rope *rope = pic_str_ptr(pic, str)->rope, *r;
+  struct rope *rope = str_ptr(pic, str)->rope;
+  char *buf;
+  struct rope_leaf *leaf;
 
   if (len) {
-    *len = rope->weight;
+    *len = rope->len;
   }
 
-  if (rope->isleaf && rope->u.leaf.str[rope->weight] == '\0') {
-    return rope->u.leaf.str;
+  if (obj_type(rope) == PIC_TYPE_ROPE_LEAF) {
+    return ((struct rope_leaf *) rope)->str;
   }
 
-  r = make_rope_leaf(pic, 0, rope->weight);
+  buf = pic_malloc(pic, rope->len + 1);
+  buf[rope->len] = 0;
+  str_cstr(pic, rope, buf);
 
-  flatten(pic, rope, r, r->buf);
+  leaf = (struct rope_leaf *) pic_obj_alloc(pic, PIC_TYPE_ROPE_LEAF);
+  leaf->len = rope->len;
+  leaf->str = buf;
 
-  return r->u.leaf.str;
+  /* cache the result */
+  str_ptr(pic, str)->rope = (struct rope *) leaf;
+
+  return buf;
+}
+
+const char *
+pic_cstr(pic_state *pic, pic_value str, int *len)
+{
+  const char *buf;
+  int l;
+
+  buf = pic_str(pic, str, &l);
+  if (strchr(buf, '\0') != buf + l) {
+    pic_error(pic, "casting scheme string containing null character to c string", 1, str);
+  }
+  if (len) {
+    *len = l;
+  }
+  return buf;
 }
 
 static pic_value
@@ -361,7 +327,7 @@ pic_str_string_ref(pic_state *pic)
 static pic_value
 pic_str_string_set(pic_state *pic)
 {
-  pic_value str, x, y, z;
+  pic_value str, x, y, z, w;
   char c;
   int k, len;
 
@@ -374,8 +340,9 @@ pic_str_string_set(pic_state *pic)
   x = pic_str_sub(pic, str, 0, k);
   y = pic_str_value(pic, &c, 1);
   z = pic_str_sub(pic, str, k + 1, len);
+  w = pic_str_cat(pic, x, pic_str_cat(pic, y, z));
 
-  str_update(pic, str, pic_str_cat(pic, x, pic_str_cat(pic, y, z)));
+  str_ptr(pic, str)->rope = str_ptr(pic, w)->rope;
 
   return pic_undef_value(pic);
 }
@@ -397,7 +364,7 @@ pic_str_string_set(pic_state *pic)
       if (! pic_str_p(pic, argv[i])) {                          \
         return pic_false_value(pic);                            \
       }                                                         \
-      if (! (strcmp(pic_str(pic, argv[i-1], NULL), pic_str(pic, argv[i], NULL)) op 0)) { \
+      if (! (pic_str_cmp(pic, argv[i-1], argv[i]) op 0)) {      \
         return pic_false_value(pic);                            \
       }                                                         \
     }                                                           \
@@ -435,7 +402,7 @@ pic_str_string_copy(pic_state *pic)
 static pic_value
 pic_str_string_copy_ip(pic_state *pic)
 {
-  pic_value to, from, x, y, z;
+  pic_value to, from, x, y, z, w;
   int n, at, start, end, tolen, fromlen;
 
   n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end);
@@ -455,8 +422,9 @@ pic_str_string_copy_ip(pic_state *pic)
   x = pic_str_sub(pic, to, 0, at);
   y = pic_str_sub(pic, from, start, end);
   z = pic_str_sub(pic, to, at + end - start, tolen);
+  w = pic_str_cat(pic, x, pic_str_cat(pic, y, z));
 
-  str_update(pic, to, pic_str_cat(pic, x, pic_str_cat(pic, y, z)));
+  str_ptr(pic, to)->rope = str_ptr(pic, w)->rope;
 
   return pic_undef_value(pic);
 }
@@ -464,7 +432,7 @@ pic_str_string_copy_ip(pic_state *pic)
 static pic_value
 pic_str_string_fill_ip(pic_state *pic)
 {
-  pic_value str, x, y, z;
+  pic_value str, x, y, z, w;
   char c, *buf;
   int n, start, end, len;
 
@@ -487,8 +455,9 @@ pic_str_string_fill_ip(pic_state *pic)
   x = pic_str_sub(pic, str, 0, start);
   y = pic_str_value(pic, buf, end - start);
   z = pic_str_sub(pic, str, end, len);
+  w = pic_str_cat(pic, x, pic_str_cat(pic, y, z));
 
-  str_update(pic, str, pic_str_cat(pic, x, pic_str_cat(pic, y, z)));
+  str_ptr(pic, str)->rope = str_ptr(pic, w)->rope;
 
   return pic_undef_value(pic);
 }

lib/symbol.c

@@ -2,25 +2,26 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 #include "state.h"
 
-#define to_cstr(a) (pic_str(pic, obj_value(pic, a), NULL))
-#define kh_pic_str_hash(a) (kh_str_hash_func(to_cstr(a)))
-#define kh_pic_str_cmp(a, b) (kh_str_cmp_func(to_cstr(a), to_cstr(b)))
+/* FIXME: arena is consumed every time hash/cmp is executed */
+#define kh_pic_str_hash(a) (pic_str_hash(pic, obj_value(pic, (a))))
+#define kh_pic_str_equal(a,b) (pic_str_cmp(pic, obj_value(pic, (a)), obj_value(pic, (b))) == 0)
 
-KHASH_DEFINE(oblist, struct string *, symbol *, kh_pic_str_hash, kh_pic_str_cmp)
+KHASH_DEFINE(oblist, struct string *, struct symbol *, kh_pic_str_hash, kh_pic_str_equal)
 
 pic_value
 pic_intern(pic_state *pic, pic_value str)
 {
   khash_t(oblist) *h = &pic->oblist;
-  symbol *sym;
+  struct symbol *sym;
   int it;
   int ret;
 
-  it = kh_put(oblist, h, pic_str_ptr(pic, str), &ret);
+  it = kh_put(oblist, h, str_ptr(pic, str), &ret);
   if (ret == 0) {               /* if exists */
     sym = kh_val(h, it);
     pic_protect(pic, obj_value(pic, sym));
@@ -29,39 +30,17 @@ pic_intern(pic_state *pic, pic_value str)
 
   kh_val(h, it) = NULL;         /* dummy */
 
-  sym = (symbol *)pic_obj_alloc(pic, offsetof(symbol, env), PIC_TYPE_SYMBOL);
-  sym->u.str = pic_str_ptr(pic, str);
+  sym = (struct symbol *)pic_obj_alloc(pic, PIC_TYPE_SYMBOL);
+  sym->str = str_ptr(pic, str);
   kh_val(h, it) = sym;
 
   return obj_value(pic, sym);
 }
 
 pic_value
-pic_make_identifier(pic_state *pic, pic_value base, pic_value env)
+pic_sym_name(pic_state *pic, pic_value sym)
 {
-  struct identifier *id;
-
-  id = (struct identifier *)pic_obj_alloc(pic, sizeof(struct identifier), PIC_TYPE_ID);
-  id->u.id = pic_id_ptr(pic, base);
-  id->env = pic_env_ptr(pic, env);
-
-  return obj_value(pic, id);
-}
-
-pic_value
-pic_sym_name(pic_state *PIC_UNUSED(pic), pic_value sym)
-{
-  return obj_value(pic, pic_sym_ptr(pic, sym)->u.str);
-}
-
-pic_value
-pic_id_name(pic_state *pic, pic_value id)
-{
-  while (! pic_sym_p(pic, id)) {
-    id = obj_value(pic, pic_id_ptr(pic, id)->u.id);
-  }
-
-  return pic_sym_name(pic, id);
+  return obj_value(pic, sym_ptr(pic, sym)->str);
 }
 
 static pic_value
@@ -113,80 +92,6 @@ pic_symbol_string_to_symbol(pic_state *pic)
   return pic_intern(pic, str);
 }
 
-static pic_value
-pic_symbol_identifier_p(pic_state *pic)
-{
-  pic_value obj;
-
-  pic_get_args(pic, "o", &obj);
-
-  return pic_bool_value(pic, pic_id_p(pic, obj));
-}
-
-static pic_value
-pic_symbol_make_identifier(pic_state *pic)
-{
-  pic_value id, env;
-
-  pic_get_args(pic, "oo", &id, &env);
-
-  TYPE_CHECK(pic, id, id);
-  TYPE_CHECK(pic, env, env);
-
-  return pic_make_identifier(pic, id, env);
-}
-
-static pic_value
-pic_symbol_identifier_base(pic_state *pic)
-{
-  pic_value id;
-
-  pic_get_args(pic, "o", &id);
-
-  TYPE_CHECK(pic, id, id);
-
-  if (pic_sym_p(pic, id)) {
-    pic_error(pic, "non-symbol identifier required", 1, id);
-  }
-
-  return obj_value(pic, pic_id_ptr(pic, id)->u.id);
-}
-
-static pic_value
-pic_symbol_identifier_environment(pic_state *pic)
-{
-  pic_value id;
-
-  pic_get_args(pic, "o", &id);
-
-  TYPE_CHECK(pic, id, id);
-
-  if (pic_sym_p(pic, id)) {
-    pic_error(pic, "non-symbol identifier required", 1, id);
-  }
-
-  return obj_value(pic, pic_id_ptr(pic, id)->env);
-}
-
-static pic_value
-pic_symbol_identifier_eq_p(pic_state *pic)
-{
-  int argc, i;
-  pic_value *argv;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  for (i = 0; i < argc; ++i) {
-    if (! pic_id_p(pic, argv[i])) {
-      return pic_false_value(pic);
-    }
-    if (! pic_equal_p(pic, argv[i], argv[0])) {
-      return pic_false_value(pic);
-    }
-  }
-  return pic_true_value(pic);
-}
-
 void
 pic_init_symbol(pic_state *pic)
 {
@@ -194,10 +99,4 @@ pic_init_symbol(pic_state *pic)
   pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p);
   pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
   pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);
-
-  pic_defun(pic, "make-identifier", pic_symbol_make_identifier);
-  pic_defun(pic, "identifier?", pic_symbol_identifier_p);
-  pic_defun(pic, "identifier=?", pic_symbol_identifier_eq_p);
-  pic_defun(pic, "identifier-base", pic_symbol_identifier_base);
-  pic_defun(pic, "identifier-environment", pic_symbol_identifier_environment);
 }

lib/value.c

@@ -0,0 +1,139 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "value.h"
+#include "state.h"
+
+int
+pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
+{
+  assert(pic_int_p(pic, v));
+  return value_int(&v);
+}
+
+double
+pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
+{
+  assert(pic_float_p(pic, v));
+  return value_float(&v);
+}
+
+char
+pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
+{
+  assert(pic_char_p(pic, v));
+  return value_char(&v);
+}
+
+void *
+pic_ptr(pic_state *PIC_UNUSED(pic), pic_value v)
+{
+  assert(pic_obj_p(pic, v));
+  return value_ptr(&v);
+}
+
+int
+pic_type(pic_state *PIC_UNUSED(pic), pic_value v)
+{
+  return value_type(&v);
+}
+
+pic_value
+pic_int_value(pic_state *PIC_UNUSED(pic), int i)
+{
+  pic_value v;
+  make_int_value(&v, i);
+  return v;
+}
+
+pic_value
+pic_float_value(pic_state *PIC_UNUSED(pic), double f)
+{
+  pic_value v;
+  make_float_value(&v, f);
+  return v;
+}
+
+pic_value
+pic_char_value(pic_state *PIC_UNUSED(pic), char c)
+{
+  pic_value v;
+  make_char_value(&v, c);
+  return v;
+}
+
+pic_value
+pic_obj_value(pic_state *PIC_UNUSED(pic), void *p, int type)
+{
+  pic_value v;
+  make_obj_value(&v, p, type);
+  return v;
+}
+
+#define DEFVAL(name, type)                      \
+  pic_value name(pic_state *PIC_UNUSED(pic)) {              \
+    pic_value v;                                \
+    make_value(&v, type);                       \
+    return v;                                   \
+  }
+
+DEFVAL(pic_nil_value, PIC_TYPE_NIL)
+DEFVAL(pic_eof_object, PIC_TYPE_EOF)
+DEFVAL(pic_true_value, PIC_TYPE_TRUE)
+DEFVAL(pic_false_value, PIC_TYPE_FALSE)
+DEFVAL(pic_undef_value, PIC_TYPE_UNDEF)
+DEFVAL(pic_invalid_value, PIC_TYPE_INVALID)
+
+pic_value
+pic_bool_value(pic_state *PIC_UNUSED(pic), bool b)
+{
+  pic_value v;
+  make_value(&v, (b ? PIC_TYPE_TRUE : PIC_TYPE_FALSE));
+  return v;
+}
+
+#define DEFPRED(name, type)                             \
+  bool name(pic_state *PIC_UNUSED(pic), pic_value v) {  \
+    return pic_type(pic, v) == type;                    \
+  }
+
+DEFPRED(pic_invalid_p, PIC_TYPE_INVALID)
+DEFPRED(pic_float_p, PIC_TYPE_FLOAT)
+DEFPRED(pic_int_p, PIC_TYPE_INT)
+DEFPRED(pic_char_p, PIC_TYPE_CHAR)
+DEFPRED(pic_eof_p, PIC_TYPE_EOF)
+DEFPRED(pic_undef_p, PIC_TYPE_UNDEF)
+DEFPRED(pic_true_p, PIC_TYPE_TRUE)
+DEFPRED(pic_nil_p, PIC_TYPE_NIL)
+DEFPRED(pic_false_p, PIC_TYPE_FALSE)
+DEFPRED(pic_str_p, PIC_TYPE_STRING)
+DEFPRED(pic_vec_p, PIC_TYPE_VECTOR)
+DEFPRED(pic_blob_p, PIC_TYPE_BLOB)
+DEFPRED(pic_dict_p, PIC_TYPE_DICT)
+DEFPRED(pic_attr_p, PIC_TYPE_ATTR)
+DEFPRED(pic_rec_p, PIC_TYPE_RECORD)
+DEFPRED(pic_sym_p, PIC_TYPE_SYMBOL)
+DEFPRED(pic_pair_p, PIC_TYPE_PAIR)
+DEFPRED(pic_proc_func_p, PIC_TYPE_PROC_FUNC)
+DEFPRED(pic_proc_irep_p, PIC_TYPE_PROC_IREP)
+DEFPRED(pic_irep_p, PIC_TYPE_IREP)
+
+bool
+pic_bool_p(pic_state *pic, pic_value v)
+{
+  return pic_true_p(pic, v) || pic_false_p(pic, v);
+}
+
+bool
+pic_proc_p(pic_state *pic, pic_value v)
+{
+  return pic_proc_func_p(pic, v) || pic_proc_irep_p(pic, v);
+}
+
+bool
+pic_obj_p(pic_state *PIC_UNUSED(pic), pic_value v)
+{
+  return value_obj_p(&v);
+}

lib/value.h

@@ -0,0 +1,272 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#ifndef PICRIN_VALUE_H
+#define PICRIN_VALUE_H
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+enum {
+  PIC_TYPE_INVALID   = 1,
+  PIC_TYPE_FLOAT     = 2,
+  PIC_TYPE_INT       = 3,
+  PIC_TYPE_CHAR      = 4,
+  PIC_TYPE_EOF       = 5,
+  PIC_TYPE_UNDEF     = 6,
+  PIC_TYPE_TRUE      = 8,
+  PIC_TYPE_NIL       = 7,
+  PIC_TYPE_FALSE     = 9,
+  PIC_IVAL_END       = 10,
+/* -------------------- */
+  PIC_TYPE_SYMBOL    = 16,
+  PIC_TYPE_STRING    = 17,
+  PIC_TYPE_BLOB      = 18,
+  PIC_TYPE_DATA      = 19,
+  PIC_TYPE_PAIR      = 20,
+  PIC_TYPE_VECTOR    = 21,
+  PIC_TYPE_DICT      = 22,
+  PIC_TYPE_RECORD    = 23,
+  PIC_TYPE_ATTR      = 24,
+  PIC_TYPE_IREP      = 25,
+  PIC_TYPE_FRAME     = 26,
+  PIC_TYPE_PROC_FUNC = 27,
+  PIC_TYPE_PROC_IREP = 28,
+  PIC_TYPE_ROPE_LEAF = 29,
+  PIC_TYPE_ROPE_NODE = 30,
+  PIC_TYPE_MAX       = 63
+};
+
+#if !PIC_NAN_BOXING
+
+PIC_STATIC_INLINE void
+make_value(struct value *v, int type)
+{
+  static const struct value zero = { {0}, 0 };
+  *v = zero;
+  v->type = type;
+}
+
+PIC_STATIC_INLINE void
+make_int_value(struct value *v, int i)
+{
+  make_value(v, PIC_TYPE_INT);
+  v->u.i = i;
+}
+
+PIC_STATIC_INLINE void
+make_float_value(struct value *v, double f)
+{
+  make_value(v, PIC_TYPE_FLOAT);
+  v->u.f = f;
+}
+
+PIC_STATIC_INLINE void
+make_char_value(struct value *v, char c)
+{
+  make_value(v, PIC_TYPE_CHAR);
+  v->u.c = c;
+}
+
+PIC_STATIC_INLINE void
+make_obj_value(struct value *v, void *p, int type)
+{
+  make_value(v, type);
+  v->u.p = p;
+}
+
+PIC_STATIC_INLINE int
+value_type(struct value *v)
+{
+  return (int)(v->type);
+}
+
+PIC_STATIC_INLINE int
+value_int(struct value *v)
+{
+  return v->u.i;
+}
+
+PIC_STATIC_INLINE double
+value_float(struct value *v)
+{
+  return v->u.f;
+}
+
+PIC_STATIC_INLINE char
+value_char(struct value *v)
+{
+  return v->u.c;
+}
+
+PIC_STATIC_INLINE void *
+value_ptr(struct value *v)
+{
+  return v->u.p;
+}
+
+PIC_STATIC_INLINE bool
+value_eq_p(struct value *x, struct value *y)
+{
+  return memcmp(x, y, sizeof(struct value)) == 0;
+}
+
+PIC_STATIC_INLINE bool
+value_eqv_p(struct value *x, struct value *y)
+{
+  return memcmp(x, y, sizeof(struct value)) == 0;
+}
+
+#else  /* NAN_BOXING */
+
+/**
+ * value representation by nan-boxing:
+ *   float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF
+ *   ptr   : 111111111111TTTT TTPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP
+ *   int   : 111111111111TTTT TT00000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII
+ *   char  : 111111111111TTTT TT00000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
+ */
+
+PIC_STATIC_INLINE void
+make_value(struct value *v, int type)
+{
+  v->v = 0xfff0000000000000ul | ((uint64_t)(type) << 46);
+}
+
+PIC_STATIC_INLINE void
+make_int_value(struct value *v, int i)
+{
+  make_value(v, PIC_TYPE_INT);
+  v->v |= (unsigned)i;
+}
+
+PIC_STATIC_INLINE void
+make_float_value(struct value *v, double f)
+{
+  if (f != f) {
+    v->v = 0x7ff8000000000000ul;
+  } else {
+    union { double f; uint64_t i; } u;
+    u.f = f;
+    v->v = u.i;
+  }
+}
+
+PIC_STATIC_INLINE void
+make_char_value(struct value *v, char c)
+{
+  make_value(v, PIC_TYPE_CHAR);
+  v->v |= (unsigned char)c;
+}
+
+PIC_STATIC_INLINE void
+make_obj_value(struct value *v, void *ptr, int type)
+{
+  make_value(v, type);
+  v->v |= 0x3ffffffffffful & ((uint64_t)ptr >> 2);
+}
+
+PIC_STATIC_INLINE int
+value_type(struct value *v)
+{
+  return 0xfff0000000000000ul >= v->v ? PIC_TYPE_FLOAT : ((v->v >> 46) & 0x3f);
+}
+
+PIC_STATIC_INLINE int
+value_int(struct value *v)
+{
+  union { int i; unsigned u; } u;
+  u.u = v->v & 0xfffffffful;
+  return u.i;
+}
+
+PIC_STATIC_INLINE double
+value_float(struct value *v)
+{
+  union { double f; uint64_t i; } u;
+  u.i = v->v;
+  return u.f;
+}
+
+PIC_STATIC_INLINE char
+value_char(struct value *v)
+{
+  return v->v & 0xfffffffful;
+}
+
+PIC_STATIC_INLINE void *
+value_ptr(struct value *v)
+{
+  return (void *)((0x3ffffffffffful & v->v) << 2);
+}
+
+PIC_STATIC_INLINE bool
+value_eq_p(struct value *x, struct value *y)
+{
+  return x->v == y->v;
+}
+
+PIC_STATIC_INLINE bool
+value_eqv_p(struct value *x, struct value *y)
+{
+  return x->v == y->v;
+}
+
+#endif  /* NAN_BOXING end */
+
+
+#define DEFPRED(name, type)                     \
+  PIC_STATIC_INLINE bool                        \
+  value_##name##_p(struct value *v) {           \
+    return value_type(v) == type;               \
+  }
+
+DEFPRED(invalid, PIC_TYPE_INVALID)
+DEFPRED(float, PIC_TYPE_FLOAT)
+DEFPRED(int, PIC_TYPE_INT)
+DEFPRED(char, PIC_TYPE_CHAR)
+DEFPRED(eof, PIC_TYPE_EOF)
+DEFPRED(undef, PIC_TYPE_UNDEF)
+DEFPRED(true, PIC_TYPE_TRUE)
+DEFPRED(nil, PIC_TYPE_NIL)
+DEFPRED(false, PIC_TYPE_FALSE)
+DEFPRED(str, PIC_TYPE_STRING)
+DEFPRED(vec, PIC_TYPE_VECTOR)
+DEFPRED(blob, PIC_TYPE_BLOB)
+DEFPRED(dict, PIC_TYPE_DICT)
+DEFPRED(attr, PIC_TYPE_ATTR)
+DEFPRED(rec, PIC_TYPE_RECORD)
+DEFPRED(sym, PIC_TYPE_SYMBOL)
+DEFPRED(pair, PIC_TYPE_PAIR)
+DEFPRED(proc_func, PIC_TYPE_PROC_FUNC)
+DEFPRED(proc_irep, PIC_TYPE_PROC_IREP)
+DEFPRED(irep, PIC_TYPE_IREP)
+DEFPRED(data, PIC_TYPE_DATA)
+
+#undef DEFPRED
+
+PIC_STATIC_INLINE bool
+value_obj_p(struct value *v)
+{
+  return value_type(v) > PIC_IVAL_END;
+}
+
+void *pic_ptr(pic_state *, pic_value);
+int pic_type(pic_state *, pic_value);
+pic_value pic_invalid_value(pic_state *);
+pic_value pic_obj_value(pic_state *, void *, int);
+bool pic_invalid_p(pic_state *, pic_value);
+bool pic_attr_p(pic_state *, pic_value);
+bool pic_rec_p(pic_state *, pic_value);
+bool pic_irep_p(pic_state *, pic_value);
+bool pic_proc_func_p(pic_state *, pic_value);
+bool pic_proc_irep_p(pic_state *, pic_value);
+bool pic_obj_p(pic_state *, pic_value);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

lib/var.c

@@ -2,7 +2,8 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 #include "state.h"
 
@@ -19,9 +20,9 @@ var_call(pic_state *pic)
   if (n == 0) {
     pic_value env, it;
 
-    pic_for_each(env, pic->dyn_env, it) {
-      if (pic_weak_has(pic, env, self)) {
-        return pic_weak_ref(pic, env, self);
+    pic_for_each(env, pic_ref(pic, "__picrin_dynenv__"), it) {
+      if (pic_attr_has(pic, env, self)) {
+        return pic_attr_ref(pic, env, self);
       }
     }
     PIC_UNREACHABLE();          /* logic flaw */
@@ -32,7 +33,7 @@ var_call(pic_state *pic)
     if (! pic_false_p(pic, conv)) {
       val = pic_call(pic, conv, 1, val);
     }
-    pic_weak_set(pic, pic_car(pic, pic->dyn_env), self, val);
+    pic_attr_set(pic, pic_car(pic, pic_ref(pic, "__picrin_dynenv__")), self, val);
     return pic_undef_value(pic);
   }
 }
@@ -40,7 +41,7 @@ var_call(pic_state *pic)
 pic_value
 pic_make_var(pic_state *pic, pic_value init, pic_value conv)
 {
-  pic_value var, env = pic->dyn_env;
+  pic_value var, env = pic_ref(pic, "__picrin_dynenv__");
 
   var = pic_lambda(pic, var_call, 1, conv);
   while (1) {
@@ -48,7 +49,7 @@ pic_make_var(pic_state *pic, pic_value init, pic_value conv)
       if (! pic_false_p(pic, conv)) {
         init = pic_call(pic, conv, 1, init);
       }
-      pic_weak_set(pic, pic_car(pic, env), var, init);
+      pic_attr_set(pic, pic_car(pic, env), var, init);
       break;
     }
     env = pic_cdr(pic, env);
@@ -67,25 +68,24 @@ pic_var_make_parameter(pic_state *pic)
 }
 
 static pic_value
-pic_var_with_dynamic_environment(pic_state *pic)
+pic_var_current_dynamic_environment(pic_state *pic)
 {
-  pic_value alist, thunk, env, it, elt, val;
+  pic_value dyn_env;
+  int n;
 
-  pic_get_args(pic, "ol", &alist, &thunk);
+  n = pic_get_args(pic, "|o", &dyn_env);
 
-  env = pic_make_weak(pic);
-  pic_for_each(elt, alist, it) {
-    pic_weak_set(pic, env, pic_car(pic, elt), pic_cdr(pic, elt));
+  if (n == 0) {
+    return pic_ref(pic, "__picrin_dynenv__");
+  } else {
+    pic_set(pic, "__picrin_dynenv__", dyn_env);
+    return pic_undef_value(pic);
   }
-  pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
-  val = pic_call(pic, thunk, 0);
-  pic->dyn_env = pic_cdr(pic, pic->dyn_env);
-  return val;
 }
 
 void
 pic_init_var(pic_state *pic)
 {
   pic_defun(pic, "make-parameter", pic_var_make_parameter);
-  pic_defun(pic, "with-dynamic-environment", pic_var_with_dynamic_environment);
+  pic_defun(pic, "current-dynamic-environment", pic_var_current_dynamic_environment);
 }

lib/vector.c

@@ -2,7 +2,8 @@
  * See Copyright Notice in picrin.h
  */
 
-#include "picrin.h"
+#include <picrin.h>
+#include "value.h"
 #include "object.h"
 
 pic_value
@@ -11,7 +12,7 @@ pic_make_vec(pic_state *pic, int len, pic_value *argv)
   struct vector *vec;
   int i;
 
-  vec = (struct vector *)pic_obj_alloc(pic, sizeof(struct vector), PIC_TYPE_VECTOR);
+  vec = (struct vector *)pic_obj_alloc(pic, PIC_TYPE_VECTOR);
   vec->len = len;
   vec->data = (pic_value *)pic_malloc(pic, sizeof(pic_value) * len);
   if (argv == NULL) {
@@ -25,21 +26,21 @@ pic_make_vec(pic_state *pic, int len, pic_value *argv)
 }
 
 pic_value
-pic_vec_ref(pic_state *PIC_UNUSED(pic), pic_value vec, int k)
+pic_vec_ref(pic_state *pic, pic_value vec, int k)
 {
-  return pic_vec_ptr(pic, vec)->data[k];
+  return vec_ptr(pic, vec)->data[k];
 }
 
 void
-pic_vec_set(pic_state *PIC_UNUSED(pic), pic_value vec, int k, pic_value val)
+pic_vec_set(pic_state *pic, pic_value vec, int k, pic_value val)
 {
-  pic_vec_ptr(pic, vec)->data[k] = val;
+  vec_ptr(pic, vec)->data[k] = val;
 }
 
 int
-pic_vec_len(pic_state *PIC_UNUSED(pic), pic_value vec)
+pic_vec_len(pic_state *pic, pic_value vec)
 {
-  return pic_vec_ptr(pic, vec)->len;
+  return vec_ptr(pic, vec)->len;
 }
 
 static pic_value
@@ -142,7 +143,7 @@ pic_vec_vector_copy_i(pic_state *pic)
 
   VALID_ATRANGE(pic, tolen, at, fromlen, start, end);
 
-  memmove(pic_vec_ptr(pic, to)->data + at, pic_vec_ptr(pic, from)->data + start, sizeof(pic_value) * (end - start));
+  memmove(vec_ptr(pic, to)->data + at, vec_ptr(pic, from)->data + start, sizeof(pic_value) * (end - start));
 
   return pic_undef_value(pic);
 }
@@ -166,7 +167,7 @@ pic_vec_vector_copy(pic_state *pic)
 
   VALID_RANGE(pic, fromlen, start, end);
 
-  return pic_make_vec(pic, end - start, pic_vec_ptr(pic, from)->data + start);
+  return pic_make_vec(pic, end - start, vec_ptr(pic, from)->data + start);
 }
 
 static pic_value
@@ -188,7 +189,7 @@ pic_vec_vector_append(pic_state *pic)
   len = 0;
   for (i = 0; i < argc; ++i) {
     int l = pic_vec_len(pic, argv[i]);
-    memcpy(pic_vec_ptr(pic, vec)->data + len, pic_vec_ptr(pic, argv[i])->data, sizeof(pic_value) * l);
+    memcpy(vec_ptr(pic, vec)->data + len, vec_ptr(pic, argv[i])->data, sizeof(pic_value) * l);
     len += l;
   }
 
@@ -368,11 +369,11 @@ pic_vec_string_to_vector(pic_state *pic)
 {
   pic_value str, vec;
   int n, start, end, len, i;
-  const char *cstr;
+  const char *buf;
 
   n = pic_get_args(pic, "s|ii", &str, &start, &end);
 
-  cstr = pic_str(pic, str, &len);
+  buf = pic_str(pic, str, &len);
 
   switch (n) {
   case 1:
@@ -386,7 +387,7 @@ pic_vec_string_to_vector(pic_state *pic)
   vec = pic_make_vec(pic, end - start, NULL);
 
   for (i = 0; i < end - start; ++i) {
-    pic_vec_set(pic, vec, i, pic_char_value(pic, cstr[i + start]));
+    pic_vec_set(pic, vec, i, pic_char_value(pic, buf[i + start]));
   }
   return vec;
 }

lib/vm.h

@@ -1,59 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_VM_H
-#define PICRIN_VM_H
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-enum {
-  OP_NOP       = 0,
-  OP_POP       = 1,
-  OP_PUSHUNDEF = 2,
-  OP_PUSHNIL   = 3,
-  OP_PUSHTRUE  = 4,
-  OP_PUSHFALSE = 5,
-  OP_PUSHINT   = 6,
-  OP_PUSHFLOAT = 7,
-  OP_PUSHCHAR  = 8,
-  OP_PUSHEOF   = 9,
-  OP_PUSHCONST = 10,
-  OP_GREF      = 11,
-  OP_GSET      = 12,
-  OP_LREF      = 13,
-  OP_LSET      = 14,
-  OP_CREF      = 15,
-  OP_CSET      = 16,
-  OP_JMP       = 17,
-  OP_JMPIF     = 18,
-  OP_NOT       = 19,
-  OP_CALL      = 20,
-  OP_TAILCALL  = 21,
-  OP_RET       = 22,
-  OP_LAMBDA    = 23,
-  OP_CONS      = 24,
-  OP_CAR       = 25,
-  OP_CDR       = 26,
-  OP_NILP      = 27,
-  OP_SYMBOLP   = 28,
-  OP_PAIRP     = 29,
-  OP_ADD       = 30,
-  OP_SUB       = 31,
-  OP_MUL       = 32,
-  OP_DIV       = 33,
-  OP_EQ        = 34,
-  OP_LT        = 35,
-  OP_LE        = 36,
-  OP_GT        = 37,
-  OP_GE        = 38,
-  OP_STOP      = 39
-};
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

lib/weak.c

@@ -1,111 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "object.h"
-
-KHASH_DEFINE(weak, struct object *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
-
-pic_value
-pic_make_weak(pic_state *pic)
-{
-  struct weak *weak;
-
-  weak = (struct weak *)pic_obj_alloc(pic, sizeof(struct weak), PIC_TYPE_WEAK);
-  weak->prev = NULL;
-  kh_init(weak, &weak->hash);
-
-  return obj_value(pic, weak);
-}
-
-pic_value
-pic_weak_ref(pic_state *pic, pic_value weak, pic_value key)
-{
-  khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash;
-  int it;
-
-  it = kh_get(weak, h, obj_ptr(pic, key));
-  if (it == kh_end(h)) {
-    pic_error(pic, "element not found for given key", 1, key);
-  }
-  return kh_val(h, it);
-}
-
-void
-pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val)
-{
-  khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash;
-  int ret;
-  int it;
-
-  it = kh_put(weak, h, obj_ptr(pic, key), &ret);
-  kh_val(h, it) = val;
-}
-
-bool
-pic_weak_has(pic_state *pic, pic_value weak, pic_value key)
-{
-  khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash;
-
-  return kh_get(weak, h, obj_ptr(pic, key)) != kh_end(h);
-}
-
-void
-pic_weak_del(pic_state *pic, pic_value weak, pic_value key)
-{
-  khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash;
-  int it;
-
-  it = kh_get(weak, h, obj_ptr(pic, key));
-  if (it == kh_end(h)) {
-    pic_error(pic, "element not found for given key", 1, key);
-  }
-  kh_del(weak, h, it);
-}
-
-
-static pic_value
-weak_call(pic_state *pic)
-{
-  pic_value key, val, weak;
-  int n;
-
-  n = pic_get_args(pic, "o|o", &key, &val);
-
-  if (! obj_p(pic, key)) {
-    pic_error(pic, "attempted to set a non-object key", 1, key);
-  }
-
-  weak = pic_closure_ref(pic, 0);
-
-  if (n == 1) {
-    if (! pic_weak_has(pic, weak, key)) {
-      return pic_false_value(pic);
-    }
-    return pic_cons(pic, key, pic_weak_ref(pic, weak, key));
-  } else {
-    if (pic_false_p(pic, val)) {
-      if (pic_weak_has(pic, weak, key)) {
-        pic_weak_del(pic, weak, key);
-      }
-    } else {
-      pic_weak_set(pic, weak, key, val);
-    }
-    return pic_undef_value(pic);
-  }
-}
-
-static pic_value
-pic_weak_make_ephemeron_table(pic_state *pic)
-{
-  pic_get_args(pic, "");
-
-  return pic_lambda(pic, weak_call, 1, pic_make_weak(pic));
-}
-
-void
-pic_init_weak(pic_state *pic)
-{
-  pic_defun(pic, "make-ephemeron-table", pic_weak_make_ephemeron_table);
-}

piclib/boot.scm

@@ -1,529 +0,0 @@
-(core#define-macro call-with-current-environment
-  (core#lambda (form env)
-    (list (cadr form) env)))
-
-(core#define here
-  (call-with-current-environment
-   (core#lambda (env)
-     env)))
-
-(core#define the                     ; synonym for #'var
-  (core#lambda (var)
-    (make-identifier var here)))
-
-
-(core#define the-builtin-define (the (core#quote core#define)))
-(core#define the-builtin-lambda (the (core#quote core#lambda)))
-(core#define the-builtin-begin (the (core#quote core#begin)))
-(core#define the-builtin-quote (the (core#quote core#quote)))
-(core#define the-builtin-set! (the (core#quote core#set!)))
-(core#define the-builtin-if (the (core#quote core#if)))
-(core#define the-builtin-define-macro (the (core#quote core#define-macro)))
-
-(core#define the-define (the (core#quote define)))
-(core#define the-lambda (the (core#quote lambda)))
-(core#define the-begin (the (core#quote begin)))
-(core#define the-quote (the (core#quote quote)))
-(core#define the-set! (the (core#quote set!)))
-(core#define the-if (the (core#quote if)))
-(core#define the-define-macro (the (core#quote define-macro)))
-
-(core#define-macro quote
-  (core#lambda (form env)
-    (core#if (= (length form) 2)
-      (list the-builtin-quote (cadr form))
-      (error "illegal quote form" form))))
-
-(core#define-macro if
-  (core#lambda (form env)
-    ((core#lambda (len)
-       (core#if (= len 4)
-           (cons the-builtin-if (cdr form))
-           (core#if (= len 3)
-               (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined)
-               (error "illegal if form" form))))
-     (length form))))
-
-(core#define-macro begin
-  (core#lambda (form env)
-    ((core#lambda (len)
-       (if (= len 1)
-           #undefined
-           (if (= len 2)
-               (cadr form)
-               (if (= len 3)
-                   (cons the-builtin-begin (cdr form))
-                   (list the-builtin-begin
-                         (cadr form)
-                         (cons the-begin (cddr form)))))))
-     (length form))))
-
-(core#define-macro set!
-  (core#lambda (form env)
-    (if (= (length form) 3)
-        (if (identifier? (cadr form))
-            (cons the-builtin-set! (cdr form))
-            (error "illegal set! form" form))
-        (error "illegal set! form" form))))
-
-(core#define check-formal
-  (core#lambda (formal)
-    (if (null? formal)
-        #t
-        (if (identifier? formal)
-            #t
-            (if (pair? formal)
-                (if (identifier? (car formal))
-                    (check-formal (cdr formal))
-                    #f)
-                #f)))))
-
-(core#define-macro lambda
-  (core#lambda (form env)
-    (if (= (length form) 1)
-        (error "illegal lambda form" form)
-        (if (check-formal (cadr form))
-            (list the-builtin-lambda (cadr form) (cons the-begin (cddr form)))
-            (error "illegal lambda form" form)))))
-
-(core#define-macro define
-  (lambda (form env)
-    ((lambda (len)
-       (if (= len 1)
-           (error "illegal define form" form)
-           (if (identifier? (cadr form))
-               (if (= len 3)
-                   (cons the-builtin-define (cdr form))
-                   (error "illegal define form" form))
-               (if (pair? (cadr form))
-                   (list the-define
-                         (car (cadr form))
-                         (cons the-lambda (cons (cdr (cadr form)) (cddr form))))
-                   (error "define: binding to non-varaible object" form)))))
-     (length form))))
-
-(core#define-macro define-macro
-  (lambda (form env)
-    (if (= (length form) 3)
-        (if (identifier? (cadr form))
-            (cons the-builtin-define-macro (cdr form))
-            (error "define-macro: binding to non-variable object" form))
-        (error "illegal define-macro form" form))))
-
-
-(define-macro syntax-error
-  (lambda (form _)
-    (apply error (cdr form))))
-
-(define-macro define-auxiliary-syntax
-  (lambda (form _)
-    (define message
-      (string-append
-       "invalid use of auxiliary syntax: '" (symbol->string (cadr form)) "'"))
-    (list
-     the-define-macro
-     (cadr form)
-     (list the-lambda '_
-           (list (the 'error) message)))))
-
-(define-auxiliary-syntax else)
-(define-auxiliary-syntax =>)
-(define-auxiliary-syntax unquote)
-(define-auxiliary-syntax unquote-splicing)
-(define-auxiliary-syntax syntax-unquote)
-(define-auxiliary-syntax syntax-unquote-splicing)
-
-(define-macro let
-  (lambda (form env)
-    (if (identifier? (cadr form))
-        (list
-         (list the-lambda '()
-               (list the-define (cadr form)
-                     (cons the-lambda
-                           (cons (map car (car (cddr form)))
-                                 (cdr (cddr form)))))
-               (cons (cadr form) (map cadr (car (cddr form))))))
-        (cons
-         (cons
-          the-lambda
-          (cons (map car (cadr form))
-                (cddr form)))
-         (map cadr (cadr form))))))
-
-(define-macro and
-  (lambda (form env)
-    (if (null? (cdr form))
-        #t
-        (if (null? (cddr form))
-            (cadr form)
-            (list the-if
-                  (cadr form)
-                  (cons (the 'and) (cddr form))
-                  #f)))))
-
-(define-macro or
-  (lambda (form env)
-    (if (null? (cdr form))
-        #f
-        (let ((tmp (make-identifier 'it env)))
-          (list (the 'let)
-                (list (list tmp (cadr form)))
-                (list the-if
-                      tmp
-                      tmp
-                      (cons (the 'or) (cddr form))))))))
-
-(define-macro cond
-  (lambda (form env)
-    (let ((clauses (cdr form)))
-      (if (null? clauses)
-          #undefined
-          (let ((clause (car clauses)))
-            (if (and (identifier? (car clause))
-                     (identifier=? (the 'else) (make-identifier (car clause) env)))
-                (cons the-begin (cdr clause))
-                (if (null? (cdr clause))
-                    (let ((tmp (make-identifier 'tmp here)))
-                      (list (the 'let) (list (list tmp (car clause)))
-                            (list the-if tmp tmp (cons (the 'cond) (cdr clauses)))))
-                    (if (and (identifier? (cadr clause))
-                             (identifier=? (the '=>) (make-identifier (cadr clause) env)))
-                        (let ((tmp (make-identifier 'tmp here)))
-                          (list (the 'let) (list (list tmp (car clause)))
-                                (list the-if tmp
-                                      (list (car (cddr clause)) tmp)
-                                      (cons (the 'cond) (cdr clauses)))))
-                        (list the-if (car clause)
-                              (cons the-begin (cdr clause))
-                              (cons (the 'cond) (cdr clauses)))))))))))
-
-(define-macro quasiquote
-  (lambda (form env)
-
-    (define (quasiquote? form)
-      (and (pair? form)
-           (identifier? (car form))
-           (identifier=? (the 'quasiquote) (make-identifier (car form) env))))
-
-    (define (unquote? form)
-      (and (pair? form)
-           (identifier? (car form))
-           (identifier=? (the 'unquote) (make-identifier (car form) env))))
-
-    (define (unquote-splicing? form)
-      (and (pair? form)
-           (pair? (car form))
-           (identifier? (caar form))
-           (identifier=? (the 'unquote-splicing) (make-identifier (caar form) env))))
-
-    (define (qq depth expr)
-      (cond
-       ;; unquote
-       ((unquote? expr)
-        (if (= depth 1)
-            (car (cdr expr))
-            (list (the 'list)
-                  (list (the 'quote) (the 'unquote))
-                  (qq (- depth 1) (car (cdr expr))))))
-       ;; unquote-splicing
-       ((unquote-splicing? expr)
-        (if (= depth 1)
-            (list (the 'append)
-                  (car (cdr (car expr)))
-                  (qq depth (cdr expr)))
-            (list (the 'cons)
-                  (list (the 'list)
-                        (list (the 'quote) (the 'unquote-splicing))
-                        (qq (- depth 1) (car (cdr (car expr)))))
-                  (qq depth (cdr expr)))))
-       ;; quasiquote
-       ((quasiquote? expr)
-        (list (the 'list)
-              (list (the 'quote) (the 'quasiquote))
-              (qq (+ depth 1) (car (cdr expr)))))
-       ;; list
-       ((pair? expr)
-        (list (the 'cons)
-              (qq depth (car expr))
-              (qq depth (cdr expr))))
-       ;; vector
-       ((vector? expr)
-        (list (the 'list->vector) (qq depth (vector->list expr))))
-       ;; simple datum
-       (else
-        (list (the 'quote) expr))))
-
-    (let ((x (cadr form)))
-      (qq 1 x))))
-
-(define-macro let*
-  (lambda (form env)
-    (let ((bindings (car (cdr form)))
-          (body     (cdr (cdr form))))
-      (if (null? bindings)
-          `(,(the 'let) () ,@body)
-          `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))
-            (,(the 'let*) (,@(cdr bindings))
-             ,@body))))))
-
-(define-macro letrec
-  (lambda (form env)
-    `(,(the 'letrec*) ,@(cdr form))))
-
-(define-macro letrec*
-  (lambda (form env)
-    (let ((bindings (car (cdr form)))
-          (body     (cdr (cdr form))))
-      (let ((variables (map (lambda (v) `(,v #f)) (map car bindings)))
-            (initials  (map (lambda (v) `(,(the 'set!) ,@v)) bindings)))
-        `(,(the 'let) (,@variables)
-          ,@initials
-          ,@body)))))
-
-(define-macro let-values
-  (lambda (form env)
-    `(,(the 'let*-values) ,@(cdr form))))
-
-(define-macro let*-values
-  (lambda (form env)
-    (let ((formal (car (cdr form)))
-          (body   (cdr (cdr form))))
-      (if (null? formal)
-          `(,(the 'let) () ,@body)
-          `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal)))
-            (,(the 'lambda) (,@(car (car formal)))
-             (,(the 'let*-values) (,@(cdr formal))
-              ,@body)))))))
-
-(define-macro define-values
-  (lambda (form env)
-    (let ((formal (car (cdr form)))
-          (body   (cdr (cdr form))))
-      (let ((arguments (make-identifier 'arguments here)))
-        `(,the-begin
-          ,@(let loop ((formal formal))
-              (if (pair? formal)
-                  `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal)))
-                  (if (identifier? formal)
-                      `((,the-define ,formal #undefined))
-                      '())))
-          (,(the 'call-with-values) (,the-lambda () ,@body)
-           (,the-lambda
-            ,arguments
-            ,@(let loop ((formal formal) (args arguments))
-                (if (pair? formal)
-                    `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))
-                    (if (identifier? formal)
-                        `((,the-set! ,formal ,args))
-                        '()))))))))))
-
-(define-macro do
-  (lambda (form env)
-    (let ((bindings (car (cdr form)))
-          (test     (car (car (cdr (cdr form)))))
-          (cleanup  (cdr (car (cdr (cdr form)))))
-          (body     (cdr (cdr (cdr form)))))
-      (let ((loop (make-identifier 'loop here)))
-        `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)
-          (,the-if ,test
-                   (,the-begin
-                    ,@cleanup)
-                   (,the-begin
-                    ,@body
-                    (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings)))))))))
-
-(define-macro when
-  (lambda (form env)
-    (let ((test (car (cdr form)))
-          (body (cdr (cdr form))))
-      `(,the-if ,test
-                (,the-begin ,@body)
-                #undefined))))
-
-(define-macro unless
-  (lambda (form env)
-    (let ((test (car (cdr form)))
-          (body (cdr (cdr form))))
-      `(,the-if ,test
-                #undefined
-                (,the-begin ,@body)))))
-
-(define-macro case
-  (lambda (form env)
-    (let ((key     (car (cdr form)))
-          (clauses (cdr (cdr form))))
-      (let ((the-key (make-identifier 'key here)))
-        `(,(the 'let) ((,the-key ,key))
-          ,(let loop ((clauses clauses))
-             (if (null? clauses)
-                 #undefined
-                 (let ((clause (car clauses)))
-                   `(,the-if ,(if (and (identifier? (car clause))
-                                       (identifier=? (the 'else) (make-identifier (car clause) env)))
-                                  #t
-                                  `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))
-                             ,(if (and (identifier? (cadr clause))
-                                       (identifier=? (the '=>) (make-identifier (cadr clause) env)))
-                                  `(,(car (cdr (cdr clause))) ,the-key)
-                                  `(,the-begin ,@(cdr clause)))
-                             ,(loop (cdr clauses)))))))))))
-
-(define-macro parameterize
-  (lambda (form env)
-    (let ((formal (car (cdr form)))
-          (body   (cdr (cdr form))))
-      `(,(the 'with-dynamic-environment)
-        (,(the 'list) ,@(map (lambda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal))
-        (,the-lambda () ,@body)))))
-
-(define-macro syntax-quote
-  (lambda (form env)
-    (let ((renames '()))
-      (letrec
-          ((rename (lambda (var)
-                     (let ((x (assq var renames)))
-                       (if x
-                           (cadr x)
-                           (begin
-                             (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
-                             (rename var))))))
-           (walk (lambda (f form)
-                   (cond
-                    ((identifier? form)
-                     (f form))
-                    ((pair? form)
-                     `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))
-                    ((vector? form)
-                     `(,(the 'list->vector) (walk f (vector->list form))))
-                    (else
-                     `(,(the 'quote) ,form))))))
-        (let ((form (walk rename (cadr form))))
-          `(,(the 'let)
-            ,(map cdr renames)
-            ,form))))))
-
-(define-macro syntax-quasiquote
-  (lambda (form env)
-    (let ((renames '()))
-      (letrec
-          ((rename (lambda (var)
-                     (let ((x (assq var renames)))
-                       (if x
-                           (cadr x)
-                           (begin
-                             (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
-                             (rename var)))))))
-
-        (define (syntax-quasiquote? form)
-          (and (pair? form)
-               (identifier? (car form))
-               (identifier=? (the 'syntax-quasiquote) (make-identifier (car form) env))))
-
-        (define (syntax-unquote? form)
-          (and (pair? form)
-               (identifier? (car form))
-               (identifier=? (the 'syntax-unquote) (make-identifier (car form) env))))
-
-        (define (syntax-unquote-splicing? form)
-          (and (pair? form)
-               (pair? (car form))
-               (identifier? (caar form))
-               (identifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
-
-        (define (qq depth expr)
-          (cond
-           ;; syntax-unquote
-           ((syntax-unquote? expr)
-            (if (= depth 1)
-                (car (cdr expr))
-                (list (the 'list)
-                      (list (the 'quote) (the 'syntax-unquote))
-                      (qq (- depth 1) (car (cdr expr))))))
-           ;; syntax-unquote-splicing
-           ((syntax-unquote-splicing? expr)
-            (if (= depth 1)
-                (list (the 'append)
-                      (car (cdr (car expr)))
-                      (qq depth (cdr expr)))
-                (list (the 'cons)
-                      (list (the 'list)
-                            (list (the 'quote) (the 'syntax-unquote-splicing))
-                            (qq (- depth 1) (car (cdr (car expr)))))
-                      (qq depth (cdr expr)))))
-           ;; syntax-quasiquote
-           ((syntax-quasiquote? expr)
-            (list (the 'list)
-                  (list (the 'quote) (the 'quasiquote))
-                  (qq (+ depth 1) (car (cdr expr)))))
-           ;; list
-           ((pair? expr)
-            (list (the 'cons)
-                  (qq depth (car expr))
-                  (qq depth (cdr expr))))
-           ;; vector
-           ((vector? expr)
-            (list (the 'list->vector) (qq depth (vector->list expr))))
-           ;; identifier
-           ((identifier? expr)
-            (rename expr))
-           ;; simple datum
-           (else
-            (list (the 'quote) expr))))
-
-        (let ((body (qq 1 (cadr form))))
-          `(,(the 'let)
-            ,(map cdr renames)
-            ,body))))))
-
-(define (transformer f)
-  (lambda (form env)
-    (let ((ephemeron1 (make-ephemeron-table))
-          (ephemeron2 (make-ephemeron-table)))
-      (letrec
-          ((wrap (lambda (var1)
-                   (let ((var2 (ephemeron1 var1)))
-                     (if var2
-                         (cdr var2)
-                         (let ((var2 (make-identifier var1 env)))
-                           (ephemeron1 var1 var2)
-                           (ephemeron2 var2 var1)
-                           var2)))))
-           (unwrap (lambda (var2)
-                     (let ((var1 (ephemeron2 var2)))
-                       (if var1
-                           (cdr var1)
-                           var2))))
-           (walk (lambda (f form)
-                   (cond
-                    ((identifier? form)
-                     (f form))
-                    ((pair? form)
-                     (cons (walk f (car form)) (walk f (cdr form))))
-                    ((vector? form)
-                     (list->vector (walk f (vector->list form))))
-                    (else
-                     form)))))
-        (let ((form (cdr form)))
-          (walk unwrap (apply f (walk wrap form))))))))
-
-(define-macro define-syntax
-  (lambda (form env)
-    (let ((formal (car (cdr form)))
-          (body   (cdr (cdr form))))
-      (if (pair? formal)
-          `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))
-          `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))
-
-(define-macro letrec-syntax
-  (lambda (form env)
-    (let ((formal (car (cdr form)))
-          (body   (cdr (cdr form))))
-      `(let ()
-         ,@(map (lambda (x)
-                  `(,(the 'define-syntax) ,(car x) ,(cadr x)))
-                formal)
-         ,@body))))
-
-(define-macro let-syntax
-  (lambda (form env)
-    `(,(the 'letrec-syntax) ,@(cdr form))))

piclib/error.c

@@ -0,0 +1,89 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "../value.h"
+#include "../object.h"
+#include "../state.h"
+
+#if PIC_USE_ERROR
+
+# define pic_exc(pic) pic_ref(pic, "current-exception-handlers")
+
+PIC_JMPBUF *
+pic_prepare_try(pic_state *pic)
+{
+  struct context *cxt = pic_malloc(pic, sizeof(struct context));
+
+  cxt->pc = NULL;
+  cxt->fp = NULL;
+  cxt->sp = NULL;
+  cxt->irep = NULL;
+  cxt->conts = pic_nil_value(pic);
+  cxt->prev = pic->cxt;
+  pic->cxt = cxt;
+  return &cxt->jmp;
+}
+
+static pic_value
+native_exception_handler(pic_state *pic)
+{
+  pic_value err;
+
+  pic_get_args(pic, "o", &err);
+
+  pic_call(pic, pic_closure_ref(pic, 0), 1, err);
+  PIC_UNREACHABLE();
+}
+
+void
+pic_enter_try(pic_state *pic)
+{
+  pic_value cont, handler;
+  pic_value var, env;
+
+  pic->cxt->ai = pic->ai;
+
+  /* call/cc */
+  cont = pic_make_cont(pic, pic_invalid_value(pic));
+  handler = pic_lambda(pic, native_exception_handler, 1, cont);
+  /* with-exception-handler */
+  var = pic_exc(pic);
+  env = pic_make_attr(pic);
+  pic_attr_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
+  pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
+
+  pic_leave(pic, pic->cxt->ai);
+}
+
+void
+pic_exit_try(pic_state *pic)
+{
+  struct context *cxt = pic->cxt;
+  pic_value c, it;
+  pic->dyn_env = pic_cdr(pic, pic->dyn_env);
+  pic_for_each (c, cxt->conts, it) {
+    proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+  }
+  pic->cxt = cxt->prev;
+  pic_free(pic, cxt);
+  /* don't rewind ai here */
+}
+
+pic_value
+pic_abort_try(pic_state *pic)
+{
+  struct context *cxt = pic->cxt;
+  pic_value c, it;
+  pic_value err = cxt->sp->regs[1];
+  pic_for_each (c, cxt->conts, it) {
+    proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+  }
+  pic->cxt = cxt->prev;
+  pic_free(pic, cxt);
+  pic_protect(pic, err);
+  return err;
+}
+
+#endif

piclib/error.scm

@@ -0,0 +1,52 @@
+(begin
+
+  (define current-exception-handlers
+    (let ((e error))
+      (make-parameter (list e))))
+
+  (define (raise x)
+    (let ((handlers (current-exception-handlers)))
+      (parameterize ((current-exception-handlers (cdr handlers)))
+        ((car handlers) x)
+        (error "handler returned" x))))
+
+  (define (raise-continuable x)
+    (let ((handlers (current-exception-handlers)))
+      (parameterize ((current-exception-handlers (cdr handlers)))
+        ((car handlers) x))))
+
+  (define (with-exception-handler handler thunk)
+    (let ((handlers (current-exception-handlers)))
+      (parameterize ((current-exception-handlers (cons handler handlers)))
+        (thunk))))
+
+  (define-record-type error-object
+      (make-error-object type message irritants)
+      error-object?
+    (type error-object-type)
+    (message error-object-message)
+    (irritants error-object-irritants))
+
+  (set! error
+        (lambda (message . irritants)
+          (raise (make-error-object #f message irritants))))
+
+  (set! display
+        (let ((d display))
+          (lambda (x . port)
+            (let ((port (if (null? port) (current-error-port) (car port))))
+              (if (error-object? x)
+                  (let ()
+                    (when (error-object-type x)
+                      (d (error-object-type x) port)
+                      (d "-" port))
+                    (d "error: \"" port)
+                    (d (error-object-message x) port)
+                    (d "\"")
+                    (for-each
+                     (lambda (x)
+                       (d " " port)
+                       (write x port))
+                     (error-object-irritants x))
+                    (d "\n" port))
+                  (d x port)))))))

piclib/eval.scm

@@ -0,0 +1,918 @@
+(begin
+
+  ;; expand
+
+  (define-values (make-identifier
+                  identifier?
+                  identifier=?
+                  identifier-name
+                  identifier-environment
+                  make-environment
+                  default-environment
+                  environment?
+                  find-identifier
+                  add-identifier!
+                  set-identifier!
+                  macro-objects
+                  expand)
+    (let ()
+
+      ;; identifier
+
+      (define-record-type identifier
+          (make-identifier name env)
+          %identifier?
+        (name identifier-name)
+        (env identifier-environment))
+
+      (define (identifier? obj)
+        (or (symbol? obj) (%identifier? obj)))
+
+      (define (identifier=? id1 id2)
+        (cond
+         ((and (symbol? id1) (symbol? id2))
+          (eq? id1 id2))
+         ((and (%identifier? id1) (%identifier? id2))
+          (eq? (find-identifier (identifier-name id1) (identifier-environment id1))
+               (find-identifier (identifier-name id2) (identifier-environment id2))))
+         (else
+          #f)))
+
+      (set! equal?
+            (let ((e? equal?))
+              (lambda (x y)
+                (if (%identifier? x)
+                    (identifier=? x y)
+                    (e? x y)))))
+
+
+      ;; environment
+
+      (define-record-type environment
+          (%make-environment parent prefix binding)
+          environment?
+        (parent  environment-parent)
+        (prefix  environment-prefix)
+        (binding environment-binding))
+
+      (define (search-scope id env)
+        ((environment-binding env) id))
+
+      (define (find-identifier id env)
+        (or (search-scope id env)
+            (let ((parent (environment-parent env)))
+              (if parent
+                  (find-identifier id parent)
+                  (if (symbol? id)
+                      (add-identifier! id env)
+                      (find-identifier (identifier-name id)
+                                       (identifier-environment id)))))))
+
+      (define add-identifier!
+        (let ((uniq
+               (let ((n 0))
+                 (lambda (id)
+                   (let ((m n))
+                     (set! n (+ n 1))
+                     (string->symbol
+                      (string-append
+                       "."
+                       (symbol->string
+                        (let loop ((id id))
+                          (if (symbol? id)
+                              id
+                              (loop (identifier-name id)))))
+                       "."
+                       (number->string m))))))))
+          (lambda (id env)
+            (or (search-scope id env)
+                (if (and (not (environment-parent env)) (symbol? id))
+                    (string->symbol
+                     (string-append
+                      (environment-prefix env)
+                      (symbol->string id)))
+                    (let ((uid (uniq id)))
+                      (set-identifier! id uid env)
+                      uid))))))
+
+      (define (set-identifier! id uid env)
+        ((environment-binding env) id uid))
+
+      (define (make-environment prefix)
+        (%make-environment #f (symbol->string prefix) (make-attribute)))
+
+      (define default-environment
+        (let ((env (make-environment (string->symbol ""))))
+          (for-each
+           (lambda (x) (set-identifier! x x env))
+           '(core#define
+             core#set!
+             core#quote
+             core#lambda
+             core#if
+             core#begin
+             core#define-macro))
+          (lambda ()
+            env)))
+
+      (define (extend-environment parent)
+        (%make-environment parent #f (make-attribute)))
+
+
+      ;; macro
+
+      (define global-macro-table
+        (make-dictionary))
+
+      (define (find-macro uid)
+        (and (dictionary-has? global-macro-table uid)
+             (dictionary-ref global-macro-table uid)))
+
+      (define (add-macro! uid expander) ; TODO warn on redefinition
+        (dictionary-set! global-macro-table uid expander))
+
+      (define (shadow-macro! uid)
+        (when (dictionary-has? global-macro-table uid)
+          (dictionary-delete! global-macro-table uid)))
+
+      (define (macro-objects)
+        global-macro-table)
+
+
+      ;; expander
+
+      (define expand
+        (let ((task-queue (make-parameter '())))
+
+          (define (queue task)
+            (let ((tmp (cons #f #f)))
+              (task-queue `((,tmp . ,task) . ,(task-queue)))
+              tmp))
+
+          (define (run-all)
+            (for-each
+             (lambda (x)
+               (let ((task (cdr x)) (skelton (car x)))
+                 (let ((x (task)))
+                   (set-car! skelton (car x))
+                   (set-cdr! skelton (cdr x)))))
+             (reverse (task-queue))))
+
+          (define (caddr x) (car (cddr x)))
+
+          (define (map* proc list*)
+            (cond
+             ((null? list*) list*)
+             ((pair? list*) (cons (proc (car list*)) (map* proc (cdr list*))))
+             (else (proc list*))))
+
+          (define (literal? x)
+            (not (or (identifier? x) (pair? x))))
+
+          (define (call? x)
+            (and (list? x)
+                 (not (null? x))
+                 (identifier? (car x))))
+
+          (define (expand-variable var env)
+            (let ((x (find-identifier var env)))
+              (let ((m (find-macro x)))
+                (if m
+                    (expand-node (m var env) env)
+                    x))))
+
+          (define (expand-quote obj)
+            `(core#quote ,obj))
+
+          (define (expand-define var form env)
+            (let ((uid (add-identifier! var env)))
+              (shadow-macro! uid)
+              `(core#define ,uid ,(expand-node form env))))
+
+          (define (expand-lambda args body env)
+            (let ((env (extend-environment env)))
+              (let ((args (map* (lambda (var) (add-identifier! var env)) args)))
+                (parameterize ((task-queue '()))
+                  (let ((body (expand-node body env)))
+                    (run-all)
+                    `(core#lambda ,args ,body))))))
+
+          (define (expand-define-macro var transformer env)
+            (let ((uid (add-identifier! var env)))
+              (let ((expander (eval transformer env)))
+                (add-macro! uid expander)
+                #undefined)))
+
+          (define (expand-node expr env)
+            (cond
+             ((literal? expr) expr)
+             ((identifier? expr) (expand-variable expr env))
+             ((call? expr)
+              (let ((functor (find-identifier (car expr) env)))
+                (case functor
+                  ((core#quote) (expand-quote (cadr expr)))
+                  ((core#define) (expand-define (cadr expr) (caddr expr) env))
+                  ((core#lambda) (queue (lambda () (expand-lambda (cadr expr) (caddr expr) env))))
+                  ((core#define-macro) (expand-define-macro (cadr expr) (caddr expr) env))
+                  (else
+                   (let ((m (find-macro functor)))
+                     (if m
+                         (expand-node (m expr env) env)
+                         (map (lambda (x) (expand-node x env)) expr)))))))
+             ((list? expr)
+              (map (lambda (x) (expand-node x env)) expr))
+             (else
+              (error "invalid expression" expr))))
+
+          (define (expand expr . env)
+            (let ((x (expand-node expr (if (null? env) (default-environment) (car env)))))
+              (run-all)
+              x))
+
+          expand))
+
+      (values make-identifier
+              identifier?
+              identifier=?
+              identifier-name
+              identifier-environment
+              make-environment
+              default-environment
+              environment?
+              find-identifier
+              add-identifier!
+              set-identifier!
+              macro-objects
+              expand)))
+
+
+  ;; built-in macros
+
+  (let ()
+
+    (define (define-transformer name transformer)
+      (dictionary-set! (macro-objects) name transformer))
+
+    (define (the var)
+      (make-identifier var (default-environment)))
+
+    (let
+        ;; cache popular identifiers
+        ((the-core-define (the 'core#define))
+         (the-core-lambda (the 'core#lambda))
+         (the-core-begin (the 'core#begin))
+         (the-core-quote (the 'core#quote))
+         (the-core-set! (the 'core#set!))
+         (the-core-if (the 'core#if))
+         (the-core-define-macro (the 'core#define-macro))
+         (the-define (the 'define))
+         (the-lambda (the 'lambda))
+         (the-begin (the 'begin))
+         (the-quote (the 'quote))
+         (the-set! (the 'set!))
+         (the-if (the 'if))
+         (the-define-macro (the 'define-macro)))
+
+      (define-transformer 'quote
+        (lambda (form env)
+          (if (= (length form) 2)
+              (let ((obj (cadr form)))
+                (cond
+                 ((pair? obj) `(,(the 'cons) (,the-quote ,(car obj)) (,the-quote ,(cdr obj))))
+                 ((vector? obj) `(,(the 'vector) . ,(vector->list
+                                                     (vector-map (lambda (obj) `(,the-quote ,obj)) obj))))
+                 (else `(,the-core-quote ,obj))))
+              (error "malformed quote" form))))
+
+      (define-transformer 'if
+        (lambda (form env)
+          (let ((len (length form)))
+            (cond
+             ((= len 3) `(,@form #undefined))
+             ((= len 4) `(,the-core-if . ,(cdr form)))
+             (else (error "malformed if" form))))))
+
+      (define-transformer 'begin
+        (lambda (form env)
+          (let ((len (length form)))
+            (cond
+             ((= len 1) #undefined)
+             ((= len 2) (cadr form))
+             ((= len 3) `(,the-core-begin . ,(cdr form)))
+             (else `(,the-core-begin ,(cadr form) (,the-begin . ,(cddr form))))))))
+
+      (define-transformer 'set!
+        (lambda (form env)
+          (if (and (= (length form) 3) (identifier? (cadr form)))
+              `(,the-core-set! . ,(cdr form))
+              (error "malformed set!" form))))
+
+      (define (check-formal formal)
+        (or (null? formal)
+            (identifier? formal)
+            (and (pair? formal)
+                 (identifier? (car formal))
+                 (check-formal (cdr formal)))))
+
+      (define-transformer 'lambda
+        (lambda (form env)
+          (if (= (length form) 1)
+              (error "malformed lambda" form)
+              (if (check-formal (cadr form))
+                  `(,the-core-lambda ,(cadr form) (,the-begin . ,(cddr form)))
+                  (error "malformed lambda" form)))))
+
+      (define-transformer 'define
+        (lambda (form env)
+          (let ((len (length form)))
+            (if (= len 1)
+                (error "malformed define" form)
+                (let ((formal (cadr form)))
+                  (if (identifier? formal)
+                      (if (= len 3)
+                          `(,the-core-define . ,(cdr form))
+                          (error "malformed define" form))
+                      (if (pair? formal)
+                          `(,the-define ,(car formal) (,the-lambda ,(cdr formal) . ,(cddr form)))
+                          (error "define: binding to non-varaible object" form))))))))
+
+      (define-transformer 'define-macro
+        (lambda (form env)
+          (if (= (length form) 3)
+              (if (identifier? (cadr form))
+                  `(,the-core-define-macro . ,(cdr form))
+                  (error "define-macro: binding to non-variable object" form))
+              (error "malformed define-macro" form))))
+
+
+      (define-macro define-auxiliary-syntax
+        (lambda (form _)
+          `(define-transformer ',(cadr form)
+             (lambda _
+               (error "invalid use of auxiliary syntax" ',(cadr form))))))
+
+      (define-auxiliary-syntax else)
+      (define-auxiliary-syntax =>)
+      (define-auxiliary-syntax unquote)
+      (define-auxiliary-syntax unquote-splicing)
+
+      (define-transformer 'let
+        (lambda (form env)
+          (if (identifier? (cadr form))
+              (let ((name   (car (cdr form)))
+                    (formal (car (cdr (cdr form))))
+                    (body   (cdr (cdr (cdr form)))))
+                `((,the-lambda ()
+                               (,the-define (,name . ,(map car formal)) . ,body)
+                               (,name . ,(map cadr formal)))))
+              (let ((formal (car (cdr form)))
+                    (body   (cdr (cdr form))))
+                `((,the-lambda ,(map car formal) . ,body) . ,(map cadr formal))))))
+
+      (define-transformer 'and
+        (lambda (form env)
+          (if (null? (cdr form))
+              #t
+              (if (null? (cddr form))
+                  (cadr form)
+                  `(,the-if ,(cadr form) (,(the 'and) . ,(cddr form)) #f)))))
+
+      (define-transformer 'or
+        (lambda (form env)
+          (if (null? (cdr form))
+              #f
+              (let ((tmp (make-identifier 'it env))) ; should we use #f as the env for tmp?
+                `(,(the 'let) ((,tmp ,(cadr form)))
+                  (,the-if ,tmp ,tmp (,(the 'or) . ,(cddr form))))))))
+
+      (define-transformer 'cond
+        (lambda (form env)
+          (let ((clauses (cdr form)))
+            (if (null? clauses)
+                #undefined
+                (let ((clause (car clauses)))
+                  (if (and (identifier? (car clause))
+                           (identifier=? (the 'else) (make-identifier (car clause) env)))
+                      `(,the-begin . ,(cdr clause))
+                      (if (null? (cdr clause))
+                          `(,(the 'or) ,(car clause) (,(the 'cond) . ,(cdr clauses)))
+                          (if (and (identifier? (cadr clause))
+                                   (identifier=? (the '=>) (make-identifier (cadr clause) env)))
+                              (let ((tmp (make-identifier 'tmp env)))
+                                `(,(the 'let) ((,tmp ,(car clause)))
+                                  (,the-if ,tmp (,(cadr (cdr clause)) ,tmp) (,(the 'cond) . ,(cddr form)))))
+                              `(,the-if ,(car clause)
+                                        (,the-begin . ,(cdr clause))
+                                        (,(the 'cond) . ,(cdr clauses)))))))))))
+
+      (define-transformer 'quasiquote
+        (lambda (form env)
+
+          (define (quasiquote? form)
+            (and (pair? form)
+                 (identifier? (car form))
+                 (identifier=? (the 'quasiquote) (make-identifier (car form) env))))
+
+          (define (unquote? form)
+            (and (pair? form)
+                 (identifier? (car form))
+                 (identifier=? (the 'unquote) (make-identifier (car form) env))))
+
+          (define (unquote-splicing? form)
+            (and (pair? form)
+                 (pair? (car form))
+                 (identifier? (caar form))
+                 (identifier=? (the 'unquote-splicing) (make-identifier (caar form) env))))
+
+          (define (qq depth expr)
+            (cond
+             ;; unquote
+             ((unquote? expr)
+              (if (= depth 1)
+                  (cadr expr)
+                  (list (the 'list)
+                        (list (the 'quote) (the 'unquote))
+                        (qq (- depth 1) (car (cdr expr))))))
+             ;; unquote-splicing
+             ((unquote-splicing? expr)
+              (if (= depth 1)
+                  (list (the 'append)
+                        (car (cdr (car expr)))
+                        (qq depth (cdr expr)))
+                  (list (the 'cons)
+                        (list (the 'list)
+                              (list (the 'quote) (the 'unquote-splicing))
+                              (qq (- depth 1) (car (cdr (car expr)))))
+                        (qq depth (cdr expr)))))
+             ;; quasiquote
+             ((quasiquote? expr)
+              (list (the 'list)
+                    (list (the 'quote) (the 'quasiquote))
+                    (qq (+ depth 1) (car (cdr expr)))))
+             ;; list
+             ((pair? expr)
+              (list (the 'cons)
+                    (qq depth (car expr))
+                    (qq depth (cdr expr))))
+             ;; vector
+             ((vector? expr)
+              (list (the 'list->vector) (qq depth (vector->list expr))))
+             ;; simple datum
+             (else
+              (list (the 'quote) expr))))
+
+          (let ((x (cadr form)))
+            (qq 1 x))))
+
+      (define-transformer 'let*
+        (lambda (form env)
+          (let ((bindings (car (cdr form)))
+                (body     (cdr (cdr form))))
+            (if (null? bindings)
+                `(,(the 'let) () . ,body)
+                `(,(the 'let) ((,(car (car bindings)) . ,(cdr (car bindings))))
+                  (,(the 'let*) ,(cdr bindings) . ,body))))))
+
+      (define-transformer 'letrec
+        (lambda (form env)
+          `(,(the 'letrec*) . ,(cdr form))))
+
+      (define-transformer 'letrec*
+        (lambda (form env)
+          (let ((bindings (car (cdr form)))
+                (body     (cdr (cdr form))))
+            (let ((variables (map (lambda (v) `(,v #undefined)) (map car bindings)))
+                  (initials  (map (lambda (v) `(,(the 'set!) ,@v)) bindings)))
+              `(,(the 'let) ,variables
+                ,@initials
+                ,@body)))))
+
+      (define-transformer 'let-values
+        (lambda (form env)
+          `(,(the 'let*-values) ,@(cdr form))))
+
+      (define-transformer 'let*-values
+        (lambda (form env)
+          (let ((formals (cadr form))
+                (body    (cddr form)))
+            (if (null? formals)
+                `(,(the 'let) () ,@body)
+                (let ((formal (car formals)))
+                  `(,(the 'call-with-values) (,the-lambda () . ,(cdr formal))
+                    (,(the 'lambda) ,(car formal)
+                     (,(the 'let*-values) ,(cdr formals) . ,body))))))))
+
+      (define-transformer 'define-values
+        (lambda (form env)
+          (let ((formal (cadr form))
+                (body   (cddr form)))
+            (let ((tmps (let loop ((formal formal))
+                          (if (identifier? formal)
+                              (make-identifier formal env)
+                              (if (pair? formal)
+                                  (cons (make-identifier (car formal) env) (loop (cdr formal)))
+                                  '())))))
+              `(,the-begin
+                ,@(let loop ((formal formal))
+                    (if (identifier? formal)
+                        `((,the-define ,formal #undefined))
+                        (if (pair? formal)
+                            (cons `(,the-define ,(car formal) #undefined) (loop (cdr formal)))
+                            '())))
+                (,(the 'call-with-values) (,the-lambda () . ,body)
+                 (,the-lambda ,tmps . ,(let loop ((formal formal) (tmps tmps))
+                                         (if (identifier? formal)
+                                             `((,the-set! ,formal ,tmps))
+                                             (if (pair? formal)
+                                                 (cons `(,the-set! ,(car formal) ,(car tmps))
+                                                       (loop (cdr formal) (cdr tmps)))
+                                                 '()))))))))))
+
+      (define-transformer 'do
+        (lambda (form env)
+          (let ((bindings (car (cdr form)))
+                (test     (car (car (cdr (cdr form)))))
+                (cleanup  (cdr (car (cdr (cdr form)))))
+                (body     (cdr (cdr (cdr form)))))
+            (let ((loop (make-identifier 'loop env)))
+              `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)
+                (,the-if ,test
+                         (,the-begin . ,cleanup)
+                         (,the-begin
+                          ,@body
+                          (,loop . ,(map (lambda (x)
+                                           (if (null? (cdr (cdr x)))
+                                               (car x)
+                                               (car (cdr (cdr x)))))
+                                         bindings)))))))))
+
+      (define-transformer 'when
+        (lambda (form env)
+          (let ((test (car (cdr form)))
+                (body (cdr (cdr form))))
+            `(,the-if ,test
+                      (,the-begin ,@body)
+                      #undefined))))
+
+      (define-transformer 'unless
+        (lambda (form env)
+          (let ((test (car (cdr form)))
+                (body (cdr (cdr form))))
+            `(,the-if ,test
+                      #undefined
+                      (,the-begin ,@body)))))
+
+      (define-transformer 'case
+        (lambda (form env)
+          (let ((key     (car (cdr form)))
+                (clauses (cdr (cdr form))))
+            (let ((the-key (make-identifier 'key env)))
+              `(,(the 'let) ((,the-key ,key))
+                ,(let loop ((clauses clauses))
+                   (if (null? clauses)
+                       #undefined
+                       (let ((clause (car clauses)))
+                         `(,the-if ,(if (and (identifier? (car clause))
+                                             (identifier=? (the 'else) (make-identifier (car clause) env)))
+                                        #t
+                                        `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))
+                                   ,(if (and (identifier? (cadr clause))
+                                             (identifier=? (the '=>) (make-identifier (cadr clause) env)))
+                                        `(,(car (cdr (cdr clause))) ,the-key)
+                                        `(,the-begin ,@(cdr clause)))
+                                   ,(loop (cdr clauses)))))))))))
+
+      (define-transformer 'parameterize
+        (lambda (form env)
+          (let ((formal (car (cdr form)))
+                (body   (cdr (cdr form))))
+            (let ((table (the 'table))
+                  (prev (the 'prev))
+                  (it (the 'it)))
+              `(,(the 'let) ((,table (,(the 'make-attribute)))
+                             (,prev (,(the 'current-dynamic-environment))))
+                (,(the 'current-dynamic-environment) (,(the 'cons) ,table ,prev))
+                (,the-begin . ,formal)
+                (,(the 'let) ((,it (,the-begin . ,body)))
+                 (,(the 'current-dynamic-environment) ,prev)
+                 ,it))))))
+
+      (define-transformer 'define-record-type
+        (lambda (form env)
+          (let ((type (car (cdr form)))
+                (ctor (car (cdr (cdr form))))
+                (pred (car (cdr (cdr (cdr form)))))
+                (fields (cdr (cdr (cdr (cdr form))))))
+            `(,the-begin
+              (,the-define ,ctor
+                           (,(the 'make-record) ',type
+                            (,(the 'vector) . ,(map (lambda (field) (if (memq (car field) (cdr ctor)) (car field) #undefined)) fields))))
+              (,the-define ,pred
+                           (,(the 'lambda) (obj)
+                            (,(the 'and) (,(the 'record?) obj) (,(the 'eq?) (,(the 'record-type) obj) ',type))))
+              . ,(let loop ((fields fields) (pos 0) (acc '()))
+                   (if (null? fields)
+                       acc
+                       (let ((field (car fields)))
+                         (let ((defs `((,the-define (,(cadr field) obj)
+                                                    (,the-if (,pred obj)
+                                                             (,(the 'vector-ref) (,(the 'record-datum) obj) ,pos)
+                                                             (,(the 'error) "record type mismatch" obj ',type)))
+                                       . ,(if (null? (cddr field))
+                                              '()
+                                              `((,the-define (,(car (cddr field)) obj value)
+                                                             (,the-if (,pred obj)
+                                                                      (,(the 'vector-set!) (,(the 'record-datum) obj) ,pos value)
+                                                                      (,(the 'error) "record type mismatch" obj ',type))))))))
+                           (loop (cdr fields) (+ pos 1) `(,@defs . ,acc))))))))))
+
+      (define-transformer 'include
+        (letrec ((read-file
+                  (lambda (filename)
+                    (let ((port (open-input-file filename)))
+                      (let loop ((expr (read port)) (exprs '()))
+                        (if (eof-object? expr)
+                            (begin
+                              (close-port port)
+                              (reverse exprs))
+                            (loop (read port) (cons expr exprs))))))))
+          (lambda (form env)
+            (let ((filenames (cdr form)))
+              (let ((exprs (apply append (map read-file filenames))))
+                `(,the-begin . ,exprs))))))))
+
+  ;; compile
+
+  (define-values (compile)
+    (let ()
+
+      (define (caddr x) (car (cddr x)))
+      (define (cadddr x) (cadr (cddr x)))
+      (define (max a b) (if (< a b) b a))
+      (define (integer? n) (and (number? n) (exact? n)))
+
+      (define normalize
+        (let ((defs (make-parameter '())))
+
+          ;; 1. remove core# prefix from keywords
+          ;; 2. eliminates internal definitions by replacing with equivalent let & set!
+          ;; 3. transform a var into (ref var)
+          ;; 4. wrap raw constants with quote
+
+          ;; TODO: warn redefinition, warn duplicate variables
+
+          (define (normalize e)
+            (cond
+             ((symbol? e) `(ref ,e))
+             ((not (pair? e)) `(quote ,e))
+             (else
+              (case (car e)
+                ((core#quote) `(quote . ,(cdr e)))
+                ((core#define)
+                 (let ((var (cadr e)) (val (caddr e)))
+                   (defs (cons var (defs)))
+                   `(set! ,var ,(normalize val))))
+                ((core#lambda)
+                 (let ((args (cadr e)) (body (caddr e)))
+                   (parameterize ((defs '()))
+                     (let ((body (normalize body)))
+                       (if (null? (defs))
+                           `(lambda ,args ,body)
+                           `(lambda ,args
+                              ((lambda ,(defs) ,body) ,@(map (lambda (_) ''#f) (defs)))))))))
+                ((core#set!) `(set! ,(cadr e) ,(normalize (caddr e))))
+                ((core#if) `(if . ,(map normalize (cdr e))))
+                ((core#begin) `(begin . ,(map normalize (cdr e))))
+                (else
+                 (map normalize e))))))
+
+          normalize))
+
+
+      (define transform
+        (let ()
+
+          ;; tail-conscious higher-order CPS transformation
+
+          ;; target language
+          ;; E ::= A
+          ;;     | (if A E E)
+          ;;     | (set! v A E)
+          ;;     | (A A ...)
+          ;; A ::= (lambda (var ...) E)
+          ;;     | (ref v)
+          ;;     | (quote x)
+          ;;     | (undefined)
+
+          (define uniq
+            (let ((n 0))
+              (lambda ()
+                (set! n (+ n 1))
+                (string->symbol
+                 (string-append "$" (number->string n))))))
+
+          (define (transform-k e k)
+            (case (car e)
+              ((ref lambda quote) (k (transform-v e)))
+              ((begin) (transform-k (cadr e)
+                                    (lambda (_)
+                                      (transform-k (caddr e) k))))
+              ((set!) (transform-k (caddr e)
+                                   (lambda (v)
+                                     `(set! ,(cadr e) ,v ,(k '(undefined))))))
+              ((if) (let ((v (uniq))
+                          (c (uniq)))
+                      `((lambda (,c)
+                          ,(transform-k (cadr e)
+                                        (lambda (x)
+                                          `(if ,x
+                                               ,(transform-c (caddr e) `(ref ,c))
+                                               ,(transform-c (cadddr e) `(ref ,c))))))
+                        (lambda (,v) ,(k `(ref ,v))))))
+              (else
+               (let* ((v (uniq))
+                      (c `(lambda (,v) ,(k `(ref ,v)))))
+                 (transform-k (car e)
+                              (lambda (f)
+                                (transform*-k (cdr e)
+                                              (lambda (args)
+                                                `(,f ,c ,@args)))))))))
+
+          (define (transform*-k es k)
+            (if (null? es)
+                (k '())
+                (transform-k (car es)
+                             (lambda (x)
+                               (transform*-k (cdr es)
+                                             (lambda (xs)
+                                               (k (cons x xs))))))))
+
+          (define (transform-c e c)
+            (case (car e)
+              ((ref lambda quote) `(,c ,(transform-v e)))
+              ((begin) (transform-k (cadr e)
+                                    (lambda (_)
+                                      (transform-c (caddr e) c))))
+              ((set!) (transform-k (caddr e)
+                                   (lambda (v)
+                                     `(set! ,(cadr e) ,v (,c (undefined))))))
+              ((if) (if (and (pair? c) (eq? 'lambda (car c)))
+                        (let ((k (uniq)))
+                          `((lambda (,k)
+                              ,(transform-k (cadr e)
+                                            (lambda (x)
+                                              `(if ,x
+                                                   ,(transform-c (caddr e) `(ref ,k))
+                                                   ,(transform-c (cadddr e) `(ref ,k))))))
+                            ,c))
+                        (transform-k (cadr e)
+                                     (lambda (x)
+                                       `(if ,x
+                                            ,(transform-c (caddr e) c)
+                                            ,(transform-c (cadddr e) c))))))
+              (else
+               (transform-k (car e)
+                            (lambda (f)
+                              (transform*-k (cdr e)
+                                            (lambda (args)
+                                              `(,f ,c ,@args))))))))
+
+          (define (transform-v e)
+            (case (car e)
+              ((ref quote) e)
+              ((lambda)
+               (let ((k (uniq)))
+                 `(lambda (,k . ,(cadr e)) ,(transform-c (caddr e) `(ref ,k)))))))
+
+          (lambda (e)
+            (let ((k (uniq)))
+              `(lambda (,k) ,(transform-c e `(ref ,k)))))))
+
+
+      (define codegen
+        (let ()
+
+          ;; TODO: check range of index/depth/frame_size/irepc/objc
+
+          (define (lookup var env)
+            (let up ((depth 0) (env env))
+              (if (null? env)
+                  `(global ,var)
+                  (let loop ((index 1) (binding (car env)))
+                    (if (symbol? binding)
+                        (if (eq? var binding)
+                            `(local ,depth ,index)
+                            (up (+ depth 1) (cdr env)))
+                        (if (null? binding)
+                            (up (+ depth 1) (cdr env))
+                            (if (eq? var (car binding))
+                                `(local ,depth ,index)
+                                (loop (+ index 1) (cdr binding)))))))))
+
+          (define env (make-parameter '()))
+          (define code (make-parameter '()))
+          (define reps (make-parameter '()))
+          (define objs (make-parameter '()))
+
+          (define (emit inst)
+            (code (cons inst (code))))
+
+          (define (emit-irep irep)
+            (let ((n (length (reps))))
+              (reps (cons irep (reps)))
+              n))
+
+          (define (emit-obj obj)       ; TODO remove duplicates
+            (let ((n (length (objs))))
+              (objs (cons obj (objs)))
+              n))
+
+          (define make-label
+            (let ((n 0))
+              (lambda ()
+                (let ((m n))
+                  (set! n (+ n 1))
+                  m))))
+
+          (define (emit-label label)
+            (code (cons label (code))))
+
+          (define (codegen-e e)
+            (case (car e)
+              ((ref lambda quote undefined) (codegen-a e 0))
+              ((set!) (begin
+                        (codegen-a (caddr e) 0)
+                        (let ((x (lookup (cadr e) (env))))
+                          (if (eq? 'global (car x))
+                              (let ((i (emit-obj (cadr x))))
+                                (emit `(GSET 0 ,i)))
+                              (emit `(LSET 0 . ,(cdr x)))))
+                        (codegen-e (cadddr e))))
+              ((if) (begin
+                      (codegen-a (cadr e) 0)
+                      (let ((label (make-label)))
+                        (emit `(COND 0 ,label))
+                        (codegen-e (caddr e))
+                        (emit-label label)
+                        (codegen-e (cadddr e)))))
+              (else (begin
+                      (let loop ((i 0) (e e))
+                        (unless (null? e)
+                          (codegen-a (car e) i)
+                          (loop (+ i 1) (cdr e))))
+                      (emit `(CALL ,(- (length e) 1)))))))
+
+          (define (codegen-a e i)
+            (case (car e)
+              ((ref) (let ((x (lookup (cadr e) (env))))
+                       (if (eq? 'global (car x))
+                           (let ((n (emit-obj (cadr x))))
+                             (emit `(GREF ,i ,n)))
+                           (emit `(LREF ,i . ,(cdr x))))))
+              ((quote) (let ((obj (cadr e)))
+                         (cond ((eq? #t obj) (emit `(LOADT ,i)))
+                               ((eq? #f obj) (emit `(LOADF ,i)))
+                               ((null? obj) (emit `(LOADN ,i)))
+                               ((eq? #undefined obj) (emit `(LOADU ,i)))
+                               ((and (integer? obj) (<= -127 obj 127)) (emit `(LOADI ,i ,obj)))
+                               (else (let ((n (emit-obj obj)))
+                                       (emit `(LOAD ,i ,n)))))))
+              ((undefined) (emit `(LOADU ,i)))
+              ((lambda) (let ((frame-size
+                               (let loop ((e (caddr e)))
+                                 (case (car e)
+                                   ((ref lambda quote undefined) 1)
+                                   ((if) (max (loop (caddr e)) (loop (cadddr e))))
+                                   ((set!) (loop (cadddr e)))
+                                   (else (+ 1 (length e))))))
+                              (argc-varg
+                               (let loop ((args (cadr e)) (c 0))
+                                 (if (symbol? args)
+                                     (cons c #t)
+                                     (if (null? args)
+                                         (cons c #f)
+                                         (loop (cdr args) (+ 1 c)))))))
+                          (let ((irep
+                                 (parameterize ((code '())
+                                                (env (cons (cadr e) (env)))
+                                                (reps '())
+                                                (objs '()))
+                                   (codegen-e (caddr e))
+                                   (list (reverse (code)) (reverse (reps)) (reverse (objs)) argc-varg frame-size))))
+                            (let ((n (emit-irep irep)))
+                              (emit `(PROC ,i ,n))))))))
+
+          (lambda (e)
+            (parameterize ((code '()) (env '()) (reps '()) (objs '()))
+              (codegen-e e)
+              (car (reps))))))
+
+      (lambda (e . env)
+        (make-procedure (codegen (transform (normalize (apply expand e env))))))))
+
+
+  ;; eval
+
+  (define (eval expr . env)
+    ((apply compile expr env))))
+

piclib/library.scm

@@ -1,271 +1,234 @@
-;;; There are two ways to name a library: (foo bar) or foo.bar
-;;; The former is normalized to the latter.
+(define-values (current-library
+                find-library
+                make-library
+                library-environment
+                library-exports
+                library-import
+                library-export)
+  (let ()
+    ;; There are two ways to name a library: (foo bar) or foo.bar
+    ;; The former is normalized to the latter.
 
-(define (mangle name)
-  (when (null? name)
-    (error "library name should be a list of at least one symbols" name))
+    (define (mangle name)
+      (when (null? name)
+        (error "library name should be a list of at least one symbols" name))
 
-  (define (->string n)
-    (cond
-     ((symbol? n)
-      (let ((str (symbol->string n)))
-        (string-for-each
-         (lambda (c)
-           (when (or (char=? c #\.) (char=? c #\:))
-             (error "elements of library name may not contain '.' or ':'" n)))
-         str)
-        str))
-     ((and (number? n) (exact? n) (<= 0 n))
-      (number->string n))
-     (else
-      (error "symbol or non-negative integer is required" n))))
+      (define (->string n)
+        (cond
+         ((symbol? n)
+          (let ((str (symbol->string n)))
+            (string-for-each
+             (lambda (c)
+               (when (or (char=? c #\.) (char=? c #\:))
+                 (error "elements of library name may not contain '.' or ':'" n)))
+             str)
+            str))
+         ((and (number? n) (exact? n) (<= 0 n))
+          (number->string n))
+         (else
+          (error "symbol or non-negative integer is required" n))))
 
-  (define (join strs delim)
-    (let loop ((res (car strs)) (strs (cdr strs)))
-      (if (null? strs)
-          res
-          (loop (string-append res delim (car strs)) (cdr strs)))))
+      (define (join strs delim)
+        (let loop ((res (car strs)) (strs (cdr strs)))
+          (if (null? strs)
+              res
+              (loop (string-append res delim (car strs)) (cdr strs)))))
 
-  (if (symbol? name)
-      name                              ; TODO: check symbol names
-      (string->symbol (join (map ->string name) "."))))
+      (if (symbol? name)
+          name                        ; TODO: check symbol names
+          (string->symbol (join (map ->string name) "."))))
 
-(define current-library
-  (make-parameter '(picrin base) mangle))
+    (define current-library
+      (make-parameter '(picrin user) mangle))
 
-(define *libraries*
-  (make-dictionary))
+    (define *libraries*
+      (make-dictionary))
 
-(define (find-library name)
-  (dictionary-has? *libraries* (mangle name)))
+    (define (find-library name)
+      (dictionary-has? *libraries* (mangle name)))
 
-(define (make-library name)
-  (let ((name (mangle name)))
-    (let ((env (make-environment
-                 (string->symbol (string-append (symbol->string name) ":"))))
-          (exports (make-dictionary)))
-      ;; set up initial environment
-      (set-identifier! 'define-library 'define-library env)
-      (set-identifier! 'import 'import env)
-      (set-identifier! 'export 'export env)
-      (set-identifier! 'cond-expand 'cond-expand env)
-      (dictionary-set! *libraries* name `(,env . ,exports)))))
+    (define (make-library name)
+      (let ((name (mangle name)))
+        (let ((env (make-environment
+                     (string->symbol (string-append (symbol->string name) ":"))))
+              (exports (make-dictionary)))
+          ;; set up initial environment
+          (set-identifier! 'define-library 'define-library env)
+          (set-identifier! 'import 'import env)
+          (set-identifier! 'export 'export env)
+          (set-identifier! 'cond-expand 'cond-expand env)
+          (dictionary-set! *libraries* name `(,env . ,exports)))))
 
-(define (library-environment name)
-  (car (dictionary-ref *libraries* (mangle name))))
+    (define (library-environment name)
+      (car (dictionary-ref *libraries* (mangle name))))
 
-(define (library-exports name)
-  (cdr (dictionary-ref *libraries* (mangle name))))
+    (define (library-exports name)
+      (cdr (dictionary-ref *libraries* (mangle name))))
 
-(define (library-import name sym alias)
-  (let ((uid (dictionary-ref (library-exports name) sym)))
-    (let ((env (library-environment (current-library))))
-      (set-identifier! alias uid env))))
+    (define (library-import name sym alias)
+      (let ((uid (dictionary-ref (library-exports name) sym)))
+        (let ((env (library-environment (current-library))))
+          (set-identifier! alias uid env))))
 
-(define (library-export sym alias)
-  (let ((env (library-environment (current-library)))
-        (exports (library-exports (current-library))))
-    (dictionary-set! exports alias (find-identifier sym env))))
+    (define (library-export sym alias)
+      (let ((env (library-environment (current-library)))
+            (exports (library-exports (current-library))))
+        (dictionary-set! exports alias (find-identifier sym env))))
 
 
 
-;;; R7RS library syntax
+    ;; R7RS library syntax
 
-(define-macro define-library
-  (lambda (form _)
-    (let ((name (cadr form))
-          (body (cddr form)))
-      (or (find-library name) (make-library name))
-      (parameterize ((current-library name))
-        (for-each
-         (lambda (expr)
-           (eval expr name))       ; TODO parse library declarations
-         body)))))
+    (let ((define-transformer
+            (lambda (name macro)
+              (dictionary-set! (macro-objects) name macro))))
 
-(define-macro cond-expand
-  (lambda (form _)
-    (letrec
-        ((test (lambda (form)
-                 (or
-                  (eq? form 'else)
-                  (and (symbol? form)
-                       (memq form (features)))
-                  (and (pair? form)
-                       (case (car form)
-                         ((library) (find-library (cadr form)))
-                         ((not) (not (test (cadr form))))
-                         ((and) (let loop ((form (cdr form)))
-                                  (or (null? form)
-                                      (and (test (car form)) (loop (cdr form))))))
-                         ((or) (let loop ((form (cdr form)))
-                                 (and (pair? form)
-                                      (or (test (car form)) (loop (cdr form))))))
-                         (else #f)))))))
-      (let loop ((clauses (cdr form)))
-        (if (null? clauses)
-            #undefined
-            (if (test (caar clauses))
-                `(,the-begin ,@(cdar clauses))
-                (loop (cdr clauses))))))))
-
-(define-macro import
-  (lambda (form _)
-    (let ((caddr
-           (lambda (x) (car (cdr (cdr x)))))
-          (prefix
-           (lambda (prefix symbol)
-             (string->symbol
-              (string-append
-               (symbol->string prefix)
-               (symbol->string symbol)))))
-          (getlib
-           (lambda (name)
-             (if (find-library name)
-                 name
-                 (error "library not found" name)))))
-      (letrec
-          ((extract
-            (lambda (spec)
-              (case (car spec)
-                ((only rename prefix except)
-                 (extract (cadr spec)))
-                (else
-                 (getlib spec)))))
-           (collect
-            (lambda (spec)
-              (case (car spec)
-                ((only)
-                 (let ((alist (collect (cadr spec))))
-                   (map (lambda (var) (assq var alist)) (cddr spec))))
-                ((rename)
-                 (let ((alist (collect (cadr spec)))
-                       (renames (map (lambda (x) `(,(car x) . ,(cadr x))) (cddr spec))))
-                   (map (lambda (s) (or (assq (car s) renames) s)) alist)))
-                ((prefix)
-                 (let ((alist (collect (cadr spec))))
-                   (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))
-                ((except)
-                 (let ((alist (collect (cadr spec))))
-                   (let loop ((alist alist))
-                     (if (null? alist)
-                         '()
-                         (if (memq (caar alist) (cddr spec))
-                             (loop (cdr alist))
-                             (cons (car alist) (loop (cdr alist))))))))
-                (else
-                 (dictionary-map (lambda (x) (cons x x))
-                                 (library-exports (getlib spec))))))))
-        (letrec
-            ((import
-               (lambda (spec)
-                 (let ((lib (extract spec))
-                       (alist (collect spec)))
+      (define-transformer 'define-library
+        (lambda (form _)
+          (let ((name (cadr form))
+                (body (cddr form)))
+            (or (find-library name) (make-library name))
+            (parameterize ((current-library name))
+              (for-each
+               (lambda (expr)
+                 (let ((exprs (if (and (pair? expr) (eq? (car expr) 'begin))
+                                  (cdr expr)
+                                  (list expr)))
+                       (env (library-environment name)))
                    (for-each
-                    (lambda (slot)
-                      (library-import lib (cdr slot) (car slot)))
-                    alist)))))
-          (for-each import (cdr form)))))))
+                    (lambda (e) (eval e env))
+                    exprs)))
+               body)))))
 
-(define-macro export
-  (lambda (form _)
-    (letrec
-        ((collect
-          (lambda (spec)
-            (cond
-             ((symbol? spec)
-              `(,spec . ,spec))
-             ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))
-              `(,(list-ref spec 1) . ,(list-ref spec 2)))
-             (else
-              (error "malformed export")))))
-         (export
-           (lambda (spec)
-             (let ((slot (collect spec)))
-               (library-export (car slot) (cdr slot))))))
-      (for-each export (cdr form)))))
+      (define-transformer 'cond-expand
+        (lambda (form _)
+          (letrec
+              ((test (lambda (form)
+                       (or
+                        (eq? form 'else)
+                        (and (symbol? form)
+                             (memq form (features)))
+                        (and (pair? form)
+                             (case (car form)
+                               ((library) (find-library (cadr form)))
+                               ((not) (not (test (cadr form))))
+                               ((and) (let loop ((form (cdr form)))
+                                        (or (null? form)
+                                            (and (test (car form)) (loop (cdr form))))))
+                               ((or) (let loop ((form (cdr form)))
+                                       (and (pair? form)
+                                            (or (test (car form)) (loop (cdr form))))))
+                               (else #f)))))))
+            (let loop ((clauses (cdr form)))
+              (if (null? clauses)
+                  #undefined
+                  (if (test (caar clauses))
+                      `(,(make-identifier 'begin (default-environment)) ,@(cdar clauses))
+                      (loop (cdr clauses))))))))
+
+      (define-transformer 'import
+        (lambda (form _)
+          (let ((caddr
+                 (lambda (x) (car (cdr (cdr x)))))
+                (prefix
+                 (lambda (prefix symbol)
+                   (string->symbol
+                    (string-append
+                     (symbol->string prefix)
+                     (symbol->string symbol)))))
+                (getlib
+                 (lambda (name)
+                   (if (find-library name)
+                       name
+                       (error "library not found" name)))))
+            (letrec
+                ((extract
+                  (lambda (spec)
+                    (case (car spec)
+                      ((only rename prefix except)
+                       (extract (cadr spec)))
+                      (else
+                       (getlib spec)))))
+                 (collect
+                  (lambda (spec)
+                    (case (car spec)
+                      ((only)
+                       (let ((alist (collect (cadr spec))))
+                         (map (lambda (var) (assq var alist)) (cddr spec))))
+                      ((rename)
+                       (let ((alist (collect (cadr spec)))
+                             (renames (map (lambda (x) `(,(car x) . ,(cadr x))) (cddr spec))))
+                         (map (lambda (s) (or (assq (car s) renames) s)) alist)))
+                      ((prefix)
+                       (let ((alist (collect (cadr spec))))
+                         (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))
+                      ((except)
+                       (let ((alist (collect (cadr spec))))
+                         (let loop ((alist alist))
+                           (if (null? alist)
+                               '()
+                               (if (memq (caar alist) (cddr spec))
+                                   (loop (cdr alist))
+                                   (cons (car alist) (loop (cdr alist))))))))
+                      (else
+                       (dictionary-map (lambda (x) (cons x x))
+                                       (library-exports (getlib spec))))))))
+              (letrec
+                  ((import
+                     (lambda (spec)
+                       (let ((lib (extract spec))
+                             (alist (collect spec)))
+                         (for-each
+                          (lambda (slot)
+                            (library-import lib (cdr slot) (car slot)))
+                          alist)))))
+                (for-each import (cdr form)))))))
+
+      (define-transformer 'export
+        (lambda (form _)
+          (letrec
+              ((collect
+                (lambda (spec)
+                  (cond
+                   ((symbol? spec)
+                    `(,spec . ,spec))
+                   ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))
+                    `(,(list-ref spec 1) . ,(list-ref spec 2)))
+                   (else
+                    (error "malformed export")))))
+               (export
+                 (lambda (spec)
+                   (let ((slot (collect spec)))
+                     (library-export (car slot) (cdr slot))))))
+            (for-each export (cdr form))))))
 
 
-;;; bootstrap...
-(let ()
-  (make-library '(picrin base))
-  (set-car! (dictionary-ref *libraries* (mangle '(picrin base))) default-environment)
-  (let ((export-keywords
-         (lambda (keywords)
-           (let ((env (library-environment '(picrin base)))
-                 (exports (library-exports '(picrin base))))
-             (for-each
+    ;; bootstrap...
+
+    (let ()
+      (make-library '(picrin base))
+      (set-car! (dictionary-ref *libraries* (mangle '(picrin base))) (default-environment))
+      (let* ((exports
+              (library-exports '(picrin base)))
+             (export-keyword
               (lambda (keyword)
-                (dictionary-set! exports keyword keyword))
-              keywords)))))
-    (export-keywords
-     '(define lambda quote set! if begin define-macro
-        let let* letrec letrec*
-        let-values let*-values define-values
-        quasiquote unquote unquote-splicing
-        and or
-        cond case else =>
-        do when unless
-        parameterize
-        define-syntax
-        syntax-quote syntax-unquote
-        syntax-quasiquote syntax-unquote-splicing
-        let-syntax letrec-syntax
-        syntax-error))
-    (export-keywords
-     '(features
-       eq? eqv? equal? not boolean? boolean=?
-       pair? cons car cdr null? set-car! set-cdr!
-       caar cadr cdar cddr
-       list? make-list list length append reverse
-       list-tail list-ref list-set! list-copy
-       map for-each memq memv member assq assv assoc
-       current-input-port current-output-port current-error-port
-       port? input-port? output-port? port-open? close-port
-       eof-object? eof-object
-       read-u8 peek-u8 read-bytevector!
-       write-u8 write-bytevector flush-output-port
-       open-input-bytevector open-output-bytevector get-output-bytevector
-       number? exact? inexact? inexact exact
-       = < > <= >= + - * /
-       number->string string->number
-       procedure? apply
-       symbol? symbol=? symbol->string string->symbol
-       make-identifier identifier? identifier=? identifier-base identifier-environment
-       vector? vector make-vector vector-length vector-ref vector-set!
-       vector-copy! vector-copy vector-append vector-fill! vector-map vector-for-each
-       list->vector vector->list string->vector vector->string
-       bytevector? bytevector make-bytevector
-       bytevector-length bytevector-u8-ref bytevector-u8-set!
-       bytevector-copy! bytevector-copy bytevector-append
-       bytevector->list list->bytevector
-       call-with-current-continuation call/cc values call-with-values
-       char? char->integer integer->char char=? char<? char>? char<=? char>=?
-       current-exception-handlers with-exception-handler
-       raise raise-continuable error
-       error-object? error-object-message error-object-irritants
-       error-object-type
-       string? string make-string string-length string-ref string-set!
-       string-copy string-copy! string-fill! string-append
-       string-map string-for-each list->string string->list
-       string=? string<? string>? string<=? string>=?
-       make-parameter with-dynamic-environment
-       read
-       make-dictionary dictionary? dictionary dictionary-has?
-       dictionary-ref dictionary-set! dictionary-delete! dictionary-size
-       dictionary-map dictionary-for-each
-       dictionary->alist alist->dictionary dictionary->plist plist->dictionary
-       make-record record? record-type record-datum
-       default-environment make-environment find-identifier set-identifier!
-       eval
-       make-ephemeron-table
-       write write-simple write-shared display))
-    (export-keywords
-     '(find-library make-library current-library)))
-  (set! eval
-        (let ((e eval))
-          (lambda (expr . lib)
-            (let ((lib (if (null? lib) (current-library) (car lib))))
-              (e expr (library-environment lib))))))
-  (make-library '(picrin user))
-  (current-library '(picrin user)))
+                (dictionary-set! exports keyword keyword))))
+        (for-each export-keyword
+                  '(define lambda quote set! if begin define-macro
+                     let let* letrec letrec*
+                     let-values let*-values define-values
+                     quasiquote unquote unquote-splicing
+                     and or
+                     cond case else =>
+                     do when unless
+                     parameterize define-record-type include))
+        (dictionary-for-each export-keyword (global-objects)))
+      (make-library '(picrin user)))
 
+    (values current-library
+            find-library
+            make-library
+            library-environment
+            library-exports
+            library-import
+            library-export)))

src/main.c

@@ -8,9 +8,11 @@
 void
 pic_init_picrin(pic_state *pic)
 {
+  void pic_init_lib(pic_state *);
   void pic_init_contrib(pic_state *);
   void pic_load_piclib(pic_state *);
 
+  pic_init_lib(pic);
   pic_init_contrib(pic);
   pic_load_piclib(pic);
 }
@@ -26,7 +28,7 @@ main(int argc, char *argv[], char **envp)
   pic_value e;
   int status;
 
-  pic = pic_open(pic_default_allocf, NULL);
+  pic = pic_open(pic_default_allocf, NULL, pic_default_panicf);
 
   picrin_argc = argc;
   picrin_argv = argv;
@@ -40,7 +42,7 @@ main(int argc, char *argv[], char **envp)
     status = 0;
   }
   pic_catch(e) {
-    pic_print_error(pic, pic_stderr(pic), e);
+    pic_funcall(pic, "display", 2, e, pic_stderr(pic));
     status = 1;
   }
 

tools/mkboot.scm

@@ -1,68 +0,0 @@
-(import (scheme base)
-        (scheme read)
-        (scheme write))
-
-(define (with-output-to-string thunk)
-  (let ((port (open-output-string)))
-    (parameterize ((current-output-port port))
-      (thunk)
-      (let ((s (get-output-string port)))
-        (close-port port)
-        s))))
-
-(define exprs
-  (let loop ((acc '()))
-    (let ((e (read)))
-      (if (eof-object? e)
-          (reverse acc)
-          (loop (cons e acc))))))
-
-(define text
-  (with-output-to-string
-    (lambda ()
-      (for-each
-       (lambda (e)
-         (write e)
-         (write-string " "))
-       exprs))))
-
-(define (escape-string s)
-  (with-output-to-string
-    (lambda ()
-      (string-for-each
-       (lambda (c)
-         (case c
-           ((#\\) (write-string "\\\\"))
-           ((#\") (write-string "\\\""))
-           ((#\newline) (write-string "\\n"))
-           (else (write-char c))))
-       s))))
-
-(define (group-string i s)
-  (let loop ((t s) (n (string-length s)) (acc '()))
-    (if (= n 0)
-        (reverse acc)
-        (if (< n i)
-            (loop "" 0 (cons t acc))
-            (loop (string-copy t i) (- n i) (cons (string-copy t 0 i) acc))))))
-
-(define lines (map escape-string (group-string 80 text)))
-
-(for-each
- (lambda (s) (display s) (newline))
- `("#include \"picrin.h\""
-   "#include \"picrin/extra.h\""
-   ""
-   "static const char boot_rom[][80] = {"
-   ,@(let loop ((lines lines) (acc '()))
-       (if (null? lines)
-           (reverse acc)
-           (loop (cdr lines) (cons (string-append "\"" (car lines) "\",") acc))))
-   "};"
-   ""
-   "void"
-   "pic_boot(pic_state *pic)"
-   "{"
-   "  pic_load_cstr(pic, &boot_rom[0][0]);"
-   "}"))
-

tools/mkerror.scm

@@ -0,0 +1,30 @@
+(let ((port (open-input-file "piclib/error.c")))
+  (let loop ()
+    (let ((c (read-u8 port)))
+      (unless (eof-object? c)
+        (write-u8 c)
+        (loop)))))
+
+(for-each
+ display
+ `("\n"
+   "#if PIC_USE_ERROR\n"
+   "static "))
+
+(let loop ()
+  (let ((c (read-u8)))
+    (unless (eof-object? c)
+      (write-u8 c)
+      (loop))))
+
+(for-each
+ display
+ `("#endif\n"
+   "\n"
+   "void\n"
+   "pic_init_error(pic_state *PIC_UNUSED(pic))\n"
+   "{\n"
+   "#if PIC_USE_ERROR\n"
+   "  pic_call(pic, pic_deserialize(pic, pic_blob_value(pic, error_rom, sizeof error_rom)), 0);\n"
+   "#endif\n"
+   "}\n"))

tools/mkeval.scm

@@ -0,0 +1,25 @@
+(for-each
+ display
+ `("#include \"picrin.h\"\n"
+   "#include \"picrin/extra.h\"\n"
+   "\n"
+   "#if PIC_USE_EVAL\n"
+   "static "))
+
+(let loop ()
+  (let ((c (read-u8)))
+    (unless (eof-object? c)
+      (write-u8 c)
+      (loop))))
+
+(for-each
+ display
+ `("#endif\n"
+   "\n"
+   "void\n"
+   "pic_init_eval(pic_state *PIC_UNUSED(pic))\n"
+   "{\n"
+   "#if PIC_USE_EVAL\n"
+   "  pic_call(pic, pic_deserialize(pic, pic_blob_value(pic, eval_rom, sizeof eval_rom)), 0);\n"
+   "#endif\n"
+   "}\n"))

tools/mkinit.pl

@@ -18,13 +18,13 @@ pic_init_contrib(pic_state *pic)
 EOL
 
 foreach my $lib (@ARGV) {
-    print "  void pic_init_$lib(pic_state *);\n";
+    print "  void pic_nitro_init_$lib(pic_state *);\n";
 }
 
 print;
 
 foreach my $lib (@ARGV) {
-    print "  pic_init_$lib(pic);\n";
+    print "  pic_nitro_init_$lib(pic);\n";
 }
 
 print <<EOL;

tools/mklib.scm

@@ -0,0 +1,21 @@
+(for-each
+ display
+ `("#include \"picrin.h\"\n"
+   "#include \"picrin/extra.h\"\n"
+   "\n"
+   "static "))
+
+(let loop ()
+  (let ((c (read-u8)))
+    (unless (eof-object? c)
+      (write-u8 c)
+      (loop))))
+
+(for-each
+ display
+ `("\n"
+   "void\n"
+   "pic_init_lib(pic_state *PIC_UNUSED(pic))\n"
+   "{\n"
+   "  pic_call(pic, pic_deserialize(pic, pic_blob_value(pic, lib_rom, sizeof lib_rom)), 0);\n"
+   "}\n"))

tools/mkloader.pl

@@ -14,6 +14,31 @@ print <<EOL;
 #include "picrin.h"
 #include "picrin/extra.h"
 
+void
+pic_eval_native(pic_state *pic, const char *str)
+{
+  size_t ai = pic_enter(pic);
+  pic_value port = pic_fmemopen(pic, str, strlen(str), "r"), e;
+
+  pic_try {
+    size_t ai = pic_enter(pic);
+
+    while (1) {
+      pic_value form = pic_funcall(pic, "read", 1, port);
+      if (pic_eof_p(pic, form))
+        break;
+      pic_funcall(pic, "eval", 1, form);
+      pic_leave(pic, ai);
+    }
+  }
+  pic_catch (e) {
+    pic_fclose(pic, port);
+    pic_raise(pic, e);
+  }
+  pic_fclose(pic, port);
+  pic_leave(pic, ai);
+}
+
 EOL
 
 foreach my $file (@ARGV) {
@@ -50,7 +75,7 @@ EOL
     my $var = &escape_v($file);
     my $basename = basename($file);
     my $dirname = basename(dirname($file));
-    print "    pic_load_cstr(pic, &${var}[0][0]);\n";
+    print "    pic_eval_native(pic, &${var}[0][0]);\n";
     print<<EOL
   }
   pic_catch(e) {