Merge branch 'master' into bench

.travis.yml

@@ -1,16 +1,20 @@
+sudo: false
 language: c
 compiler:
   - gcc
   - clang
+addons:
+  apt:
+    packages:
+      - gcc-multilib
+#     - valgrind
 env:
   - CFLAGS="-m32"
   - CFLAGS="-m64"
-before_script:
-  - sudo apt-get update -qq
-  - sudo apt-get install -y libc6:i386 libgcc1:i386 gcc-4.6-base:i386 gcc-multilib
 script:
   - perl --version
   - make test
+# - make test-contrib TEST_RUNNER="valgrind -q --leak-check=full --dsymutil=yes --error-exitcode=1 bin/picrin"
   - make clean
   - make debug
-  - make test 2> /dev/null >/dev/null
+  - make test

Makefile

@@ -7,15 +7,6 @@ PICRIN_SRCS = \
 	src/init_contrib.c
 PICRIN_OBJS = \
 	$(PICRIN_SRCS:.c=.o)
-PICRIN_LIBS = \
-	piclib/picrin/base.scm\
-	piclib/picrin/macro.scm\
-	piclib/picrin/record.scm\
-	piclib/picrin/array.scm\
-	piclib/picrin/control.scm\
-	piclib/picrin/experimental/lambda.scm\
-	piclib/picrin/syntax-rules.scm\
-	piclib/picrin/test.scm
 
 CONTRIB_SRCS =
 CONTRIB_OBJS = $(CONTRIB_SRCS:.c=.o)
@@ -24,24 +15,26 @@ CONTRIB_INITS =
 CONTRIB_TESTS =
 CONTRIB_DOCS = $(wildcard contrib/*/docs/*.rst)
 
+TEST_RUNNER = bin/picrin
+
 CFLAGS += -I./extlib/benz/include -Wall -Wextra
 LDFLAGS += -lm
 
 prefix = /usr/local
 
-all: CFLAGS += -O2
+all: CFLAGS += -O2 -DNDEBUG=1
 all: bin/picrin
 
-include $(sort $(wildcard contrib/*/nitro.mk))
-
 debug: CFLAGS += -O0 -g
 debug: bin/picrin
 
+include $(sort $(wildcard contrib/*/nitro.mk))
+
 bin/picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a
 	$(CC) $(CFLAGS) -o $@ $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a $(LDFLAGS)
 
-src/load_piclib.c: $(PICRIN_LIBS) $(CONTRIB_LIBS)
-	perl etc/mkloader.pl $(PICRIN_LIBS) $(CONTRIB_LIBS) > $@
+src/load_piclib.c: $(CONTRIB_LIBS)
+	perl etc/mkloader.pl $(CONTRIB_LIBS) > $@
 
 src/init_contrib.c:
 	perl etc/mkinit.pl $(CONTRIB_INITS) > $@
@@ -74,7 +67,7 @@ test: test-contribs test-nostdlib
 test-contribs: bin/picrin $(CONTRIB_TESTS)
 
 test-nostdlib:
-	$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0' -D'PIC_ENABLE_STDIO=0' -nostdlib -fPIC -shared -std=c89 -ansi -pedantic -Wall -Wextra -o lib/libbenz.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector
+	$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0' -D'PIC_ENABLE_STDIO=0' -ffreestanding -nostdlib -fPIC -shared -std=c89 -pedantic -Wall -Wextra -Werror -o lib/libbenz.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector
 	rm -f lib/libbenz.so
 
 install: all

contrib/10.callcc/callcc.c

@@ -258,10 +258,13 @@ pic_callcc_full(pic_state *pic, struct pic_proc *proc)
 }
 
 static pic_value
-pic_callcc_full_trampoline(pic_state *pic, struct pic_proc *proc)
+pic_callcc_callcc(pic_state *pic)
 {
+  struct pic_proc *proc;
   struct pic_fullcont *cont;
 
+  pic_get_args(pic, "l", &proc);
+
   save_cont(pic, &cont);
   if (setjmp(cont->jmp)) {
     return pic_values_by_list(pic, cont->results);
@@ -277,20 +280,10 @@ pic_callcc_full_trampoline(pic_state *pic, struct pic_proc *proc)
     /* save the continuation object in proc */
     pic_proc_env_set(pic, c, "cont", pic_obj_value(dat));
 
-    return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c)));
+    return pic_apply_trampoline_list(pic, proc, pic_list1(pic, pic_obj_value(c)));
   }
 }
 
-static pic_value
-pic_callcc_callcc(pic_state *pic)
-{
-  struct pic_proc *cb;
-
-  pic_get_args(pic, "l", &cb);
-
-  return pic_callcc_full_trampoline(pic, cb);
-}
-
 #define pic_redefun(pic, lib, name, func)       \
   pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func)))
 

contrib/10.macro/macro.scm

@@ -44,11 +44,11 @@
         ((wrap (let ((register (make-register)))
                  (lambda (var)
                    (let ((id (register var)))
-                     (if (undefined? id)
+                     (if id
+                         (cdr id)
                          (let ((id (make-identifier var env)))
                            (register var id)
-                           id)
-                         id)))))
+                           id))))))
          (walk (lambda (f form)
                  (cond
                   ((variable? form)
@@ -106,11 +106,11 @@
           ((rename (let ((register (make-register)))
                      (lambda (var)
                        (let ((id (register var)))
-                         (if (undefined? id)
+                         (if id
+                             (cdr id)
                              (let ((id (make-identifier var mac-env)))
                                (register var id)
-                               id)
-                             id)))))
+                               id))))))
            (compare (lambda (x y)
                       (variable=?
                        (make-identifier x use-env)
@@ -124,25 +124,25 @@
         (letrec
             ((inject (lambda (var1)
                        (let ((var2 (register1 var1)))
-                         (if (undefined? var2)
+                         (if var2
+                             (cdr var2)
                              (let ((var2 (make-identifier var1 use-env)))
                                (register1 var1 var2)
                                (register2 var2 var1)
-                               var2)
-                             var2))))
+                               var2)))))
              (rename (let ((register (make-register)))
                        (lambda (var)
                          (let ((id (register var)))
-                           (if (undefined? id)
+                           (if id
+                               (cdr id)
                                (let ((id (make-identifier var mac-env)))
                                  (register var id)
-                                 id)
-                               id)))))
+                                 id))))))
              (flip (lambda (var2) ; unwrap if injected, wrap if not injected
                      (let ((var1 (register2 var2)))
-                       (if (undefined? var1)
-                           (rename var2)
-                           var1))))
+                       (if var1
+                           (cdr var1)
+                           (rename var2)))))
              (walk (lambda (f form)
                      (cond
                       ((variable? form)

contrib/10.macro/nitro.mk

@@ -0,0 +1,6 @@
+CONTRIB_LIBS += $(wildcard contrib/10.macro/*.scm)
+
+CONTRIB_TESTS += test-macro
+
+test-macro: bin/picrin
+	$(TEST_RUNNER) contrib/10.macro/t/ir-macro.scm

contrib/10.math/math.c

@@ -0,0 +1,310 @@
+#include "picrin.h"
+
+#include <math.h>
+
+static pic_value
+pic_number_floor2(pic_state *pic)
+{
+  int i, j;
+  bool e1, e2;
+
+  pic_get_args(pic, "II", &i, &e1, &j, &e2);
+
+  if (e1 && e2) {
+    int k;
+
+    k = (i < 0 && j < 0) || (0 <= i && 0 <= j)
+      ? i / j
+      : (i / j) - 1;
+
+    return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j));
+  } else {
+    double q, r;
+
+    q = floor((double)i/j);
+    r = i - j * q;
+    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
+  }
+}
+
+static pic_value
+pic_number_trunc2(pic_state *pic)
+{
+  int i, j;
+  bool e1, e2;
+
+  pic_get_args(pic, "II", &i, &e1, &j, &e2);
+
+  if (e1 && e2) {
+    return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j));
+  } else {
+    double q, r;
+
+    q = trunc((double)i/j);
+    r = i - j * q;
+
+    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
+  }
+}
+
+static pic_value
+pic_number_floor(pic_state *pic)
+{
+  double f;
+  bool e;
+
+  pic_get_args(pic, "F", &f, &e);
+
+  if (e) {
+    return pic_int_value((int)f);
+  } else {
+    return pic_float_value(floor(f));
+  }
+}
+
+static pic_value
+pic_number_ceil(pic_state *pic)
+{
+  double f;
+  bool e;
+
+  pic_get_args(pic, "F", &f, &e);
+
+  if (e) {
+    return pic_int_value((int)f);
+  } else {
+    return pic_float_value(ceil(f));
+  }
+}
+
+static pic_value
+pic_number_trunc(pic_state *pic)
+{
+  double f;
+  bool e;
+
+  pic_get_args(pic, "F", &f, &e);
+
+  if (e) {
+    return pic_int_value((int)f);
+  } else {
+    return pic_float_value(trunc(f));
+  }
+}
+
+static pic_value
+pic_number_round(pic_state *pic)
+{
+  double f;
+  bool e;
+
+  pic_get_args(pic, "F", &f, &e);
+
+  if (e) {
+    return pic_int_value((int)f);
+  } else {
+    return pic_float_value(round(f));
+  }
+}
+
+static pic_value
+pic_number_finite_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  if (pic_int_p(v))
+    return pic_true_value();
+  if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v))))
+    return pic_true_value();
+  else
+    return pic_false_value();
+}
+
+static pic_value
+pic_number_infinite_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  if (pic_float_p(v) && isinf(pic_float(v)))
+    return pic_true_value();
+  else
+    return pic_false_value();
+}
+
+static pic_value
+pic_number_nan_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  if (pic_float_p(v) && isnan(pic_float(v)))
+    return pic_true_value();
+  else
+    return pic_false_value();
+}
+
+static pic_value
+pic_number_exp(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+  return pic_float_value(exp(f));
+}
+
+static pic_value
+pic_number_log(pic_state *pic)
+{
+  double f,g;
+  int argc;
+
+  argc = pic_get_args(pic, "f|f", &f, &g);
+  if (argc == 1) {
+    return pic_float_value(log(f));
+  }
+  else {
+    return pic_float_value(log(f) / log(g));
+  }
+}
+
+static pic_value
+pic_number_sin(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+  f = sin(f);
+  return pic_float_value(f);
+}
+
+static pic_value
+pic_number_cos(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+  f = cos(f);
+  return pic_float_value(f);
+}
+
+static pic_value
+pic_number_tan(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+  f = tan(f);
+  return pic_float_value(f);
+}
+
+static pic_value
+pic_number_acos(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+  f = acos(f);
+  return pic_float_value(f);
+}
+
+static pic_value
+pic_number_asin(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+  f = asin(f);
+  return pic_float_value(f);
+}
+
+static pic_value
+pic_number_atan(pic_state *pic)
+{
+  double f,g;
+  int argc;
+
+  argc = pic_get_args(pic, "f|f", &f, &g);
+  if (argc == 1) {
+    f = atan(f);
+    return pic_float_value(f);
+  }
+  else {
+    return pic_float_value(atan2(f,g));
+  }
+}
+
+static pic_value
+pic_number_sqrt(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+
+  return pic_float_value(sqrt(f));
+}
+
+static pic_value
+pic_number_abs(pic_state *pic)
+{
+  double f;
+  bool e;
+
+  pic_get_args(pic, "F", &f, &e);
+
+  if (e) {
+    return pic_int_value(f < 0 ? -f : f);
+  }
+  else {
+    return pic_float_value(fabs(f));
+  }
+}
+
+static pic_value
+pic_number_expt(pic_state *pic)
+{
+  double f, g, h;
+  bool e1, e2;
+
+  pic_get_args(pic, "FF", &f, &e1, &g, &e2);
+
+  h = pow(f, g);
+  if (e1 && e2) {
+    if (h <= INT_MAX) {
+      return pic_int_value((int)h);
+    }
+  }
+  return pic_float_value(h);
+}
+
+void
+pic_init_math(pic_state *pic)
+{
+  pic_deflibrary (pic, "(picrin math)") {
+    pic_defun(pic, "floor/", pic_number_floor2);
+    pic_defun(pic, "truncate/", pic_number_trunc2);
+    pic_defun(pic, "floor", pic_number_floor);
+    pic_defun(pic, "ceiling", pic_number_ceil);
+    pic_defun(pic, "truncate", pic_number_trunc);
+    pic_defun(pic, "round", pic_number_round);
+
+    pic_defun(pic, "finite?", pic_number_finite_p);
+    pic_defun(pic, "infinite?", pic_number_infinite_p);
+    pic_defun(pic, "nan?", pic_number_nan_p);
+    pic_defun(pic, "sqrt", pic_number_sqrt);
+    pic_defun(pic, "exp", pic_number_exp);
+    pic_defun(pic, "log", pic_number_log);
+    pic_defun(pic, "sin", pic_number_sin);
+    pic_defun(pic, "cos", pic_number_cos);
+    pic_defun(pic, "tan", pic_number_tan);
+    pic_defun(pic, "acos", pic_number_acos);
+    pic_defun(pic, "asin", pic_number_asin);
+    pic_defun(pic, "atan", pic_number_atan);
+    pic_defun(pic, "abs", pic_number_abs);
+    pic_defun(pic, "expt", pic_number_expt);
+  }
+}

contrib/10.math/nitro.mk

@@ -0,0 +1,3 @@
+CONTRIB_INITS += math
+
+CONTRIB_SRCS += contrib/10.math/math.c

contrib/20.r7rs/nitro.mk

@@ -27,5 +27,5 @@ CONTRIB_TESTS += test-r7rs
 
 test-r7rs: bin/picrin
 	for test in `ls contrib/20.r7rs/t/*.scm`; do \
-	  bin/picrin "$$test"; \
+	  $(TEST_RUNNER) "$$test"; \
 	done

contrib/20.r7rs/scheme/base.scm

@@ -1,8 +1,18 @@
 (define-library (scheme base)
   (import (picrin base)
+          (only (picrin math)
+                abs
+                expt
+                floor/
+                truncate/
+                floor
+                ceiling
+                truncate
+                round
+                sqrt
+                nan?
+                infinite?)
           (picrin macro)
-          (picrin record)
-          (picrin syntax-rules)
           (picrin string)
           (scheme file))
 
@@ -76,63 +86,57 @@
 
   ;; 4.2.7. Exception handling
 
-  (define-syntax guard-aux
-    (syntax-rules (else =>)
-      ((guard-aux reraise (else result1 result2 ...))
-       (begin result1 result2 ...))
-      ((guard-aux reraise (test => result))
-       (let ((temp test))
-         (if temp
-             (result temp)
-             reraise)))
-      ((guard-aux reraise (test => result)
-                  clause1 clause2 ...)
-       (let ((temp test))
-         (if temp
-             (result temp)
-             (guard-aux reraise clause1 clause2 ...))))
-      ((guard-aux reraise (test))
-       (or test reraise))
-      ((guard-aux reraise (test) clause1 clause2 ...)
-       (let ((temp test))
-         (if temp
-             temp
-             (guard-aux reraise clause1 clause2 ...))))
-      ((guard-aux reraise (test result1 result2 ...))
-       (if test
-           (begin result1 result2 ...)
-           reraise))
-      ((guard-aux reraise
-                  (test result1 result2 ...)
-                  clause1 clause2 ...)
-       (if test
-           (begin result1 result2 ...)
-           (guard-aux reraise clause1 clause2 ...)))))
+  (define-syntax (guard-aux reraise . clauses)
+    (letrec
+        ((else?
+          (lambda (clause)
+            (and (list? clause) (equal? #'else (car clause)))))
+         (=>?
+          (lambda (clause)
+            (and (list? clause) (= (length clause) 3) (equal? #'=> (list-ref clause 1))))))
+      (if (null? clauses)
+          reraise
+          (let ((clause (car clauses))
+                (rest (cdr clauses)))
+            (cond
+             ((else? clause)
+              #`(begin #,@(cdr clause)))
+             ((=>? clause)
+              #`(let ((tmp #,(list-ref clause 0)))
+                  (if tmp
+                      (#,(list-ref clause 2) tmp)
+                      (guard-aux #,reraise #,@rest))))
+             ((= (length clause) 1)
+              #`(or #,(car clause) (guard-aux #,reraise #,@rest)))
+             (else
+              #`(if #,(car clause)
+                    (begin #,@(cdr clause))
+                    (guard-aux #,reraise #,@rest))))))))
 
-  (define-syntax guard
-    (syntax-rules ()
-      ((guard (var clause ...) e1 e2 ...)
-       ((call/cc
-         (lambda (guard-k)
-           (with-exception-handler
-            (lambda (condition)
-              ((call/cc
-                (lambda (handler-k)
-                  (guard-k
-                   (lambda ()
-                     (let ((var condition))
-                       (guard-aux
-                        (handler-k
-                         (lambda ()
-                           (raise-continuable condition)))
-                        clause ...))))))))
-            (lambda ()
-              (call-with-values
-                  (lambda () e1 e2 ...)
-                (lambda args
-                  (guard-k
-                   (lambda ()
-                     (apply values args)))))))))))))
+  (define-syntax (guard formal . body)
+    (let ((var (car formal))
+          (clauses (cdr formal)))
+      #`((call/cc
+          (lambda (guard-k)
+            (with-exception-handler
+             (lambda (condition)
+               ((call/cc
+                 (lambda (handler-k)
+                   (guard-k
+                    (lambda ()
+                      (let ((#,var condition))
+                        (guard-aux
+                         (handler-k
+                          (lambda ()
+                            (raise-continuable condition)))
+                         #,@clauses))))))))
+             (lambda ()
+               (call-with-values
+                   (lambda () #,@body)
+                 (lambda args
+                   (guard-k
+                    (lambda ()
+                      (apply values args))))))))))))
 
   (export guard)
 
@@ -149,6 +153,243 @@
 
   ;; 4.3.2 Pattern language
 
+  (define (succ n)
+    (+ n 1))
+
+  (define (pred n)
+    (if (= n 0)
+        0
+        (- n 1)))
+
+  (define (every? args)
+    (if (null? args)
+        #t
+        (if (car args)
+            (every? (cdr args))
+            #f)))
+
+  (define (filter f list)
+    (if (null? list)
+        '()
+        (if (f (car list))
+            (cons (car list)
+                  (filter f (cdr list)))
+            (filter f (cdr list)))))
+
+  (define (take-tail n list)
+    (let drop ((n (- (length list) n)) (list list))
+      (if (= n 0)
+          list
+          (drop (- n 1) (cdr list)))))
+
+  (define (drop-tail n list)
+    (let take ((n (- (length list) n)) (list list))
+      (if (= n 0)
+          '()
+          (cons (car list) (take (- n 1) (cdr list))))))
+
+  (define (map-keys f assoc)
+    (map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
+
+  (define (map-values f assoc)
+    (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
+
+  ;; TODO
+  ;; - placeholder
+  ;; - vector
+  ;; - (... template) pattern
+
+  ;; p ::= constant
+  ;;     | var
+  ;;     | (p ... . p)      (in input pattern, tail p should be a proper list)
+  ;;     | (p . p)
+
+  (define (compile ellipsis literals rules)
+
+    (define (constant? obj)
+      (and (not (pair? obj))
+           (not (variable? obj))))
+
+    (define (literal? obj)
+      (and (variable? obj)
+           (memq obj literals)))
+
+    (define (many? pat)
+      (and (pair? pat)
+           (pair? (cdr pat))
+           (variable? (cadr pat))
+           (variable=? (cadr pat) ellipsis)))
+
+    (define (pattern-validator pat)      ; pattern -> validator
+      (letrec
+          ((pattern-validator
+            (lambda (pat form)
+              (cond
+               ((constant? pat)
+                #`(equal? '#,pat #,form))
+               ((literal? pat)
+                #`(and (variable? #,form) (variable=? #'#,pat #,form)))
+               ((variable? pat)
+                #t)
+               ((many? pat)
+                (let ((head #`(drop-tail #,(length (cddr pat)) #,form))
+                      (tail #`(take-tail #,(length (cddr pat)) #,form)))
+                  #`(and (list? #,form)
+                         (>= (length #,form) #,(length (cddr pat)))
+                         (every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head))
+                         #,(pattern-validator (cddr pat) tail))))
+               ((pair? pat)
+                #`(and (pair? #,form)
+                       #,(pattern-validator (car pat) #`(car #,form))
+                       #,(pattern-validator (cdr pat) #`(cdr #,form))))
+               (else
+                #f)))))
+        (pattern-validator pat 'it)))
+
+    (define (pattern-variables pat)       ; pattern -> (freevar)
+      (cond
+       ((constant? pat)
+        '())
+       ((literal? pat)
+        '())
+       ((variable? pat)
+        `(,pat))
+       ((many? pat)
+        (append (pattern-variables (car pat))
+                (pattern-variables (cddr pat))))
+       ((pair? pat)
+        (append (pattern-variables (car pat))
+                (pattern-variables (cdr pat))))))
+
+    (define (pattern-levels pat)          ; pattern -> ((var * int))
+      (cond
+       ((constant? pat)
+        '())
+       ((literal? pat)
+        '())
+       ((variable? pat)
+        `((,pat . 0)))
+       ((many? pat)
+        (append (map-values succ (pattern-levels (car pat)))
+                (pattern-levels (cddr pat))))
+       ((pair? pat)
+        (append (pattern-levels (car pat))
+                (pattern-levels (cdr pat))))))
+
+    (define (pattern-selectors pat)       ; pattern -> ((var * selector))
+      (letrec
+          ((pattern-selectors
+            (lambda (pat form)
+              (cond
+               ((constant? pat)
+                '())
+               ((literal? pat)
+                '())
+               ((variable? pat)
+                `((,pat . ,form)))
+               ((many? pat)
+                (let ((head #`(drop-tail #,(length (cddr pat)) #,form))
+                      (tail #`(take-tail #,(length (cddr pat)) #,form)))
+                  (let ((envs (pattern-selectors (car pat) 'it)))
+                    (append
+                     (map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs)
+                     (pattern-selectors (cddr pat) tail)))))
+               ((pair? pat)
+                (append (pattern-selectors (car pat) #`(car #,form))
+                        (pattern-selectors (cdr pat) #`(cdr #,form))))))))
+        (pattern-selectors pat 'it)))
+
+    (define (template-representation pat levels selectors)
+      (cond
+       ((constant? pat)
+        pat)
+       ((variable? pat)
+        (let ((it (assq pat levels)))
+          (if it
+              (if (= 0 (cdr it))
+                  (cdr (assq pat selectors))
+                  (error "unmatched pattern variable level" pat))
+              #`(#,'rename '#,pat))))
+       ((many? pat)
+        (letrec*
+            ((inner-pat
+              (car pat))
+             (inner-levels
+              (map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels))
+             (inner-freevars
+              (filter (lambda (v) (assq v levels)) (pattern-variables inner-pat)))
+             (inner-vars
+              ;; select only vars declared with ellipsis
+              (filter (lambda (v) (> (cdr (assq v levels)) 0)) inner-freevars))
+             (inner-tmps
+              (map (lambda (v) #'it) inner-vars))
+             (inner-selectors
+              ;; first env '(map cons ...)' shadows second env 'selectors'
+              (append (map cons inner-vars inner-tmps) selectors))
+             (inner-rep
+              (template-representation inner-pat inner-levels inner-selectors))
+             (sorted-selectors
+              (map (lambda (v) (assq v selectors)) inner-vars))
+             (list-of-selectors
+              ;; ((a . xs) (b . ys) (c . zs)) -> (xs ys zs)
+              (map cdr sorted-selectors)))
+          (let ((rep1 #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors))
+                (rep2 (template-representation (cddr pat) levels selectors)))
+            #`(append #,rep1 #,rep2))))
+       ((pair? pat)
+        #`(cons #,(template-representation (car pat) levels selectors)
+                #,(template-representation (cdr pat) levels selectors)))))
+
+    (define (compile-rule pattern template)
+      (let ((levels
+             (pattern-levels pattern))
+            (selectors
+             (pattern-selectors pattern)))
+        (template-representation template levels selectors)))
+
+    (define (compile-rules rules)
+      (if (null? rules)
+          #`(error "unmatch")
+          (let ((pattern (car (car rules)))
+                (template (cadr (car rules))))
+            #`(if #,(pattern-validator pattern)
+                  #,(compile-rule pattern template)
+                  #,(compile-rules (cdr rules))))))
+
+    (define (compile rules)
+      #`(call-with-current-environment
+         (lambda (env)
+           (letrec
+               ((#,'rename (let ((reg (make-register)))
+                             (lambda (x)
+                               (let ((y (reg x)))
+                                 (if y
+                                     (cdr y)
+                                     (let ((id (make-identifier x env)))
+                                       (reg x id)
+                                       id)))))))
+             (lambda #,'it
+               #,(compile-rules rules))))))
+
+    (let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable
+      (compile rules)))
+
+  (define-syntax (syntax-rules . args)
+    (if (list? (car args))
+        #`(syntax-rules ... #,@args)
+        (let ((ellipsis (car args))
+              (literals (car (cdr args)))
+              (rules    (cdr (cdr args))))
+          (compile ellipsis literals rules))))
+
+  (define-syntax (define-auxiliary-syntax var)
+    #`(define-macro #,var
+        (lambda _
+          (error "invalid use of auxiliary syntax" '#,var))))
+
+  (define-auxiliary-syntax _)
+  (define-auxiliary-syntax ...)
+
   (export syntax-rules
           _
           ...)
@@ -171,6 +412,56 @@
 
   ;; 5.5 Recored-type definitions
 
+  (define ((boot-make-record-type <meta-type>) name)
+    (let ((rectype (make-record <meta-type>)))
+      (record-set! rectype 'name name)
+      rectype))
+
+  (define <record-type>
+    (let ((<record-type> ((boot-make-record-type #t) 'record-type)))
+      (record-set! <record-type> '@@type <record-type>)
+      <record-type>))
+
+  (define make-record-type (boot-make-record-type <record-type>))
+
+  (define-syntax (define-record-constructor type name . fields)
+    (let ((record #'record))
+      #`(define (#,name . #,fields)
+          (let ((#,record (make-record #,type)))
+            #,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
+            #,record))))
+
+  (define-syntax (define-record-predicate type name)
+    #`(define (#,name obj)
+        (and (record? obj)
+             (eq? (record-type obj) #,type))))
+
+  (define-syntax (define-record-accessor pred field accessor)
+    #`(define (#,accessor record)
+        (if (#,pred record)
+            (record-ref record '#,field)
+            (error (string-append (symbol->string  '#,accessor) ": wrong record type") record))))
+
+  (define-syntax (define-record-modifier pred field modifier)
+    #`(define (#,modifier record val)
+        (if (#,pred record)
+            (record-set! record '#,field val)
+            (error (string-append (symbol->string '#,modifier) ": wrong record type")  record))))
+
+  (define-syntax (define-record-field pred field accessor . modifier-opt)
+    (if (null? modifier-opt)
+        #`(define-record-accessor #,pred #,field #,accessor)
+        #`(begin
+            (define-record-accessor #,pred #,field #,accessor)
+            (define-record-modifier #,pred #,field #,(car modifier-opt)))))
+
+  (define-syntax (define-record-type name ctor pred . fields)
+    #`(begin
+        (define #,name (make-record-type '#,name))
+        (define-record-constructor #,name #,@ctor)
+        (define-record-predicate #,name #,pred)
+        #,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
+
   (export define-record-type)
 
   ;; 6.1. Equivalence predicates
@@ -181,6 +472,16 @@
 
   ;; 6.2. Numbers
 
+  (define complex? number?)
+  (define real? number?)
+  (define rational? number?)
+  (define (integer? o)
+    (or (exact? o)
+        (and (inexact? o)
+             (not (nan? o))
+             (not (infinite? o))
+             (= o (floor o)))))
+
   (define (exact-integer? x)
     (and (exact? x)
          (integer? x)))

contrib/20.r7rs/scheme/inexact.scm

@@ -1,5 +1,6 @@
 (define-library (scheme inexact)
-  (import (picrin base))
+  (import (picrin base)
+          (picrin math))
 
   (export acos
           asin

contrib/20.r7rs/scheme/r5rs.scm

@@ -8,7 +8,9 @@
           (scheme lazy)
           (scheme eval)
           (scheme load)
-          (picrin base))
+          (only (picrin base)
+                library-environment
+                find-library))
 
   (define-library (scheme null)
     (import (scheme base))

contrib/20.r7rs/src/file.c

@@ -11,7 +11,7 @@ file_error(pic_state *pic, const char *msg)
 {
   struct pic_error *e;
 
-  e = pic_make_error(pic, pic->sFILE, msg, pic_nil_value());
+  e = pic_make_error(pic, pic_intern(pic, "file"), msg, pic_nil_value());
 
   pic_raise(pic, pic_obj_value(e));
 }

contrib/20.r7rs/src/load.c

@@ -4,27 +4,20 @@
 
 #include "picrin.h"
 
-void
-pic_load(pic_state *pic, const char *filename)
-{
-  struct pic_port *port;
-
-  port = pic_open_file(pic, filename, PIC_PORT_IN | PIC_PORT_TEXT);
-
-  pic_load_port(pic, port);
-
-  pic_close_port(pic, port);
-}
-
 static pic_value
 pic_load_load(pic_state *pic)
 {
   pic_value envid;
   char *fn;
+  struct pic_port *port;
 
   pic_get_args(pic, "z|o", &fn, &envid);
 
-  pic_load(pic, fn);
+  port = pic_open_file(pic, fn, PIC_PORT_IN | PIC_PORT_TEXT);
+
+  pic_load(pic, port);
+
+  pic_close_port(pic, port);
 
   return pic_undef_value();
 }

contrib/20.r7rs/src/mutable-string.c

@@ -4,13 +4,16 @@ void
 pic_str_set(pic_state *pic, pic_str *str, size_t i, char c)
 {
   pic_str *x, *y, *z, *tmp;
+  char buf[1];
 
   if (pic_str_len(str) <= i) {
     pic_errorf(pic, "index out of range %d", i);
   }
 
+  buf[0] = c;
+
   x = pic_str_sub(pic, str, 0, i);
-  y = pic_make_str_fill(pic, 1, c);
+  y = pic_make_str(pic, buf, 1);
   z = pic_str_sub(pic, str, i + 1, pic_str_len(str));
 
   tmp = pic_str_cat(pic, x, pic_str_cat(pic, y, z));

contrib/20.r7rs/t/syntax-rules.scm

@@ -1,8 +1,7 @@
-(import (picrin base)
-        (picrin syntax-rules)
+(import (scheme base)
         (picrin test))
 
-(test-begin)
+(test-begin "syntax-rules")
 
 (define-syntax extract?
   (syntax-rules ()

contrib/30.optional/nitro.mk

@@ -3,5 +3,5 @@ CONTRIB_TESTS += test-optional
 
 test-optional: bin/picrin
 	for test in `ls contrib/30.optional/t/*.scm`; do \
-	  bin/picrin $$test; \
+	  $(TEST_RUNNER) $$test; \
 	done

contrib/30.partcont/piclib/partcont.scm

@@ -27,6 +27,16 @@
                (reset (lambda ()
                         (k v))))))))))
 
-  (export shift
-          reset))
+  (define-syntax reset*
+    (syntax-rules ()
+      ((_ expr ...)
+       (reset (lambda () expr ...)))))
+
+  (define-syntax shift*
+    (syntax-rules ()
+      ((_ k expr ...)
+       (shift (lambda (k) expr ...)))))
+
+  (export (rename shift* shift)
+          (rename reset* reset)))
 

contrib/30.random/nitro.mk

@@ -4,5 +4,5 @@ CONTRIB_TESTS += test-random
 
 test-random: bin/picrin
 	for test in `ls contrib/30.random/t/*.scm`; do \
-	  bin/picrin $$test; \
+	  $(TEST_RUNNER) $$test; \
 	done

contrib/30.readline/nitro.mk

@@ -12,5 +12,5 @@ contrib/src/readline.o: contrib/src/readline.c
 
 test-readline: bin/picrin
 	for test in `ls contrib/30.readline/t/*.scm`; do \
-	  bin/picrin $$test; \
+	  $(TEST_RUNNER) $$test; \
 	done

contrib/30.readline/t/test.scm

@@ -2,7 +2,7 @@
         (picrin readline history)
         (picrin test))
   
-(define testfile "picrin_readline_test_file")
+(define testfile "/tmp/picrin_readline_test_file")
 (test-begin)
 
 (test 0 (history-length))

contrib/30.regexp/nitro.mk

@@ -4,5 +4,5 @@ CONTRIB_TESTS += test-regexp
 
 test-regexp: bin/picrin
 	for test in `ls contrib/30.regexp/t/*.scm`; do \
-	  bin/picrin $$test; \
+	  $(TEST_RUNNER) $$test; \
 	done

contrib/30.test/nitro.mk

@@ -0,0 +1 @@
+CONTRIB_LIBS += $(wildcard contrib/30.test/*.scm)

contrib/30.test/test.scm

@@ -1,6 +1,6 @@
 (define-library (picrin test)
-  (import (picrin base)
-          (picrin syntax-rules))
+  (import (scheme base)
+          (scheme write))
 
   (define test-counter 0)
   (define counter 0)

contrib/40.procedure/nitro.mk

@@ -0,0 +1 @@
+CONTRIB_LIBS += $(wildcard contrib/40.procedure/*.scm)

contrib/40.procedure/procedure.scm

@@ -0,0 +1,25 @@
+(define-library (picrin procedure)
+  (import (scheme base))
+  (export >>
+          <<
+          constant
+          identity)
+
+  (define identity values)
+
+  (define (constant . args)
+    (lambda _
+      (apply values args)))
+
+  (define (>> . fs)
+    (if (null? fs)
+        identity
+        (let ((f (car fs))
+              (g (apply >> (cdr fs))))
+          (lambda args
+            (call-with-values (lambda () (apply f args))
+              (lambda args
+                (apply g args)))))))
+
+  (define (<< . fs)
+    (apply >> (reverse fs))))

contrib/40.srfi/nitro.mk

@@ -1,5 +1,8 @@
-CONTRIB_INITS += socket
+CONTRIB_INITS += \
+	srfi_0 \
+	srfi_106
 CONTRIB_LIBS += \
+	contrib/40.srfi/srfi/0.scm\
 	contrib/40.srfi/srfi/1.scm\
 	contrib/40.srfi/srfi/8.scm\
 	contrib/40.srfi/srfi/17.scm\
@@ -9,10 +12,12 @@ CONTRIB_LIBS += \
 	contrib/40.srfi/srfi/95.scm\
 	contrib/40.srfi/srfi/106.scm\
 	contrib/40.srfi/srfi/111.scm
-CONTRIB_SRCS += contrib/40.srfi/src/106.c
+CONTRIB_SRCS += \
+	contrib/40.srfi/src/0.c\
+	contrib/40.srfi/src/106.c
 CONTRIB_TESTS += test-srfi
 
 test-srfi: bin/picrin
 	for test in `ls contrib/40.srfi/t/*.scm`; do \
-	  bin/picrin "$$test"; \
+	  $(TEST_RUNNER) "$$test"; \
 	done

contrib/40.srfi/src/0.c

@@ -0,0 +1,16 @@
+#include "picrin.h"
+
+void
+pic_init_srfi_0(pic_state *pic)
+{
+    pic_add_feature(pic, "srfi-0");
+    pic_add_feature(pic, "srfi-1");
+    pic_add_feature(pic, "srfi-8");
+    pic_add_feature(pic, "srfi-17");
+    pic_add_feature(pic, "srfi-26");
+    pic_add_feature(pic, "srfi-43");
+    pic_add_feature(pic, "srfi-60");
+    pic_add_feature(pic, "srfi-95");
+    pic_add_feature(pic, "srfi-106");
+    pic_add_feature(pic, "srfi-111");
+}

contrib/40.srfi/src/106.c

@@ -397,7 +397,7 @@ pic_socket_call_with_socket(pic_state *pic)
 }
 
 void
-pic_init_socket(pic_state *pic)
+pic_init_srfi_106(pic_state *pic)
 {
   pic_deflibrary (pic, "(srfi 106)") {
     pic_defun_(pic, "socket?", pic_socket_socket_p);

contrib/40.srfi/srfi/0.scm

@@ -0,0 +1,3 @@
+(define-library (srfi 0)
+  (import (scheme base))
+  (export cond-expand))

contrib/40.srfi/srfi/1.scm

@@ -315,8 +315,7 @@
         (let rec ((clist clist) (cont values))
           (if (null? clist)
               (cont knil)
-              (let ((tail (map cdr clists)))
-                (rec tail (lambda (x) (cont (kons clist x)))))))
+                (rec (cdr clist) (lambda (x) (cont (kons clist x))))))
         (let rec ((clists (cons clist clists)) (cont values))
           (if (every pair? clists)
               (let ((tail (map cdr clists)))
@@ -497,11 +496,11 @@
   (define (any pred clist . clists)
     (if (null? clists)
         (let rec ((clist clist))
-          (if (pair? clist)
+          (and (pair? clist)
               (or (pred (car clist))
                   (rec (cdr clist)))))
         (let rec ((clists (cons clist clists)))
-          (if (every pair? clists)
+          (and (every pair? clists)
               (or (apply pred (map car clists))
                   (rec (map cdr clists)))))))
 
@@ -510,11 +509,11 @@
           (if (null? clists)
               (let rec ((clist clist))
                 (or (null? clist)
-                    (if (pred (car clist))
+                    (and (pred (car clist))
                         (rec (cdr clist)))))
               (let rec ((clists (cons clist clists)))
                 (or (any null? clists)
-                    (if (apply pred (map car clists))
+                    (and (apply pred (map car clists))
                         (rec (map cdr clists))))))))
 
   (define (list-index pred clist . clists)

contrib/40.srfi/srfi/17.scm

@@ -17,9 +17,9 @@
     (letrec ((setter
               (lambda (proc)
                 (let ((setter (dictionary-ref (attribute proc) '@@setter)))
-                  (if (undefined? setter)
-                      (error "no setter found")
-                      setter))))
+                  (if setter
+                      (cdr setter)
+                      (error "no setter found")))))
              (set-setter!
               (lambda (proc setter)
                 (dictionary-set! (attribute proc) '@@setter setter))))

contrib/40.srfi/t/1.scm

@@ -0,0 +1,292 @@
+;; Certain portions of this document -- the specific, marked segments of text
+;; describing the R5RS procedures -- were adapted with permission from the R5RS
+;; report.
+;; 
+;; All other text is copyright (C) Olin Shivers (1998, 1999). All Rights
+;; Reserved.
+;; 
+;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;; of this software and associated documentation files (the "Software"), to
+;; deal in the Software without restriction, including without limitation the
+;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+;; sell copies of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;; 
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;; IN THE SOFTWARE. 
+
+(import (scheme base)
+        (srfi 1)
+        (picrin test))
+
+(test-begin)
+
+(test '(a) (cons 'a '()))
+(test '((a) b c d) (cons '(a) '(b c d)))
+(test '("a" b c) (cons "a" '(b c)))
+(test '(a . 3) (cons 'a 3))
+(test '((a b) . c) (cons '(a b) 'c))
+
+(test '(a 7 c) (list 'a (+ 3 4) 'c))
+(test '() (list))
+
+(test '(a b c) (xcons '(b c) 'a))
+
+; (test '(1 2 3 . 4) (cons* 1 2 3 4))
+; (test 1 (cons* 1))
+
+(test '(c c c c) (make-list 4 'c))
+
+(test '(0 1 2 3) (list-tabulate 4 values))
+
+; TODO: Test list-copy
+
+; (test #0=(z q . #0#) (circular-list 'z 'q))
+
+(test '(0 1 2 3 4) (iota 5))
+(test '(0 -0.1 -0.2 -0.3 -0.4) (iota 5 0 -0.1))
+
+; TODO: Test proper-list?
+; TODO: Test circular-list?
+; TODO: Test dotted-list?
+
+(test #t (pair? '(a . b)))
+(test #t (pair? '(a b c)))
+(test #f (pair? '()))
+(test #f (pair? '#(a b)))
+(test #f (pair? 7))
+(test #f (pair? 'a))
+
+; TODO: Test null?
+; TODO: Test null-list?
+; TODO: Test not-pair?
+
+(test #t (list= eq?))
+(test #t (list= eq? '(a)))
+; TODO: Add non-trivial test cases for list=
+
+(test 'a (car '(a b c)))
+(test '(a) (car '((a) b c d)))
+(test 1 (car '(1 . 2)))
+(test #t (error-object?
+           (guard (exn (else exn))
+             (car '()))))
+
+(test '(b c) (cdr '(a b c)))
+(test '(b c d) (cdr '((a) b c d)))
+(test 2 (cdr '(1 . 2)))
+(test #t (error-object?
+           (guard (exn (else exn))
+             (cdr '()))))
+
+; TODO: Test /c[ad]{2,4}r/
+
+(test 'c (list-ref '(a b c d) 2))
+
+; TODO: Test first, second, ..., tenth
+; TODO: Test car+cdr
+
+(test '(a b) (take '(a b c d e) 2))
+(test '(1 2) (take '(1 2 3 . d) 2))
+(test '(1 2 3) (take '(1 2 3 . d) 3))
+
+(test '(c d e) (drop '(a b c d e) 2))
+(test '(3 . d) (drop '(1 2 3 . d) 2))
+(test 'd (drop '(1 2 3 . d) 3))
+
+(test '(d e) (take-right '(a b c d e) 2))
+; (test '(2 3 . d) (take-right '(1 2 3 . d) 2))
+; (test 'd (take-right '(1 2 3 . d) 0)
+
+(test '(a b c) (drop-right '(a b c d e) 2))
+; (test '(1) (drop-right '(1 2 3 . d) 2))
+; (test '(1 2 3) (drop-right '(1 2 3 . d) 0))
+
+(test '(1 3) (take! (circular-list 1 3 5) 8)) ; implementation dependent behavior
+
+; TODO: Test split-at
+; TODO: Test split-at!
+
+(test 'c (last '(a b c)))
+(test '(c) (last-pair '(a b c)))
+
+; TODO: Test length
+; TODO: Test length+
+
+(test '(x y) (append '(x) '(y)))
+(test '(a b c d) (append '(a) '(b c d)))
+(test '(a (b) (c)) (append '(a (b)) '((c))))
+(test '(a b c . d) (append '(a b) '(c . d)))
+(test 'a (append '() 'a))
+(test '(x y) (append '(x y)))
+(test '() (append))
+
+; TODO: Test append!
+; TODO: Test concatenate
+; TODO: Test concatenate!
+
+(test '(c b a) (reverse '(a b c)))
+(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+
+; TODO: Test reverse!
+; TODO: Test append-reverse
+; TODO: Test append-reverse!
+
+(test '((one 1 odd) (two 2 even) (three 3 odd))
+      (zip '(one two three) 
+           '(1 2 3)
+           '(odd even odd even odd even odd even)))
+(test '((1) (2) (3)) (zip '(1 2 3)))
+(test '((3 #f) (1 #t) (4 #f) (1 #t)) (zip '(3 1 4 1) (circular-list #f #t)))
+
+; TODO: Test /unzip[1-5]/
+
+(test 3 (count even? '(3 1 4 1 5 9 2 5 6)))
+(test 3 (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16)))
+(test 2 (count < '(3 1 4 1) (circular-list 1 10)))
+
+; TODO: Test fold
+; TODO: Test fold-right
+; TODO: Test pair-fold
+
+(test '((a b c) (b c) (c)) (pair-fold-right cons '() '(a b c)))
+
+; TODO: Test reduce
+; TODO: Test reduce-right
+; TODO: Test unfold
+; TODO: unfold-right
+
+(test '(b e h) (map cadr '((a b) (d e) (g h))))
+(test '(1 4 27 256 3125) (map (lambda (n) (expt n n))
+                              '(1 2 3 4 5)))
+(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
+(test '(4 1 5 1) (map + '(3 1 4 1) (circular-list 1 0)))
+
+(test #(0 1 4 9 16)
+      (let ((v (make-vector 5)))
+        (for-each (lambda (i)
+                    (vector-set! v i (* i i)))
+                  '(0 1 2 3 4))
+        v))
+
+; TODO: Test append-map
+; TODO: Test append-map!
+; TODO: Test map!
+; TODO: Test map-in-order
+; TODO: Test pair-for-each
+
+(test '(1 9 49) (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7)))
+
+(test '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4)))
+
+; TODO: Test partition
+
+(test '(7 43) (remove even? '(0 7 8 8 43 -4)))
+
+; TODO: Test filter!
+; TODO: Test partition!
+; TODO: Test remove!
+
+(test 4 (find even? '(3 1 4 1 5 9)))
+
+(test '(-8 -5 0 0) (find-tail even? '(3 1 37 -8 -5 0 0)))
+(test #f (find-tail even? '(3 1 37 -5)))
+
+(test '(2 18) (take-while even? '(2 18 3 10 22 9)))
+
+; TODO: Test take-while!
+
+(test '(3 10 22 9) (drop-while even? '(2 18 3 10 22 9)))
+
+; TODO: Test span
+; TODO: Test span!
+; TODO: Test break
+; TODO: Test break!
+
+(test #t (any integer? '(a 3 b 2.7)))
+(test #f (any integer? '(a 3.1 b 2.7)))
+(test #t (any < '(3 1 4 1 5) '(2 7 1 8 2)))
+
+; TODO: Test every
+
+(test 2 (list-index even? '(3 1 4 1 5 9)))
+; (test 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+; (test #f (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+(test '((a) c) (member (list 'a) '(b (a) c)))
+
+(test '(a b c) (memq 'a '(a b c)))
+(test '(b c) (memq 'b '(a b c)))
+(test #f (memq 'a '(b c d)))
+(test #f (memq (list 'a) '(b (a) c)))
+
+(test '(101 102) (memv 101 '(100 101 102)))
+
+; TODO: Test delete
+; TODO: Test delete!
+
+(test '(a b c z) (delete-duplicates '(a b a c a b c z)))
+(test '((a . 3) (b . 7) (c . 1))
+      (delete-duplicates '((a . 3) (b . 7) (a . 9) (c . 1))
+                         (lambda (x y) (eq? (car x) (car y)))))
+
+; TODO: Test delete-duplicates!
+
+(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) (assq 'a e))
+(test '(b 2) (assq 'b e))
+(test #f (assq 'd e))
+(test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+(test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+
+; TODO: Test alist-cons
+; TODO: Test alist-copy
+; TODO: Test alist-delete
+; TODO: Test alist-delete!
+
+(test #t (lset<= eq? '(a) '(a b a) '(a b c c)))
+(test #t (lset<= eq?))
+(test #t (lset<= eq? '(a)))
+
+(test #t (lset= eq? '(b e a) '(a e b) '(e e b a)))
+(test #t (lset= eq?))
+(test #t (lset= eq? '(a)))
+
+(test '(u o i a b c d c e) (lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u))
+
+(test '(u o i a b c d e) (lset-union eq? '(a b c d e) '(a e i o u)))
+(test '(x a a c) (lset-union eq? '(a a c) '(x a x)))
+(test '() (lset-union eq?))
+(test '(a b c) (lset-union eq? '(a b c)))
+
+(test '(a e) (lset-intersection eq? '(a b c d e) '(a e i o u)))
+(test '(a x a) (lset-intersection eq? '(a x y a) '(x a x z)))
+(test '(a b c) (lset-intersection eq? '(a b c)))
+
+(test '(b c d) (lset-difference eq? '(a b c d e) '(a e i o u)))
+(test '(a b c) (lset-difference eq? '(a b c)))
+
+(test '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u)))
+(test '() (lset-xor eq?))
+(test '(a b c d e) (lset-xor eq? '(a b c d e)))
+
+; TODO: Test lset-diff+intersection
+; TODO: Test lset-union!
+; TODO: Test lset-intersection!
+; TODO: Test lset-difference!
+; TODO: Test lset-xor!
+; TODO: Test lset-diff+intersection!
+; TODO: Test set-car!
+; TODO: Test set-cdr!
+
+(test-end)

contrib/40.srfi/t/106.scm

@@ -2,6 +2,8 @@
         (srfi 106)
         (picrin test))
 
+(test-begin)
+
 ; The number 9600 has no meaning. I just borrowed from Rust.
 (define *test-port* 9600)
 (define (next-test-port)
@@ -70,3 +72,5 @@
 (test *shut-wr* (shutdown-method write))
 (test *shut-rdwr* (shutdown-method read write))
 (test *shut-rdwr* (shutdown-method write read))
+
+(test-end)

contrib/50.destructuring-bind/lambda.scm

@@ -0,0 +1,24 @@
+(define-library (picrin destructuring-bind)
+  (import (picrin base)
+          (picrin macro))
+
+  (define-syntax (destructuring-bind formal value . body)
+    (cond
+     ((variable? formal)
+      #`(let ((#,formal #,value))
+          #,@body))
+     ((pair? formal)
+      #`(let ((value #,value))
+          (destructuring-bind #,(car formal) (car value)
+            (destructuring-bind #,(cdr formal) (cdr value)
+              #,@body))))
+     ((vector? formal)
+      ;; TODO
+      (error "fixme"))
+     (else
+      #`(if (equal? #,value '#,formal)
+            (begin
+              #,@body)
+            (error "match failure" #,value '#,formal)))))
+
+  (export destructuring-bind))

contrib/50.destructuring-bind/nitro.mk

@@ -0,0 +1 @@
+CONTRIB_LIBS += $(wildcard contrib/50.destructuring-bind/*.scm)

contrib/50.for/nitro.mk

@@ -3,5 +3,5 @@ CONTRIB_TESTS += test-for
 
 test-for: bin/picrin
 	for test in `ls contrib/50.for/t/*.scm`; do \
-	  bin/picrin "$$test"; \
+	  $(TEST_RUNNER) "$$test"; \
 	done

contrib/50.for/piclib/for.scm

@@ -2,19 +2,29 @@
   (import (scheme base)
           (picrin control))
 
-  (define-syntax for
+  (define unit list)
+
+  (define (bind m f)
+    (apply append (map f m)))
+
+  (define-syntax reify
     (syntax-rules ()
       ((_ expr)
-       (reset (lambda () expr)))))
+       (reset (unit expr)))))
 
-  (define (in m)
-    (shift (lambda (k)
-             (apply append (map k m)))))
+  (define (reflect m)
+    (shift k (bind m k)))
 
-  (define (yield x)
-    (list x))
+  (define zero '())
 
-  (define (null . x)
-    '())
+  (define plus append)
 
-  (export for in yield null))
+  (export unit
+          bind
+          zero
+          plus
+          reify
+          reflect
+          (rename reify for)
+          (rename reflect in)
+          (rename unit yield)))

contrib/50.for/t/test.scm

@@ -4,18 +4,20 @@
 
 (test '(1 2 3)
       (for
-       (yield (in '(1 2 3)))))
+       (in '(1 2 3))))
 
-(test '((1 a) (1 b) (1 c) (2 a) (2 b) (2 c) (3 a) (3 b) (3 c))
+(test '((1 . a) (1 . b) (1 . c) (2 . a) (2 . b) (2 . c) (3 . a) (3 . b) (3 . c))
       (for
        (let ((n (in '(1 2 3)))
              (c (in '(a b c))))
-         (yield (list n c)))))
+         (cons n c))))
 
-(test '((2 a) (2 b) (2 c))
+(define (fail) (in zero))
+
+(test '((2 . a) (2 . b) (2 . c))
       (for
        (let ((n (in '(1 2 3)))
              (c (in '(a b c))))
          (if (even? n)
-             (yield (list n c))
-             (null)))))
+             (cons n c)
+             (fail)))))

contrib/50.option/nitro.mk

@@ -0,0 +1,7 @@
+CONTRIB_LIBS += $(wildcard contrib/50.option/*.scm)
+CONTRIB_TESTS += test-option
+
+test-option: bin/picrin
+	for test in `ls contrib/50.option/t/*.scm`; do \
+	  $(TEST_RUNNER) "$$test"; \
+	done

contrib/50.option/option.scm

@@ -0,0 +1,22 @@
+(define-library (picrin control option)
+  (import (scheme base)
+          (picrin control)
+          (picrin procedure))
+
+  (define unit identity)
+
+  (define (bind m f)
+    (and m (f m)))
+
+  (define-syntax reify
+    (syntax-rules ()
+      ((_ expr)
+       (reset (unit expr)))))
+
+  (define (reflect m)
+    (shift k (bind m k)))
+
+  (export unit
+          bind
+          reify
+          reflect))

contrib/50.option/t/test.scm

@@ -0,0 +1,27 @@
+(import (picrin base)
+        (picrin test)
+        (picrin control option))
+
+(define phonebook
+  '(("Bob" . "01788 665242")
+    ("Fred" . "01624 556442")
+    ("Alice" . "01889 985333")
+    ("Jane" . "01732 187565")))
+
+(define nums
+  '((one . 1) (two . 2) (three . 3) (four . 19)))
+
+(define num-dict
+  (alist->dictionary nums))
+
+(test '("01889 985333" . 3)
+ (reify
+  (let* ((a (reflect (assoc "Alice" phonebook)))
+         (b (reflect (dictionary-ref num-dict 'three))))
+    (cons (cdr a) (cdr b)))))
+
+(test '#f
+ (reify
+  (let* ((a (reflect (assoc "Alice" phonebook)))
+         (b (reflect (dictionary-ref num-dict 'five))))
+    (cons (cdr a) (cdr b)))))

contrib/60.logic/logic.scm

@@ -0,0 +1,131 @@
+(define-library (picrin logic)
+  (import (scheme base)
+          (picrin control))
+  (export call/fresh
+          disj
+          conj
+          is
+          run-goal
+          run-goal*
+          zero
+          plus
+          unit
+          bind
+          reify
+          reflect)
+
+  (define (assp p alist)
+    (if (null? alist)
+        #f
+        (if (p (caar alist))
+            (car alist)
+            (assp p (cdr alist)))))
+
+  (define (force* $)
+    (if (procedure? $) (force* ($)) $))
+
+  ;; fundation
+
+  (define (var c) (vector c))
+  (define (var? x) (vector? x))
+  (define (var=? x1 x2) (= (vector-ref x1 0) (vector-ref x2 0)))
+
+  (define (subst u s)
+    (let ((pr (and (var? u) (assp (lambda (v) (var=? u v)) s))))
+      (if pr (subst (cdr pr) s) u)))
+
+  (define (subst* v s)
+    (let ((v (subst v s)))
+      (cond
+       ((var? v) v)
+       ((pair? v) (cons (subst* (car v) s)
+                        (subst* (cdr v) s)))
+       (else v))))
+
+  (define (ext-s x v s) `((,x . ,v) . ,s))
+
+  (define (unify u v s)
+    (let ((u (subst u s)) (v (subst v s)))
+      (cond
+       ((and (var? u) (var? v) (var=? u v)) s)
+       ((var? u) (ext-s u v s))
+       ((var? v) (ext-s v u s))
+       ((and (pair? u) (pair? v))
+        (let ((s (unify (car u) (car v) s)))
+          (and s (unify (cdr u) (cdr v) s))))
+       (else (and (eqv? u v) s)))))
+
+  ;; klist monad
+
+  (define zero '())
+  (define (plus $1 $2)
+    (cond
+     ((null? $1) $2)
+     ((procedure? $1) (lambda () (plus $2 ($1))))
+     ((pair? $1) (cons (car $1) (plus (cdr $1) $2)))))
+
+  (define (unit s/c) (list s/c))
+  (define (bind $ g)
+    (cond
+     ((null? $) zero)
+     ((procedure? $) (lambda () (bind ($) g)))
+     ((pair? $) (plus (g (car $)) (bind (cdr $) g)))))
+
+  (define-syntax reify
+    (syntax-rules ()
+      ((_ expr)
+       (reset (unit expr)))))
+
+  (define (reflect m)
+    (shift k (bind m k)))
+
+  ;; goal constructors
+
+  (define (call/fresh f)
+    (lambda (s/c)
+      (let ((s (car s/c)) (c (cdr s/c)))
+        ((f (var c)) `(,s . ,(+ c 1))))))
+
+  (define (disj g1 g2) (lambda (s/c) (plus (g1 s/c) (g2 s/c))))
+  (define (conj g1 g2) (lambda (s/c) (bind (g1 s/c) g2)))
+
+  (define (is u v)
+    (lambda (s/c)
+      (let ((s (unify u v (car s/c))))
+        (if s (unit `(,s . ,(cdr s/c))) zero))))
+
+  ;; goal runner
+
+  (define initial-state '(() . 0))
+
+  (define (run-goal n g)
+    (map reify-1st (take n (g initial-state))))
+
+  (define (run-goal* g)
+    (map reify-1st (take* (g initial-state))))
+
+  (define (take n $)
+    (if (zero? n) '()
+        (let (($ (force* $)))
+          (if (null? $) '() (cons (car $) (take (- n 1) (cdr $)))))))
+
+  (define (take* $)
+    (let (($ (force* $)))
+      (if (null? $) '() (cons (car $) (take* (cdr $))))))
+
+  (define (reify-1st s/c)
+    (let ((v (subst* (var 0) (car s/c))))
+      (subst* v (reify-s v '()))))
+
+  (define (reify-s v s)
+    (let ((v (subst v s)))
+      (cond
+       ((var? v)
+        (let  ((n (reify-name (length s))))
+          (cons `(,v . ,n) s)))
+       ((pair? v) (reify-s (cdr v) (reify-s (car v) s)))
+       (else s))))
+
+  (define (reify-name n)
+    (string->symbol
+     (string-append "_" "." (number->string n)))))

contrib/60.logic/nitro.mk

@@ -0,0 +1,7 @@
+CONTRIB_LIBS += $(wildcard contrib/60.logic/*.scm)
+CONTRIB_TESTS += test-logic
+
+test-logic: bin/picrin
+	for test in `ls contrib/60.logic/t/*.scm`; do \
+	  $(TEST_RUNNER) "$$test"; \
+	done

contrib/60.logic/t/logic-test.scm

@@ -0,0 +1,120 @@
+(import (scheme base)
+        (scheme lazy)
+        (scheme write)
+        (picrin logic)
+        (picrin test))
+
+(define-syntax Zzz
+  (syntax-rules ()
+    ((_ g) (lambda (s/c) (lambda () (g s/c))))))
+
+(define-syntax conj+
+  (syntax-rules ()
+    ((_ g) (Zzz g))
+    ((_ g0 g ...) (conj (Zzz g0) (conj+ g ...)))))
+
+(define-syntax disj+
+  (syntax-rules ()
+    ((_ g) (Zzz g))
+    ((_ g0 g ...) (disj (Zzz g0) (disj+ g ...)))))
+
+(define-syntax fresh
+  (syntax-rules ()
+    ((_ () g0 g ...) (conj+ g0 g ...))
+    ((_ (x0 x ...) g0 g ...)
+     (call/fresh
+      (lambda (x0)
+        (fresh (x ...) g0 g ...))))))
+
+(define-syntax conde
+  (syntax-rules ()
+    ((_ (g0 g ...) ...) (disj+ (conj+ g0 g ...) ...))))
+
+(define-syntax run
+  (syntax-rules ()
+    ((_ n (x ...) g0 g ...)
+     (run-goal n (fresh (x ...) g0 g ...)))))
+
+(define-syntax run*
+  (syntax-rules ()
+    ((_ (x ...) g0 g ...)
+     (run-goal* (fresh (x ...) g0 g ...)))))
+
+(define (appendo l s out)
+  (conde
+    ((is '() l) (is s out))
+    ((fresh (a d res)
+       (is `(,a . ,d) l)
+       (is `(,a . ,res) out)
+       (appendo d s res)))))
+
+(test '((() (1 2 3 4 5))
+        ((1) (2 3 4 5))
+        ((1 2) (3 4 5))
+        ((1 2 3) (4 5))
+        ((1 2 3 4) (5))
+        ((1 2 3 4 5) ()))
+      (run* (q) (fresh (x y) (is `(,x ,y) q) (appendo x y '(1 2 3 4 5)))))
+
+(test '((() (1 2 3 4 5))
+        ((1) (2 3 4 5))
+        ((1 2) (3 4 5))
+        ((1 2 3) (4 5))
+        ((1 2 3 4) (5))
+        ((1 2 3 4 5) ()))
+      (run* (q x y) (is `(,x ,y) q) (appendo x y '(1 2 3 4 5))))
+
+(test '((1 2 8 3 4 5)
+        (1 2 8 3 4 5 8)
+        (1 2 8 3 4 8 5)
+        (1 2 8 3 8 4 5)
+        (1 2 8 8 3 4 5)
+        (1 2 8 8 3 4 5)
+        (1 8 2 8 3 4 5)
+        (8 1 2 8 3 4 5))
+      (letrec
+          ((rember*o (lambda (tr o)
+                       (conde
+                        ((is '() tr) (is '() o))
+                        ((fresh (a d)
+                                (is `(,a . ,d) tr)
+                                (conde
+                                 ((fresh (aa da)
+                                         (is `(,aa . ,da) a)
+                                         (fresh (a^ d^)
+                                                (rember*o a a^)
+                                                (rember*o d d^)
+                                                (is `(,a^ . ,d^) o))))
+                                 ((is a 8) (rember*o d o))
+                                 ((fresh (d^)
+                                         (rember*o d d^)
+                                         (is `(,a . ,d^) o))))))))))
+        (run 8 (q) (rember*o q '(1 2 8 3 4 5)))))
+
+(test '((1 (2 8 3 4) 5)
+        (1 (2 8 3 4) 5 8)
+        (1 (2 8 3 4) 5 8 8)
+        (1 (2 8 3 4) 8 5)
+        (1 8 (2 8 3 4) 5)
+        (8 1 (2 8 3 4) 5)
+        (1 (2 8 3 4) 5 8 8 8)
+        (1 (2 8 3 4) 5 8 8 8 8)
+        (1 (2 8 3 4) 5 8 8 8 8 8))
+      (letrec
+          ((rember*o (lambda (tr o)
+                       (conde
+                        ((is '() tr) (is '() o))
+                        ((fresh (a d)
+                                (is `(,a . ,d) tr)
+                                (conde
+                                 ((fresh (aa da)
+                                         (is `(,aa . ,da) a)
+                                         (fresh (a^ d^)
+                                                (is `(,a^ . ,d^) o)
+                                                (rember*o d d^)
+                                                (rember*o a a^))))
+                                 ((is a 8) (rember*o d o))
+                                 ((fresh (d^)
+                                         (is `(,a . ,d^) o)
+                                         (rember*o d d^))))))))))
+        (run 9 (q) (rember*o q '(1 (2 8 3 4) 5)))))

contrib/60.peg/TODO

@@ -0,0 +1,2 @@
+- memoize
+- more procedures

contrib/60.peg/nitro.mk

@@ -0,0 +1,8 @@
+CONTRIB_LIBS += contrib/60.peg/picrin/parser.scm contrib/60.peg/picrin/parser/string.scm
+
+CONTRIB_TESTS += test-peg
+
+test-peg: bin/picrin
+	for test in `ls contrib/60.peg/t/*.scm`; do \
+	  $(TEST_RUNNER) "$$test"; \
+	done

contrib/60.peg/picrin/parser.scm

@@ -0,0 +1,100 @@
+(define-library (picrin parser)
+  (import (scheme base)
+          (picrin control)
+          (picrin procedure))
+  (export parse
+          ;; monadic
+          reify
+          reflect
+          bind
+          unit
+          zero
+          plus
+          fapply
+          ;; look ahead
+          with
+          without
+          ;; eta
+          lazy
+          ;; aux
+          choice
+          optional
+          many
+          between)
+
+  ;; type Parser i r = i -> Maybe (r, i)
+
+  (define (parse rule input)
+    (rule input))
+
+  ;; monadic operators
+
+  (define-syntax reify
+    (syntax-rules ()
+      ((_ expr)
+       (reset (unit expr)))))
+
+  (define (reflect x)
+    (shift k (bind x k)))
+
+  (define (bind m f)
+    (lambda (i)
+      (let ((x (m i)))
+        (and x ((f (car x)) (cdr x))))))
+
+  (define (unit x)
+    (lambda (i)
+      `(,x . ,i)))
+
+  (define zero
+    (lambda (i) #f))
+
+  (define (plus a b)
+    (lambda (i)
+      (or (a i) (b i))))
+
+  (define (fapply f . args)
+    (reify
+     (let loop ((args args) (ps '()))
+       (if (null? args)
+           (apply f (reverse ps))
+           (loop (cdr args) (cons (reflect (car args)) ps))))))
+
+  ;; look ahead
+
+  (define (with a)
+    (lambda (i)
+      (and (a i) `(#f . ,i))))
+
+  (define (without a)
+    (lambda (i)
+      (and (not (a i)) `(#f . ,i))))
+
+  ;; eta conversion
+
+  (define-syntax lazy
+    (syntax-rules ()
+      ((_ expr)
+       (lambda (i) (expr i)))))
+
+  ;; aux
+
+  (define (choice . xs)
+    (if (null? xs)
+        zero
+        (plus (car xs) (apply choice (cdr xs)))))
+
+  (define (optional a)
+    (choice a (unit #f)))
+
+  (define (many a)
+    (lazy
+     (choice
+      (reify
+       (let* ((a (reflect a))
+              (b (reflect (many a))))
+         (cons a b)))
+      null)))
+
+  (define (between l x r)
+    (fapply (>> list cadr) l x r)))

contrib/60.peg/picrin/parser/string.scm

@@ -0,0 +1,28 @@
+(define-library (picrin parser string)
+  (import (except (scheme base) string)
+          (picrin parser))
+  (export string
+          any-char
+          eof
+          parse-string)
+
+  ;; string stream parser
+
+  (define (string str)
+    (lambda (i)
+      (let ((i (car i)) (input (cdr i)))
+        (let ((j (min (+ i (string-length str)) (string-length input))))
+          (and (equal? str (string-copy input i j))
+               `(,str . ,(cons j input)))))))
+
+  (define any-char
+    (lambda (i)
+      (let ((i (car i)) (input (cdr i)))
+        (and (< i (string-length input))
+             `(,(string-ref input i) . ,(cons (+ i 1) input))))))
+
+  (define eof
+    (without any-char))
+
+  (define (parse-string rule input)
+    (parse rule (cons 0 input))))

contrib/60.peg/t/peg.scm

@@ -0,0 +1,45 @@
+;;; test case
+
+(import (scheme base)
+        (picrin test)
+        (picrin procedure)
+        (picrin parser)
+        (picrin parser string))
+
+(test-begin "(picrin parser) and (picrin parser string)")
+
+(define LPAREN (string "("))
+(define RPAREN (string ")"))
+
+(define PLUS (string "+"))
+(define MINUS (string "-"))
+
+(define ONE (fapply (constant 1) (string "1")))
+
+(define S (lazy
+           (fapply (>> list car) A eof)))
+
+(define A (lazy
+           (choice
+            (fapply (lambda (p _ a) (list '+ p a)) P PLUS A)
+            (fapply (lambda (p _ a) (list '- p a)) P MINUS A)
+            P)))
+
+(define P (lazy
+           (choice
+            (between LPAREN A RPAREN)
+            ONE)))
+
+(define-syntax test-success
+  (syntax-rules ()
+    ((_ expect str)
+     (test (cons expect (cons (string-length str) str))
+           (parse-string S str)))))
+
+(test-success 1 "(1)")
+(test-success '(- (+ 1 1) 1) "((1+1)-1)")
+(test-success '(- (+ 1 1) 1) "((1+(1))-1)")
+(test-success '(+ 1 (- 1 (+ 1 (- 1 (+ 1 1))))) "(1+(1-(1+(1-(1+1)))))")
+(test-success '(+ 1 (+ 1(- 1 (+ 1 (- 1 (+ 1 1)))))) "(1+1+(1-(1+(1-(1+1)))))")
+
+(test-end)

contrib/60.repl/repl.scm

@@ -21,7 +21,7 @@
 
   (define user-env (library-environment (find-library '(picrin user))))
 
-  (begin
+  (define (init-env)
     (current-library (find-library '(picrin user)))
     (eval
      '(import (scheme base)
@@ -39,6 +39,7 @@
     (current-library (find-library '(picrin repl))))
 
   (define (repl)
+    (init-env)
     (let loop ((buf ""))
       (let ((line (readline (if (equal? buf "") "> " ""))))
         (if (eof-object? line)

contrib/90.array/array.scm

@@ -1,6 +1,5 @@
 (define-library (picrin array)
-  (import (picrin base)
-          (picrin record))
+  (import (scheme base))
 
   (define-record-type <array>
     (create-array data size head tail)
@@ -10,11 +9,6 @@
     (head array-head set-array-head!)
     (tail array-tail set-array-tail!))
 
-  (define (floor-remainder i j)
-    (call-with-values (lambda () (floor/ i j))
-      (lambda (q r)
-        r)))
-
   (define (translate ary i)
     (floor-remainder i (array-size ary)))
 

contrib/90.array/nitro.mk

@@ -0,0 +1,6 @@
+CONTRIB_LIBS += $(wildcard contrib/90.array/*.scm)
+
+CONTRIB_TESTS += test-array
+
+test-array: bin/picrin
+	$(TEST_RUNNER) contrib/90.array/t/array.scm

contrib/90.array/t/array.scm

@@ -0,0 +1,26 @@
+(import (scheme base)
+        (scheme write)
+        (picrin array)
+        (picrin test))
+
+(test-begin)
+
+(define ary (make-array))
+
+(array-push! ary 1)
+(array-push! ary 2)
+(array-push! ary 3)
+
+(test 3 (array-pop! ary))
+(test 2 (array-pop! ary))
+(test 1 (array-pop! ary))
+
+(array-unshift! ary 1)
+(array-unshift! ary 2)
+(array-unshift! ary 3)
+
+(test 3 (array-shift! ary))
+(test 2 (array-shift! ary))
+(test 1 (array-shift! ary))
+
+(test-end)

docs/libs.rst

@@ -117,7 +117,7 @@ Symbol-to-object hash table.
 
 - **(dictionary-ref dict key)**
 
-  Look up dictionary dict for a value associated with key. If dict has a slot for key `key`, the value stored in the slot is returned. Otherwise `#undefined` is returned.
+  Look up dictionary dict for a value associated with key. If dict has a slot for key `key`, a pair containing the key object and the associated value is returned. Otherwise `#f` is returned.
 
 - **(dictionary-set! dict key obj)**
 

etc/tak.scm

@@ -5,8 +5,9 @@
 (define (time f)
   (let ((start (current-jiffy)))
     (f)
-    (/ (- (current-jiffy) start)
-       (jiffies-per-second))))
+    (inexact
+     (/ (- (current-jiffy) start)
+        (jiffies-per-second)))))
 
 (define (tak x y z)
   (if (> x y)

extlib/benz/attr.c

@@ -22,13 +22,13 @@ pic_attr(pic_state *pic, pic_value obj)
 pic_value
 pic_attr_ref(pic_state *pic, pic_value obj, const char *key)
 {
-  return pic_dict_ref(pic, pic_attr(pic, obj), pic_intern_cstr(pic, key));
+  return pic_dict_ref(pic, pic_attr(pic, obj), pic_intern(pic, key));
 }
 
 void
 pic_attr_set(pic_state *pic, pic_value obj, const char *key, pic_value v)
 {
-  pic_dict_set(pic, pic_attr(pic, obj), pic_intern_cstr(pic, key), v);
+  pic_dict_set(pic, pic_attr(pic, obj), pic_intern(pic, key), v);
 }
 
 static pic_value

extlib/benz/bool.c

@@ -186,13 +186,11 @@ pic_bool_boolean_eq_p(pic_state *pic)
 void
 pic_init_bool(pic_state *pic)
 {
-  void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
-
   pic_defun(pic, "eq?", pic_bool_eq_p);
   pic_defun(pic, "eqv?", pic_bool_eqv_p);
   pic_defun(pic, "equal?", pic_bool_equal_p);
 
-  pic_defun_vm(pic, "not", pic->uNOT, pic_bool_not);
+  pic_defun(pic, "not", pic_bool_not);
 
   pic_defun(pic, "boolean?", pic_bool_boolean_p);
   pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);

extlib/benz/boot.c

@@ -489,17 +489,17 @@ my $src = <<'EOL';
       (letrec
           ((wrap (lambda (var1)
                    (let ((var2 (register1 var1)))
-                     (if (undefined? var2)
+                     (if var2
+                         (cdr var2)
                          (let ((var2 (make-identifier var1 env)))
                            (register1 var1 var2)
                            (register2 var2 var1)
-                           var2)
-                         var2))))
+                           var2)))))
            (unwrap (lambda (var2)
                      (let ((var1 (register2 var2)))
-                       (if (undefined? var1)
-                           var2
-                           var1))))
+                       (if var1
+                           (cdr var1)
+                           var2))))
            (walk (lambda (f form)
                    (cond
                     ((variable? form)
@@ -600,8 +600,9 @@ my $src = <<'EOL';
                  (let ((alist (collect (cadr spec))))
                    (map (lambda (var) (assq var alist)) (cddr spec))))
                 ((rename)
-                 (let ((alist (collect (cadr spec))))
-                   (map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))
+                 (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)))
@@ -645,12 +646,8 @@ my $src = <<'EOL';
                (library-export (car slot) (cdr slot))))))
       (for-each export (cdr form)))))
 
-(export define-library
-        cond-expand
-        import
-        export)
-
-(export let let* letrec letrec*
+(export define lambda quote set! if begin define-macro
+        let let* letrec letrec*
         let-values let*-values define-values
         quasiquote unquote unquote-splicing
         and or
@@ -926,84 +923,85 @@ const char pic_boot[][80] = {
 "ap cdr renames)\n            ,body))))))\n\n(define (transformer f)\n  (lambda (form",
 " env)\n    (let ((register1 (make-register))\n          (register2 (make-register)",
 "))\n      (letrec\n          ((wrap (lambda (var1)\n                   (let ((var2 ",
-"(register1 var1)))\n                     (if (undefined? var2)\n                  ",
-"       (let ((var2 (make-identifier var1 env)))\n                           (regi",
-"ster1 var1 var2)\n                           (register2 var2 var1)\n              ",
-"             var2)\n                         var2))))\n           (unwrap (lambda ",
-"(var2)\n                     (let ((var1 (register2 var2)))\n                     ",
-"  (if (undefined? var1)\n                           var2\n                        ",
-"   var1))))\n           (walk (lambda (f form)\n                   (cond\n         ",
-"           ((variable? form)\n                     (f form))\n                    ",
-"((pair? form)\n                     (cons (walk f (car form)) (walk f (cdr form))",
-"))\n                    ((vector? form)\n                     (list->vector (walk ",
-"f (vector->list form))))\n                    (else\n                     form))))",
-")\n        (let ((form (cdr form)))\n          (walk unwrap (apply f (walk wrap fo",
-"rm))))))))\n\n(define-macro define-syntax\n  (lambda (form env)\n    (let ((formal (",
-"car (cdr form)))\n          (body   (cdr (cdr form))))\n      (if (pair? formal)\n ",
-"         `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body",
-"))\n          `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body",
-")))))))\n\n(define-macro letrec-syntax\n  (lambda (form env)\n    (let ((formal (car",
-" (cdr form)))\n          (body   (cdr (cdr form))))\n      `(let ()\n         ,@(ma",
-"p (lambda (x)\n                  `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n   ",
-"             formal)\n         ,@body))))\n\n(define-macro let-syntax\n  (lambda (fo",
-"rm env)\n    `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(d",
-"efine-macro define-library\n  (lambda (form _)\n    (let ((name (cadr form))\n     ",
-"     (body (cddr form)))\n      (let ((old-library (current-library))\n           ",
-" (new-library (or (find-library name) (make-library name))))\n        (let ((env ",
-"(library-environment new-library)))\n          (current-library new-library)\n    ",
-"      (for-each (lambda (expr) (eval expr env)) body)\n          (current-library",
-" old-library))))))\n\n(define-macro cond-expand\n  (lambda (form _)\n    (letrec\n   ",
-"     ((test (lambda (form)\n                 (or\n                  (eq? form 'els",
-"e)\n                  (and (symbol? form)\n                       (memq form (feat",
-"ures)))\n                  (and (pair? form)\n                       (case (car fo",
-"rm)\n                         ((library) (find-library (cadr form)))\n            ",
-"             ((not) (not (test (cadr form))))\n                         ((and) (l",
-"et loop ((form (cdr form)))\n                                  (or (null? form)\n ",
-"                                     (and (test (car form)) (loop (cdr form)))))",
-")\n                         ((or) (let loop ((form (cdr form)))\n                 ",
-"                (and (pair? form)\n                                      (or (tes",
-"t (car form)) (loop (cdr form))))))\n                         (else #f)))))))\n   ",
-"   (let loop ((clauses (cdr form)))\n        (if (null? clauses)\n            #und",
-"efined\n            (if (test (caar clauses))\n                `(,the-begin ,@(cda",
-"r clauses))\n                (loop (cdr clauses))))))))\n\n(define-macro import\n  (",
-"lambda (form _)\n    (let ((caddr\n           (lambda (x) (car (cdr (cdr x)))))\n  ",
-"        (prefix\n           (lambda (prefix symbol)\n             (string->symbol\n",
-"              (string-append\n               (symbol->string prefix)\n            ",
-"   (symbol->string symbol))))))\n      (letrec\n          ((extract\n            (l",
-"ambda (spec)\n              (case (car spec)\n                ((only rename prefix",
-" except)\n                 (extract (cadr spec)))\n                (else\n         ",
-"        (or (find-library spec) (error \"library not found\" spec))))))\n          ",
-" (collect\n            (lambda (spec)\n              (case (car spec)\n            ",
-"    ((only)\n                 (let ((alist (collect (cadr spec))))\n              ",
-"     (map (lambda (var) (assq var alist)) (cddr spec))))\n                ((renam",
-"e)\n                 (let ((alist (collect (cadr spec))))\n                   (map",
-" (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n                ((prefi",
-"x)\n                 (let ((alist (collect (cadr spec))))\n                   (map",
-" (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n            ",
-"    ((except)\n                 (let ((alist (collect (cadr spec))))\n            ",
-"       (let loop ((alist alist))\n                     (if (null? alist)\n        ",
-"                 '()\n                         (if (memq (caar alist) (cddr spec)",
-")\n                             (loop (cdr alist))\n                             (",
-"cons (car alist) (loop (cdr alist))))))))\n                (else\n                ",
-" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n        ",
-"           (map (lambda (x) (cons x x)) (library-exports lib))))))))\n        (le",
-"trec\n            ((import\n               (lambda (spec)\n                 (let ((",
-"lib (extract spec))\n                       (alist (collect spec)))\n             ",
-"      (for-each\n                    (lambda (slot)\n                      (librar",
-"y-import lib (cdr slot) (car slot)))\n                    alist)))))\n          (f",
-"or-each import (cdr form)))))))\n\n(define-macro export\n  (lambda (form _)\n    (le",
-"trec\n        ((collect\n          (lambda (spec)\n            (cond\n             (",
-"(symbol? spec)\n              `(,spec . ,spec))\n             ((and (list? spec) (",
-"= (length spec) 3) (eq? (car spec) 'rename))\n              `(,(list-ref spec 1) ",
-". ,(list-ref spec 2)))\n             (else\n              (error \"malformed export",
-"\")))))\n         (export\n           (lambda (spec)\n             (let ((slot (coll",
-"ect spec)))\n               (library-export (car slot) (cdr slot))))))\n      (for",
-"-each export (cdr form)))))\n\n(export define-library\n        cond-expand\n        ",
-"import\n        export)\n\n(export let let* letrec letrec*\n        let-values let*-",
-"values define-values\n        quasiquote unquote unquote-splicing\n        and or\n",
-"        cond case else =>\n        do when unless\n        parameterize\n        de",
-"fine-syntax\n        syntax-quote syntax-unquote\n        syntax-quasiquote syntax",
-"-unquote-splicing\n        let-syntax letrec-syntax\n        syntax-error)\n\n\n",
+"(register1 var1)))\n                     (if var2\n                         (cdr v",
+"ar2)\n                         (let ((var2 (make-identifier var1 env)))\n         ",
+"                  (register1 var1 var2)\n                           (register2 va",
+"r2 var1)\n                           var2)))))\n           (unwrap (lambda (var2)\n",
+"                     (let ((var1 (register2 var2)))\n                       (if v",
+"ar1\n                           (cdr var1)\n                           var2))))\n  ",
+"         (walk (lambda (f form)\n                   (cond\n                    ((v",
+"ariable? form)\n                     (f form))\n                    ((pair? form)\n",
+"                     (cons (walk f (car form)) (walk f (cdr form))))\n           ",
+"         ((vector? form)\n                     (list->vector (walk f (vector->lis",
+"t form))))\n                    (else\n                     form)))))\n        (let",
+" ((form (cdr form)))\n          (walk unwrap (apply f (walk wrap form))))))))\n\n(d",
+"efine-macro define-syntax\n  (lambda (form env)\n    (let ((formal (car (cdr form)",
+"))\n          (body   (cdr (cdr form))))\n      (if (pair? formal)\n          `(,(t",
+"he 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n          `",
+"(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(defi",
+"ne-macro letrec-syntax\n  (lambda (form env)\n    (let ((formal (car (cdr form)))\n",
+"          (body   (cdr (cdr form))))\n      `(let ()\n         ,@(map (lambda (x)\n",
+"                  `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n                f",
+"ormal)\n         ,@body))))\n\n(define-macro let-syntax\n  (lambda (form env)\n    `(",
+",(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro de",
+"fine-library\n  (lambda (form _)\n    (let ((name (cadr form))\n          (body (cd",
+"dr form)))\n      (let ((old-library (current-library))\n            (new-library ",
+"(or (find-library name) (make-library name))))\n        (let ((env (library-envir",
+"onment new-library)))\n          (current-library new-library)\n          (for-eac",
+"h (lambda (expr) (eval expr env)) body)\n          (current-library old-library))",
+"))))\n\n(define-macro cond-expand\n  (lambda (form _)\n    (letrec\n        ((test (l",
+"ambda (form)\n                 (or\n                  (eq? form 'else)\n           ",
+"       (and (symbol? form)\n                       (memq form (features)))\n      ",
+"            (and (pair? form)\n                       (case (car form)\n          ",
+"               ((library) (find-library (cadr form)))\n                         (",
+"(not) (not (test (cadr form))))\n                         ((and) (let loop ((form",
+" (cdr form)))\n                                  (or (null? form)\n               ",
+"                       (and (test (car form)) (loop (cdr form))))))\n            ",
+"             ((or) (let loop ((form (cdr form)))\n                               ",
+"  (and (pair? form)\n                                      (or (test (car form)) ",
+"(loop (cdr form))))))\n                         (else #f)))))))\n      (let loop (",
+"(clauses (cdr form)))\n        (if (null? clauses)\n            #undefined\n       ",
+"     (if (test (caar clauses))\n                `(,the-begin ,@(cdar clauses))\n  ",
+"              (loop (cdr clauses))))))))\n\n(define-macro import\n  (lambda (form _",
+")\n    (let ((caddr\n           (lambda (x) (car (cdr (cdr x)))))\n          (prefi",
+"x\n           (lambda (prefix symbol)\n             (string->symbol\n              ",
+"(string-append\n               (symbol->string prefix)\n               (symbol->st",
+"ring symbol))))))\n      (letrec\n          ((extract\n            (lambda (spec)\n ",
+"             (case (car spec)\n                ((only rename prefix except)\n     ",
+"            (extract (cadr spec)))\n                (else\n                 (or (f",
+"ind-library spec) (error \"library not found\" spec))))))\n           (collect\n    ",
+"        (lambda (spec)\n              (case (car spec)\n                ((only)\n  ",
+"               (let ((alist (collect (cadr spec))))\n                   (map (lam",
+"bda (var) (assq var alist)) (cddr spec))))\n                ((rename)\n           ",
+"      (let ((alist (collect (cadr spec)))\n                       (renames (map (",
+"lambda (x) `((car x) . (cadr x))) (cddr spec))))\n                   (map (lambda",
+" (s) (or (assq (car s) renames) s)) alist)))\n                ((prefix)\n         ",
+"        (let ((alist (collect (cadr spec))))\n                   (map (lambda (s)",
+" (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n                ((except",
+")\n                 (let ((alist (collect (cadr spec))))\n                   (let ",
+"loop ((alist alist))\n                     (if (null? alist)\n                    ",
+"     '()\n                         (if (memq (caar alist) (cddr spec))\n          ",
+"                   (loop (cdr alist))\n                             (cons (car al",
+"ist) (loop (cdr alist))))))))\n                (else\n                 (let ((lib ",
+"(or (find-library spec) (error \"library not found\" spec))))\n                   (",
+"map (lambda (x) (cons x x)) (library-exports lib))))))))\n        (letrec\n       ",
+"     ((import\n               (lambda (spec)\n                 (let ((lib (extract",
+" spec))\n                       (alist (collect spec)))\n                   (for-e",
+"ach\n                    (lambda (slot)\n                      (library-import lib",
+" (cdr slot) (car slot)))\n                    alist)))))\n          (for-each impo",
+"rt (cdr form)))))))\n\n(define-macro export\n  (lambda (form _)\n    (letrec\n       ",
+" ((collect\n          (lambda (spec)\n            (cond\n             ((symbol? spe",
+"c)\n              `(,spec . ,spec))\n             ((and (list? spec) (= (length sp",
+"ec) 3) (eq? (car spec) 'rename))\n              `(,(list-ref spec 1) . ,(list-ref",
+" spec 2)))\n             (else\n              (error \"malformed export\")))))\n     ",
+"    (export\n           (lambda (spec)\n             (let ((slot (collect spec)))\n",
+"               (library-export (car slot) (cdr slot))))))\n      (for-each export",
+" (cdr form)))))\n\n(export define lambda quote set! if begin define-macro\n        ",
+"let let* letrec letrec*\n        let-values let*-values define-values\n        qua",
+"siquote unquote unquote-splicing\n        and or\n        cond case else =>\n      ",
+"  do when unless\n        parameterize\n        define-syntax\n        syntax-quote",
+" syntax-unquote\n        syntax-quasiquote syntax-unquote-splicing\n        let-sy",
+"ntax letrec-syntax\n        syntax-error)\n\n\n",
 "",
 ""
 };

extlib/benz/cont.c

@@ -79,6 +79,7 @@ pic_load_point(pic_state *pic, struct pic_cont *cont)
   pic->arena_idx = cont->arena_idx;
   pic->ip = cont->ip;
   pic->ptable = cont->ptable;
+  pic->cc = cont->prev;
 }
 
 static pic_value
@@ -140,8 +141,6 @@ pic_callcc(pic_state *pic, struct pic_proc *proc)
   pic_save_point(pic, &cont);
 
   if (PIC_SETJMP(pic, cont.jmp)) {
-    pic->cc = pic->cc->prev;
-
     return pic_values_by_list(pic, cont.results);
   }
   else {
@@ -155,44 +154,62 @@ pic_callcc(pic_state *pic, struct pic_proc *proc)
   }
 }
 
+static pic_value
+pic_va_values(pic_state *pic, size_t n, ...)
+{
+  pic_vec *args = pic_make_vec(pic, n);
+  va_list ap;
+  size_t i = 0;
+
+  va_start(ap, n);
+
+  while (i < n) {
+    args->data[i++] = va_arg(ap, pic_value);
+  }
+
+  va_end(ap);
+
+  return pic_values(pic, n, args->data);
+}
+
 pic_value
 pic_values0(pic_state *pic)
 {
-  return pic_values_by_list(pic, pic_nil_value());
+  return pic_va_values(pic, 0);
 }
 
 pic_value
 pic_values1(pic_state *pic, pic_value arg1)
 {
-  return pic_values_by_list(pic, pic_list1(pic, arg1));
+  return pic_va_values(pic, 1, arg1);
 }
 
 pic_value
 pic_values2(pic_state *pic, pic_value arg1, pic_value arg2)
 {
-  return pic_values_by_list(pic, pic_list2(pic, arg1, arg2));
+  return pic_va_values(pic, 2, arg1, arg2);
 }
 
 pic_value
 pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3)
 {
-  return pic_values_by_list(pic, pic_list3(pic, arg1, arg2, arg3));
+  return pic_va_values(pic, 3, arg1, arg2, arg3);
 }
 
 pic_value
 pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4)
 {
-  return pic_values_by_list(pic, pic_list4(pic, arg1, arg2, arg3, arg4));
+  return pic_va_values(pic, 4, arg1, arg2, arg3, arg4);
 }
 
 pic_value
 pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5)
 {
-  return pic_values_by_list(pic, pic_list5(pic, arg1, arg2, arg3, arg4, arg5));
+  return pic_va_values(pic, 5, arg1, arg2, arg3, arg4, arg5);
 }
 
 pic_value
-pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
+pic_values(pic_state *pic, size_t argc, pic_value *argv)
 {
   size_t i;
 
@@ -264,7 +281,7 @@ pic_cont_values(pic_state *pic)
 
   pic_get_args(pic, "*", &argc, &argv);
 
-  return pic_values_by_array(pic, argc, argv);
+  return pic_values(pic, argc, argv);
 }
 
 static pic_value
@@ -272,26 +289,28 @@ pic_cont_call_with_values(pic_state *pic)
 {
   struct pic_proc *producer, *consumer;
   size_t argc;
-  pic_value args[256];
+  pic_vec *args;
 
   pic_get_args(pic, "ll", &producer, &consumer);
 
   pic_apply(pic, producer, pic_nil_value());
 
-  argc = pic_receive(pic, 256, args);
+  argc = pic_receive(pic, 0, NULL);
+  args = pic_make_vec(pic, argc);
 
-  return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args));
+  pic_receive(pic, argc, args->data);
+
+  return pic_apply_trampoline(pic, consumer, argc, args->data);
 }
 
 void
 pic_init_cont(pic_state *pic)
 {
-  void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
-
   pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
   pic_defun(pic, "call/cc", pic_cont_callcc);
+  pic_defun(pic, "escape", pic_cont_callcc);
   pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
 
-  pic_defun_vm(pic, "values", pic->uVALUES, pic_cont_values);
-  pic_defun_vm(pic, "call-with-values", pic->uCALL_WITH_VALUES, pic_cont_call_with_values);
+  pic_defun(pic, "values", pic_cont_values);
+  pic_defun(pic, "call-with-values", pic_cont_call_with_values);
 }

extlib/benz/debug.c

@@ -45,7 +45,7 @@ pic_print_backtrace(pic_state *pic, xFILE *file)
     pic_value elem, it;
 
     e = pic_error_ptr(pic->err);
-    if (e->type != pic_intern_cstr(pic, "")) {
+    if (e->type != pic_intern(pic, "")) {
       pic_fwrite(pic, pic_obj_value(e->type), file);
       xfprintf(pic, file, " ");
     }

extlib/benz/dict.c

@@ -116,9 +116,9 @@ pic_dict_dictionary_ref(pic_state *pic)
   pic_get_args(pic, "dm", &dict, &key);
 
   if (! pic_dict_has(pic, dict, key)) {
-    return pic_undef_value();
+    return pic_false_value();
   }
-  return pic_dict_ref(pic, dict, key);
+  return pic_cons(pic, pic_obj_value(key), pic_dict_ref(pic, dict, key));
 }
 
 static pic_value
@@ -155,42 +155,19 @@ static pic_value
 pic_dict_dictionary_map(pic_state *pic)
 {
   struct pic_proc *proc;
-  size_t argc, i;
-  pic_value *args;
-  pic_value arg_list, ret = pic_nil_value();
+  struct pic_dict *dict;
+  khiter_t it;
+  khash_t(dict) *kh;
+  pic_value ret = pic_nil_value();
 
-  pic_get_args(pic, "l*", &proc, &argc, &args);
+  pic_get_args(pic, "ld", &proc, &dict);
 
-  if (argc != 0) {
-    khiter_t it[argc];
-    khash_t(dict) *kh[argc];
+  kh = &dict->hash;
 
-    for (i = 0; i < argc; ++i) {
-      if (! pic_dict_p(args[i])) {
-        pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
-      }
-      kh[i] = &pic_dict_ptr(args[i])->hash;
-      it[i] = kh_begin(kh[i]);
+  for (it = kh_begin(kh); it != kh_end(kh); ++it) {
+    if (kh_exist(kh, it)) {
+      pic_push(pic, pic_apply1(pic, proc, pic_obj_value(kh_key(kh, it))), ret);
     }
-
-    do {
-      arg_list = pic_nil_value();
-      for (i = 0; i < argc; ++i) {
-        while (it[i] != kh_end(kh[i])) { /* find next available */
-          if (kh_exist(kh[i], it[i]))
-            break;
-          it[i]++;
-        }
-        if (it[i] == kh_end(kh[i])) {
-          break;
-        }
-        pic_push(pic, pic_obj_value(kh_key(kh[i], it[i]++)), arg_list);
-      }
-      if (i != argc) {
-        break;
-      }
-      pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg_list)), ret);
-    } while (1);
   }
 
   return pic_reverse(pic, ret);
@@ -200,42 +177,18 @@ static pic_value
 pic_dict_dictionary_for_each(pic_state *pic)
 {
   struct pic_proc *proc;
-  size_t argc, i;
-  pic_value *args;
-  pic_value arg_list;
+  struct pic_dict *dict;
+  khiter_t it;
+  khash_t(dict) *kh;
 
-  pic_get_args(pic, "l*", &proc, &argc, &args);
+  pic_get_args(pic, "ld", &proc, &dict);
 
-  if (argc != 0) {
-    khiter_t it[argc];
-    khash_t(dict) *kh[argc];
+  kh = &dict->hash;
 
-    for (i = 0; i < argc; ++i) {
-      if (! pic_dict_p(args[i])) {
-        pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
-      }
-      kh[i] = &pic_dict_ptr(args[i])->hash;
-      it[i] = kh_begin(kh[i]);
+  for (it = kh_begin(kh); it != kh_end(kh); ++it) {
+    if (kh_exist(kh, it)) {
+      pic_apply1(pic, proc, pic_obj_value(kh_key(kh, it)));
     }
-
-    do {
-      arg_list = pic_nil_value();
-      for (i = 0; i < argc; ++i) {
-        while (it[i] != kh_end(kh[i])) { /* find next available */
-          if (kh_exist(kh[i], it[i]))
-            break;
-          it[i]++;
-        }
-        if (it[i] == kh_end(kh[i])) {
-          break;
-        }
-        pic_push(pic, pic_obj_value(kh_key(kh[i], it[i]++)), arg_list);
-      }
-      if (i != argc) {
-        break;
-      }
-      pic_void(pic_apply(pic, proc, pic_reverse(pic, arg_list)));
-    } while (1);
   }
 
   return pic_undef_value();

extlib/benz/error.c

@@ -7,7 +7,7 @@
 void
 pic_panic(pic_state PIC_UNUSED(*pic), const char *msg)
 {
-  extern void abort();
+  extern PIC_NORETURN void abort();
 
 #if DEBUG
   fprintf(stderr, "abort: %s\n", msg);
@@ -47,22 +47,6 @@ pic_errorf(pic_state *pic, const char *fmt, ...)
   pic_error(pic, msg, irrs);
 }
 
-const char *
-pic_errmsg(pic_state *pic)
-{
-  pic_str *str;
-
-  assert(! pic_invalid_p(pic->err));
-
-  if (! pic_error_p(pic->err)) {
-    str = pic_format(pic, "~s", pic->err);
-  } else {
-    str = pic_error_ptr(pic->err)->msg;
-  }
-
-  return pic_str_cstr(pic, str);
-}
-
 pic_value
 pic_native_exception_handler(pic_state *pic)
 {
@@ -158,7 +142,7 @@ pic_error(pic_state *pic, const char *msg, pic_value irrs)
 {
   struct pic_error *e;
 
-  e = pic_make_error(pic, pic_intern_cstr(pic, ""), msg, irrs);
+  e = pic_make_error(pic, pic_intern(pic, ""), msg, irrs);
 
   pic_raise(pic, pic_obj_value(e));
 }
@@ -212,22 +196,6 @@ pic_error_error(pic_state *pic)
   pic_error(pic, str, pic_list_by_array(pic, argc, argv));
 }
 
-static pic_value
-pic_error_make_error_object(pic_state *pic)
-{
-  struct pic_error *e;
-  pic_sym *type;
-  pic_str *msg;
-  size_t argc;
-  pic_value *argv;
-
-  pic_get_args(pic, "ms*", &type, &msg, &argc, &argv);
-
-  e = pic_make_error(pic, type, pic_str_cstr(pic, msg), pic_list_by_array(pic, argc, argv));
-
-  return pic_obj_value(e);
-}
-
 static pic_value
 pic_error_error_object_p(pic_state *pic)
 {
@@ -275,7 +243,6 @@ pic_init_error(pic_state *pic)
   pic_defun(pic, "raise", pic_error_raise);
   pic_defun(pic, "raise-continuable", pic_error_raise_continuable);
   pic_defun(pic, "error", pic_error_error);
-  pic_defun(pic, "make-error-object", pic_error_make_error_object);
   pic_defun(pic, "error-object?", pic_error_error_object_p);
   pic_defun(pic, "error-object-message", pic_error_error_object_message);
   pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants);

extlib/benz/file.c

@@ -330,9 +330,6 @@ int xvfprintf(pic_state *pic, xFILE *stream, const char *fmt, va_list ap) {
   const char *p;
   char *sval;
   int ival;
-#if PIC_ENABLE_FLOAT
-  double dval;
-#endif
   void *vp;
   int cnt = 0;
 
@@ -348,24 +345,43 @@ int xvfprintf(pic_state *pic, xFILE *stream, const char *fmt, va_list ap) {
       ival = va_arg(ap, int);
       cnt += print_int(pic, stream, ival, 10);
       break;
-#if PIC_ENABLE_FLOAT
-    case 'f':
-      dval = va_arg(ap, double);
-      cnt += print_int(pic, stream, dval, 10);
+#if PIC_ENABLE_LIBC
+    case 'f': {
+      char buf[100];
+      sprintf(buf, "%g", va_arg(ap, double));
+      cnt += xfputs(pic, buf, stream);
+      break;
+    }
+#else
+# define fabs(x) ((x) >= 0 ? (x) : -(x))
+    case 'f': {
+      double dval = va_arg(ap, double);
+      long lval;
+      if (dval < 0) {
+        dval = -dval;
+        xputc(pic, '-', stream);
+        cnt++;
+      }
+      lval = (long)dval;
+      cnt += print_int(pic, stream, lval, 10);
       xputc(pic, '.', stream);
       cnt++;
-      if ((ival = fabs((dval - floor(dval)) * 1e4) + 0.5) == 0) {
+      dval -= lval;
+      if ((ival = fabs(dval) * 1e4 + 0.5) == 0) {
         cnt += xfputs(pic, "0000", stream);
       } else {
-        int i;
-        for (i = 0; i < 3 - (int)log10(ival); ++i) {
-          xputc(pic, '0', stream);
-          cnt++;
-        }
+        if (ival < 1000) xputc(pic, '0', stream); cnt++;
+        if (ival <  100) xputc(pic, '0', stream); cnt++;
+        if (ival <   10) xputc(pic, '0', stream); cnt++;
         cnt += print_int(pic, stream, ival, 10);
       }
       break;
+    }
 #endif
+    case 'c':
+      ival = va_arg(ap, int);
+      cnt += xfputc(pic, ival, stream);
+      break;
     case 's':
       sval = va_arg(ap, char*);
       cnt += xfputs(pic, sval, stream);

extlib/benz/include/picrin.h

@@ -38,16 +38,15 @@ extern "C" {
 #include "picrin/kvec.h"
 #include "picrin/khash.h"
 
-#include "picrin/value.h"
-
 typedef struct pic_state pic_state;
 
+#include "picrin/type.h"
 #include "picrin/irep.h"
 #include "picrin/file.h"
 #include "picrin/read.h"
 #include "picrin/gc.h"
 
-KHASH_DECLARE(s, const char *, pic_sym *);
+KHASH_DECLARE(s, const char *, pic_sym *)
 
 typedef struct pic_checkpoint {
   PIC_OBJECT_HEADER
@@ -61,6 +60,7 @@ typedef struct {
   int argc, retc;
   pic_code *ip;
   pic_value *fp;
+  struct pic_irep *irep;
   struct pic_context *cxt;
   int regc;
   pic_value *regs;
@@ -95,32 +95,21 @@ struct pic_state {
 
   struct pic_lib *lib, *prev_lib;
 
-  pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG;
-  pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING;
-  pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE, *sSYNTAX_UNQUOTE;
-  pic_sym *sSYNTAX_UNQUOTE_SPLICING;
-  pic_sym *sDEFINE_MACRO, *sIMPORT, *sEXPORT;
-  pic_sym *sDEFINE_LIBRARY;
-  pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY;
-  pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT;
-  pic_sym *sCONS, *sCAR, *sCDR, *sNILP;
-  pic_sym *sSYMBOLP, *sPAIRP;
-  pic_sym *sADD, *sSUB, *sMUL, *sDIV, *sMINUS;
-  pic_sym *sEQ, *sLT, *sLE, *sGT, *sGE, *sNOT;
-  pic_sym *sREAD, *sFILE;
-  pic_sym *sGREF, *sCREF, *sLREF;
-  pic_sym *sCALL, *sTAILCALL, *sRETURN;
-  pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES;
+  pic_sym *sQUOTE, *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING;
+  pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE, *sSYNTAX_UNQUOTE, *sSYNTAX_UNQUOTE_SPLICING;
+  pic_sym *sDEFINE_LIBRARY, *sIMPORT, *sEXPORT, *sCOND_EXPAND;
+  pic_sym *sGREF, *sCREF, *sLREF, *sCALL;
 
-  pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG;
-  pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT;
-  pic_sym *uDEFINE_LIBRARY;
-  pic_sym *uCOND_EXPAND;
-  pic_sym *uCONS, *uCAR, *uCDR, *uNILP;
-  pic_sym *uSYMBOLP, *uPAIRP;
-  pic_sym *uADD, *uSUB, *uMUL, *uDIV;
-  pic_sym *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT;
-  pic_sym *uVALUES, *uCALL_WITH_VALUES;
+  pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG, *uDEFINE_MACRO;
+  pic_sym *uDEFINE_LIBRARY, *uIMPORT, *uEXPORT, *uCOND_EXPAND;
+  pic_sym *uCONS, *uCAR, *uCDR, *uNILP, *uSYMBOLP, *uPAIRP;
+  pic_sym *uADD, *uSUB, *uMUL, *uDIV, *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT;
+
+  pic_value pCONS, pCAR, pCDR, pNILP, pPAIRP, pSYMBOLP, pNOT;
+  pic_value pADD, pSUB, pMUL, pDIV, pEQ, pLT, pLE, pGT, pGE;
+
+  pic_value cCONS, cCAR, cCDR, cNILP, cPAIRP, cSYMBOLP, cNOT;
+  pic_value cADD, cSUB, cMUL, cDIV, cEQ, cLT, cLE, cGT, cGE;
 
   struct pic_lib *PICRIN_BASE;
   struct pic_lib *PICRIN_USER;
@@ -155,7 +144,6 @@ void *pic_malloc(pic_state *, size_t);
 void *pic_realloc(pic_state *, void *, size_t);
 void *pic_calloc(pic_state *, size_t, size_t);
 struct pic_object *pic_obj_alloc(pic_state *, size_t, enum pic_tt);
-struct pic_object *pic_obj_alloc_unsafe(pic_state *, size_t, enum pic_tt);
 void pic_free(pic_state *, void *);
 
 void pic_gc_run(pic_state *);
@@ -184,14 +172,14 @@ bool pic_eq_p(pic_value, pic_value);
 bool pic_eqv_p(pic_value, pic_value);
 bool pic_equal_p(pic_state *, pic_value, pic_value);
 
-pic_sym *pic_intern(pic_state *, pic_str *);
-pic_sym *pic_intern_cstr(pic_state *, const char *);
+pic_sym *pic_intern(pic_state *, const char *);
+pic_sym *pic_intern_str(pic_state *, pic_str *);
 const char *pic_symbol_name(pic_state *, pic_sym *);
 
 pic_value pic_read(pic_state *, struct pic_port *);
 pic_value pic_read_cstr(pic_state *, const char *);
 
-void pic_load_port(pic_state *, struct pic_port *);
+void pic_load(pic_state *, struct pic_port *);
 void pic_load_cstr(pic_state *, const char *);
 
 void pic_define(pic_state *, const char *, pic_value);
@@ -217,9 +205,9 @@ pic_value pic_apply2(pic_state *, struct pic_proc *, pic_value, pic_value);
 pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value);
 pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value);
 pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value);
-pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value);
+pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, size_t, pic_value *);
+pic_value pic_apply_trampoline_list(pic_state *, struct pic_proc *, pic_value);
 pic_value pic_eval(pic_state *, pic_value, struct pic_env *);
-struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_env *);
 
 struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *);
 
@@ -243,9 +231,9 @@ void pic_export(pic_state *, pic_sym *);
 PIC_NORETURN void pic_panic(pic_state *, const char *);
 PIC_NORETURN void pic_errorf(pic_state *, const char *, ...);
 void pic_warnf(pic_state *, const char *, ...);
-const char *pic_errmsg(pic_state *);
 pic_str *pic_get_backtrace(pic_state *);
 void pic_print_backtrace(pic_state *, xFILE *);
+
 struct pic_dict *pic_attr(pic_state *, pic_value);
 pic_value pic_attr_ref(pic_state *, pic_value, const char *);
 void pic_attr_set(pic_state *, pic_value, const char *, pic_value);

extlib/benz/include/picrin/compat.h

@@ -89,7 +89,7 @@ extern "C" {
 
 #else
 
-# define assert(v) 0
+# define assert(v) (void)0
 
 PIC_INLINE int
 isspace(int c)
@@ -205,10 +205,6 @@ strcpy(char *dst, const char *src)
 
 #endif
 
-#if PIC_ENABLE_FLOAT
-# include <math.h>
-#endif
-
 #if PIC_ENABLE_STDIO
 # include <stdio.h>
 #endif

extlib/benz/include/picrin/config.h

@@ -11,9 +11,6 @@
 /** enable word boxing  */
 /* #define PIC_WORD_BOXING 0 */
 
-/** enable floating point number support */
-/* #define PIC_ENABLE_FLOAT 1 */
-
 /** no dependency on libc */
 /* #define PIC_ENABLE_LIBC 1 */
 
@@ -33,6 +30,8 @@
 
 /* #define PIC_HEAP_PAGE_SIZE 10000 */
 
+/* #define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100) */
+
 /* #define PIC_STACK_SIZE 1024 */
 
 /* #define PIC_RESCUE_SIZE 30 */
@@ -66,10 +65,6 @@
 # error cannot enable both PIC_NAN_BOXING and PIC_WORD_BOXING simultaneously
 #endif
 
-#if PIC_WORD_BOXING && PIC_ENABLE_FLOAT
-# error cannot enable both PIC_WORD_BOXING and PIC_ENABLE_FLOAT simultaneously
-#endif
-
 #ifndef PIC_WORD_BOXING
 # define PIC_WORD_BOXING 0
 #endif
@@ -82,20 +77,10 @@
 # endif
 #endif
 
-#ifndef PIC_ENABLE_FLOAT
-# if ! PIC_WORD_BOXING
-#  define PIC_ENABLE_FLOAT 1
-# endif
-#endif
-
 #ifndef PIC_ENABLE_LIBC
 # define PIC_ENABLE_LIBC 1
 #endif
 
-#if PIC_NAN_BOXING && defined(PIC_ENABLE_FLOAT) && ! PIC_ENABLE_FLOAT
-# error cannot disable float support when nan boxing is on
-#endif
-
 #ifndef PIC_ENABLE_STDIO
 # define PIC_ENABLE_STDIO 1
 #endif
@@ -124,11 +109,15 @@
 #endif
 
 #ifndef PIC_HEAP_PAGE_SIZE
-# define PIC_HEAP_PAGE_SIZE (2 * 1024 * 1024)
+# 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 1024
+# define PIC_STACK_SIZE 2048
 #endif
 
 #ifndef PIC_RESCUE_SIZE

extlib/benz/include/picrin/cont.h

@@ -41,7 +41,7 @@ pic_value pic_values2(pic_state *, pic_value, pic_value);
 pic_value pic_values3(pic_state *, pic_value, pic_value, pic_value);
 pic_value pic_values4(pic_state *, pic_value, pic_value, pic_value, pic_value);
 pic_value pic_values5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value);
-pic_value pic_values_by_array(pic_state *, size_t, pic_value *);
+pic_value pic_values(pic_state *, size_t, pic_value *);
 pic_value pic_values_by_list(pic_state *, pic_value);
 size_t pic_receive(pic_state *, size_t, pic_value *);
 

extlib/benz/include/picrin/dict.h

@@ -22,7 +22,7 @@ struct pic_dict {
 struct pic_dict *pic_make_dict(pic_state *);
 
 #define pic_dict_for_each(sym, dict, it)        \
-  pic_dict_for_each_help(sym, (&dict->hash), it)
+  pic_dict_for_each_help(sym, (&(dict)->hash), it)
 #define pic_dict_for_each_help(sym, h, it)        \
   for (it = kh_begin(h); it != kh_end(h); ++it)   \
     if ((sym = kh_key(h, it)), kh_exist(h, it))

extlib/benz/include/picrin/error.h

@@ -44,7 +44,6 @@ struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_list)
       } while (0);                                        \
       pic->cc = pic->cc->prev;                            \
     } else {                                              \
-      pic->cc = pic->cc->prev;                            \
       goto label;                                         \
     }                                                     \
   } while (0);                                            \

extlib/benz/include/picrin/irep.h

@@ -9,48 +9,8 @@
 extern "C" {
 #endif
 
-enum pic_opcode {
-  OP_NOP,
-  OP_POP,
-  OP_PUSHUNDEF,
-  OP_PUSHNIL,
-  OP_PUSHTRUE,
-  OP_PUSHFALSE,
-  OP_PUSHINT,
-  OP_PUSHCHAR,
-  OP_PUSHCONST,
-  OP_GREF,
-  OP_GSET,
-  OP_LREF,
-  OP_LSET,
-  OP_CREF,
-  OP_CSET,
-  OP_JMP,
-  OP_JMPIF,
-  OP_NOT,
-  OP_CALL,
-  OP_TAILCALL,
-  OP_RET,
-  OP_LAMBDA,
-  OP_CONS,
-  OP_CAR,
-  OP_CDR,
-  OP_NILP,
-  OP_SYMBOLP,
-  OP_PAIRP,
-  OP_ADD,
-  OP_SUB,
-  OP_MUL,
-  OP_DIV,
-  OP_MINUS,
-  OP_EQ,
-  OP_LT,
-  OP_LE,
-  OP_STOP
-};
-
 typedef struct {
-  enum pic_opcode insn;
+  int insn;
   union {
     int i;
     char c;
@@ -61,11 +21,6 @@ typedef struct {
   } u;
 } pic_code;
 
-#define PIC_INIT_CODE_I(code, op, ival) do {    \
-    code.insn = op;                             \
-    code.u.i = ival;                            \
-  } while (0)
-
 struct pic_irep {
   PIC_OBJECT_HEADER
   pic_code *code;
@@ -73,7 +28,6 @@ struct pic_irep {
   bool varg;
   struct pic_irep **irep;
   pic_value *pool;
-  pic_sym **syms;
   size_t clen, ilen, plen, slen;
 };
 
@@ -81,146 +35,7 @@ pic_sym *pic_resolve(pic_state *, pic_value, struct pic_env *);
 pic_value pic_expand(pic_state *, pic_value, struct pic_env *);
 pic_value pic_analyze(pic_state *, pic_value);
 struct pic_irep *pic_codegen(pic_state *, pic_value);
-
-#if DEBUG
-
-PIC_INLINE void
-pic_dump_code(pic_code c)
-{
-  printf("[%2d] ", c.insn);
-  switch (c.insn) {
-  case OP_NOP:
-    puts("OP_NOP");
-    break;
-  case OP_POP:
-    puts("OP_POP");
-    break;
-  case OP_PUSHUNDEF:
-    puts("OP_PUSHUNDEF");
-    break;
-  case OP_PUSHNIL:
-    puts("OP_PUSHNIL");
-    break;
-  case OP_PUSHTRUE:
-    puts("OP_PUSHTRUE");
-    break;
-  case OP_PUSHFALSE:
-    puts("OP_PUSHFALSE");
-    break;
-  case OP_PUSHINT:
-    printf("OP_PUSHINT\t%d\n", c.u.i);
-    break;
-  case OP_PUSHCHAR:
-    printf("OP_PUSHCHAR\t%c\n", c.u.c);
-    break;
-  case OP_PUSHCONST:
-    printf("OP_PUSHCONST\t%d\n", c.u.i);
-    break;
-  case OP_GREF:
-    printf("OP_GREF\t%i\n", c.u.i);
-    break;
-  case OP_GSET:
-    printf("OP_GSET\t%i\n", c.u.i);
-    break;
-  case OP_LREF:
-    printf("OP_LREF\t%d\n", c.u.i);
-    break;
-  case OP_LSET:
-    printf("OP_LSET\t%d\n", c.u.i);
-    break;
-  case OP_CREF:
-    printf("OP_CREF\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
-    break;
-  case OP_CSET:
-    printf("OP_CSET\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
-    break;
-  case OP_JMP:
-    printf("OP_JMP\t%x\n", c.u.i);
-    break;
-  case OP_JMPIF:
-    printf("OP_JMPIF\t%x\n", c.u.i);
-    break;
-  case OP_NOT:
-    puts("OP_NOT");
-    break;
-  case OP_CALL:
-    printf("OP_CALL\t%d\n", c.u.i);
-    break;
-  case OP_TAILCALL:
-    printf("OP_TAILCALL\t%d\n", c.u.i);
-    break;
-  case OP_RET:
-    printf("OP_RET\t%d\n", c.u.i);
-    break;
-  case OP_LAMBDA:
-    printf("OP_LAMBDA\t%d\n", c.u.i);
-    break;
-  case OP_CONS:
-    puts("OP_CONS");
-    break;
-  case OP_CAR:
-    puts("OP_CAR");
-    break;
-  case OP_NILP:
-    puts("OP_NILP");
-    break;
-  case OP_SYMBOLP:
-    puts("OP_SYMBOLP");
-    break;
-  case OP_PAIRP:
-    puts("OP_PAIRP");
-    break;
-  case OP_CDR:
-    puts("OP_CDR");
-    break;
-  case OP_ADD:
-    puts("OP_ADD");
-    break;
-  case OP_SUB:
-    puts("OP_SUB");
-    break;
-  case OP_MUL:
-    puts("OP_MUL");
-    break;
-  case OP_DIV:
-    puts("OP_DIV");
-    break;
-  case OP_MINUS:
-    puts("OP_MINUS");
-    break;
-  case OP_EQ:
-    puts("OP_EQ");
-    break;
-  case OP_LT:
-    puts("OP_LT");
-    break;
-  case OP_LE:
-    puts("OP_LE");
-    break;
-  case OP_STOP:
-    puts("OP_STOP");
-    break;
-  }
-}
-
-PIC_INLINE void
-pic_dump_irep(struct pic_irep *irep)
-{
-  unsigned i;
-
-  printf("## irep %p\n", (void *)irep);
-  printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec);
-  for (i = 0; i < irep->clen; ++i) {
-    printf("%02x ", i);
-    pic_dump_code(irep->code[i]);
-  }
-
-  for (i = 0; i < irep->ilen; ++i) {
-    pic_dump_irep(irep->irep[i]);
-  }
-}
-
-#endif
+struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_env *);
 
 #if defined(__cplusplus)
 }

extlib/benz/include/picrin/khash.h

@@ -27,21 +27,7 @@
 #ifndef AC_KHASH_H
 #define AC_KHASH_H
 
-#include <limits.h>
-
-#if UINT_MAX == 0xffffffffu
-typedef unsigned int khint32_t;
-#elif ULONG_MAX == 0xffffffffu
-typedef unsigned long khint32_t;
-#endif
-
-#if ULONG_MAX == ULLONG_MAX
-typedef unsigned long khint64_t;
-#else
-typedef unsigned long long khint64_t;
-#endif
-
-typedef khint32_t khint_t;
+typedef int khint_t;
 typedef khint_t khiter_t;
 
 #define ac_isempty(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&2)
@@ -78,7 +64,7 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key)
 #define KHASH_DECLARE(name, khkey_t, khval_t)                           \
   typedef struct {                                                      \
     khint_t n_buckets, size, n_occupied, upper_bound;                   \
-    khint32_t *flags;                                                   \
+    int *flags;                                                         \
     khkey_t *keys;                                                      \
     khval_t *vals;                                                      \
   } kh_##name##_t;                                                      \
@@ -105,7 +91,7 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key)
   void kh_clear_##name(kh_##name##_t *h)                                \
   {                                                                     \
     if (h->flags) {                                                     \
-      memset(h->flags, 0xaa, ac_fsize(h->n_buckets) * sizeof(khint32_t)); \
+      memset(h->flags, 0xaa, ac_fsize(h->n_buckets) * sizeof(int));     \
       h->size = h->n_occupied = 0;                                      \
     }                                                                   \
   }                                                                     \
@@ -125,15 +111,15 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key)
   }                                                                     \
   void kh_resize_##name(pic_state *pic, kh_##name##_t *h, khint_t new_n_buckets) \
   { /* This function uses 0.25*n_buckets bytes of working space instead of [sizeof(key_t+val_t)+.25]*n_buckets. */ \
-    khint32_t *new_flags = 0;                                           \
+    int *new_flags = 0;                                                 \
     khint_t j = 1;                                                      \
     {                                                                   \
       ac_roundup32(new_n_buckets);                                      \
       if (new_n_buckets < 4) new_n_buckets = 4;                         \
       if (h->size >= ac_hash_upper(new_n_buckets)) j = 0; /* requested size is too small */ \
       else { /* hash table size to be changed (shrink or expand); rehash */ \
-        new_flags = pic_malloc(pic, ac_fsize(new_n_buckets) * sizeof(khint32_t)); \
-        memset(new_flags, 0xaa, ac_fsize(new_n_buckets) * sizeof(khint32_t)); \
+        new_flags = pic_malloc(pic, ac_fsize(new_n_buckets) * sizeof(int)); \
+        memset(new_flags, 0xaa, ac_fsize(new_n_buckets) * sizeof(int)); \
         if (h->n_buckets < new_n_buckets) {	/* expand */		\
           h->keys = pic_realloc(pic, (void *)h->keys, new_n_buckets * sizeof(khkey_t)); \
           if (kh_is_map) {                                              \
@@ -230,12 +216,10 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key)
 
 /* --- BEGIN OF HASH FUNCTIONS --- */
 
-#define kh_ptr_hash_func(key) (khint32_t)(long)(key)
+#define kh_ptr_hash_func(key) (int)(long)(key)
 #define kh_ptr_hash_equal(a, b) ((a) == (b))
-#define kh_int_hash_func(key) (khint32_t)(key)
+#define kh_int_hash_func(key) (int)(key)
 #define kh_int_hash_equal(a, b) ((a) == (b))
-#define kh_int64_hash_func(key) (khint32_t)((key)>>33^(key)^(key)<<11)
-#define kh_int64_hash_equal(a, b) ((a) == (b))
 #define kh_str_hash_func(key) ac_X31_hash_string(key)
 #define kh_str_hash_equal(a, b) (strcmp(a, b) == 0)
 #define kh_int_hash_func2(k) ac_Wang_hash((khint_t)key)

extlib/benz/include/picrin/opcode.h

@@ -0,0 +1,205 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#ifndef PICRIN_OPCODE_H
+#define PICRIN_OPCODE_H
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+enum pic_opcode {
+  OP_NOP,
+  OP_POP,
+  OP_PUSHUNDEF,
+  OP_PUSHNIL,
+  OP_PUSHTRUE,
+  OP_PUSHFALSE,
+  OP_PUSHINT,
+  OP_PUSHCHAR,
+  OP_PUSHCONST,
+  OP_GREF,
+  OP_GSET,
+  OP_LREF,
+  OP_LSET,
+  OP_CREF,
+  OP_CSET,
+  OP_JMP,
+  OP_JMPIF,
+  OP_NOT,
+  OP_CALL,
+  OP_TAILCALL,
+  OP_RET,
+  OP_LAMBDA,
+  OP_CONS,
+  OP_CAR,
+  OP_CDR,
+  OP_NILP,
+  OP_SYMBOLP,
+  OP_PAIRP,
+  OP_ADD,
+  OP_SUB,
+  OP_MUL,
+  OP_DIV,
+  OP_EQ,
+  OP_LT,
+  OP_LE,
+  OP_GT,
+  OP_GE,
+  OP_STOP
+};
+
+#define PIC_INIT_CODE_I(code, op, ival) do {    \
+    code.insn = op;                             \
+    code.u.i = ival;                            \
+  } while (0)
+
+#if DEBUG
+
+PIC_INLINE void
+pic_dump_code(pic_code c)
+{
+  printf("[%2d] ", c.insn);
+  switch (c.insn) {
+  case OP_NOP:
+    puts("OP_NOP");
+    break;
+  case OP_POP:
+    puts("OP_POP");
+    break;
+  case OP_PUSHUNDEF:
+    puts("OP_PUSHUNDEF");
+    break;
+  case OP_PUSHNIL:
+    puts("OP_PUSHNIL");
+    break;
+  case OP_PUSHTRUE:
+    puts("OP_PUSHTRUE");
+    break;
+  case OP_PUSHFALSE:
+    puts("OP_PUSHFALSE");
+    break;
+  case OP_PUSHINT:
+    printf("OP_PUSHINT\t%d\n", c.u.i);
+    break;
+  case OP_PUSHCHAR:
+    printf("OP_PUSHCHAR\t%c\n", c.u.c);
+    break;
+  case OP_PUSHCONST:
+    printf("OP_PUSHCONST\t%d\n", c.u.i);
+    break;
+  case OP_GREF:
+    printf("OP_GREF\t%i\n", c.u.i);
+    break;
+  case OP_GSET:
+    printf("OP_GSET\t%i\n", c.u.i);
+    break;
+  case OP_LREF:
+    printf("OP_LREF\t%d\n", c.u.i);
+    break;
+  case OP_LSET:
+    printf("OP_LSET\t%d\n", c.u.i);
+    break;
+  case OP_CREF:
+    printf("OP_CREF\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
+    break;
+  case OP_CSET:
+    printf("OP_CSET\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
+    break;
+  case OP_JMP:
+    printf("OP_JMP\t%x\n", c.u.i);
+    break;
+  case OP_JMPIF:
+    printf("OP_JMPIF\t%x\n", c.u.i);
+    break;
+  case OP_NOT:
+    puts("OP_NOT");
+    break;
+  case OP_CALL:
+    printf("OP_CALL\t%d\n", c.u.i);
+    break;
+  case OP_TAILCALL:
+    printf("OP_TAILCALL\t%d\n", c.u.i);
+    break;
+  case OP_RET:
+    puts("OP_RET");
+    break;
+  case OP_LAMBDA:
+    printf("OP_LAMBDA\t%d\n", c.u.i);
+    break;
+  case OP_CONS:
+    puts("OP_CONS");
+    break;
+  case OP_CAR:
+    puts("OP_CAR");
+    break;
+  case OP_NILP:
+    puts("OP_NILP");
+    break;
+  case OP_SYMBOLP:
+    puts("OP_SYMBOLP");
+    break;
+  case OP_PAIRP:
+    puts("OP_PAIRP");
+    break;
+  case OP_CDR:
+    puts("OP_CDR");
+    break;
+  case OP_ADD:
+    puts("OP_ADD");
+    break;
+  case OP_SUB:
+    puts("OP_SUB");
+    break;
+  case OP_MUL:
+    puts("OP_MUL");
+    break;
+  case OP_DIV:
+    puts("OP_DIV");
+    break;
+  case OP_EQ:
+    puts("OP_EQ");
+    break;
+  case OP_LT:
+    puts("OP_LT");
+    break;
+  case OP_LE:
+    puts("OP_LE");
+    break;
+  case OP_GT:
+    puts("OP_GT");
+    break;
+  case OP_GE:
+    puts("OP_GE");
+    break;
+  case OP_STOP:
+    puts("OP_STOP");
+    break;
+  }
+}
+
+PIC_INLINE void
+pic_dump_irep(struct pic_irep *irep)
+{
+  unsigned i;
+
+  printf("## irep %p\n", (void *)irep);
+  printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec);
+  for (i = 0; i < irep->clen; ++i) {
+    printf("%02x ", i);
+    pic_dump_code(irep->code[i]);
+  }
+
+  for (i = 0; i < irep->ilen; ++i) {
+    pic_dump_irep(irep->irep[i]);
+  }
+}
+
+#endif
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/string.h

@@ -22,7 +22,6 @@ void pic_rope_decref(pic_state *, struct pic_rope *);
 
 pic_str *pic_make_str(pic_state *, const char * /* nullable */, size_t);
 pic_str *pic_make_str_cstr(pic_state *, const char *);
-pic_str *pic_make_str_fill(pic_state *, size_t, char);
 
 char pic_str_ref(pic_state *, pic_str *, size_t);
 size_t pic_str_len(pic_str *);

extlib/benz/include/picrin/type.h

@@ -2,8 +2,8 @@
  * See Copyright Notice in picrin.h
  */
 
-#ifndef PICRIN_VALUE_H
-#define PICRIN_VALUE_H
+#ifndef PICRIN_TYPE_H
+#define PICRIN_TYPE_H
 
 #if defined(__cplusplus)
 extern "C" {
@@ -20,9 +20,7 @@ enum pic_vtype {
   PIC_VTYPE_FALSE,
   PIC_VTYPE_UNDEF,
   PIC_VTYPE_INVALID,
-#if PIC_ENABLE_FLOAT
   PIC_VTYPE_FLOAT,
-#endif
   PIC_VTYPE_INT,
   PIC_VTYPE_CHAR,
   PIC_VTYPE_EOF,
@@ -116,9 +114,7 @@ typedef struct {
   enum pic_vtype type;
   union {
     void *data;
-#if PIC_ENABLE_FLOAT
     double f;
-#endif
     int i;
     char c;
   } u;
@@ -128,9 +124,7 @@ typedef struct {
 #define pic_vtype(v) ((v).type)
 #define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL)
 
-#if PIC_ENABLE_FLOAT
-# define pic_float(v) ((v).u.f)
-#endif
+#define pic_float(v) ((v).u.f)
 #define pic_int(v) ((v).u.i)
 #define pic_char(v) ((v).u.c)
 
@@ -140,9 +134,7 @@ enum pic_tt {
   /* immediate */
   PIC_TT_NIL,
   PIC_TT_BOOL,
-#if PIC_ENABLE_FLOAT
   PIC_TT_FLOAT,
-#endif
   PIC_TT_INT,
   PIC_TT_CHAR,
   PIC_TT_EOF,
@@ -218,21 +210,12 @@ PIC_INLINE const char *pic_type_repr(enum pic_tt);
     pic_errorf(pic, "expected " #type ", but got ~s", v);       \
   }
 
-#if PIC_ENABLE_FLOAT
 PIC_INLINE bool
 pic_valid_int(double v)
 {
   return INT_MIN <= v && v <= INT_MAX;
 }
 
-#else
-PIC_INLINE bool
-pic_valid_int(int PIC_UNUSED(v))
-{
-  return true;
-}
-#endif
-
 PIC_INLINE pic_value pic_nil_value();
 PIC_INLINE pic_value pic_true_value();
 PIC_INLINE pic_value pic_false_value();
@@ -240,9 +223,7 @@ PIC_INLINE pic_value pic_bool_value(bool);
 PIC_INLINE pic_value pic_undef_value();
 PIC_INLINE pic_value pic_invalid_value();
 PIC_INLINE pic_value pic_obj_value(void *);
-#if PIC_ENABLE_FLOAT
 PIC_INLINE pic_value pic_float_value(double);
-#endif
 PIC_INLINE pic_value pic_int_value(int);
 PIC_INLINE pic_value pic_size_value(size_t);
 PIC_INLINE pic_value pic_char_value(char c);
@@ -264,10 +245,8 @@ pic_type(pic_value v)
     return PIC_TT_UNDEF;
   case PIC_VTYPE_INVALID:
     return PIC_TT_INVALID;
-#if PIC_ENABLE_FLOAT
   case PIC_VTYPE_FLOAT:
     return PIC_TT_FLOAT;
-#endif
   case PIC_VTYPE_INT:
     return PIC_TT_INT;
   case PIC_VTYPE_CHAR:
@@ -289,10 +268,8 @@ pic_type_repr(enum pic_tt tt)
     return "nil";
   case PIC_TT_BOOL:
     return "boolean";
-#if PIC_ENABLE_FLOAT
   case PIC_TT_FLOAT:
     return "float";
-#endif
   case PIC_TT_INT:
     return "int";
   case PIC_TT_SYMBOL:
@@ -382,13 +359,11 @@ pic_bool_value(bool b)
 PIC_INLINE pic_value
 pic_size_value(size_t s)
 {
-#if PIC_ENABLE_FLOAT
   if (sizeof(unsigned) < sizeof(size_t)) {
     if (s > (size_t)INT_MAX) {
       return pic_float_value(s);
     }
   }
-#endif
   return pic_int_value((int)s);
 }
 
@@ -472,8 +447,6 @@ pic_obj_value(void *ptr)
   return v;
 }
 
-#if PIC_ENABLE_FLOAT
-
 PIC_INLINE pic_value
 pic_float_value(double f)
 {
@@ -484,8 +457,6 @@ pic_float_value(double f)
   return v;
 }
 
-#endif
-
 PIC_INLINE pic_value
 pic_int_value(int i)
 {
@@ -569,10 +540,8 @@ pic_eqv_p(pic_value x, pic_value y)
     return true;
   case PIC_TT_BOOL:
     return pic_vtype(x) == pic_vtype(y);
-#if PIC_ENABLE_FLOAT
   case PIC_TT_FLOAT:
     return pic_float(x) == pic_float(y);
-#endif
   case PIC_TT_INT:
     return pic_int(x) == pic_int(y);
   default:
@@ -582,6 +551,59 @@ pic_eqv_p(pic_value x, pic_value y)
 
 #endif
 
+#define pic_define_aop(name, op, guard)                                 \
+  PIC_INLINE pic_value                                                  \
+  name(pic_state *pic, pic_value a, pic_value b)                        \
+  {                                                                     \
+    PIC_NORETURN void pic_errorf(pic_state *, const char *, ...);       \
+    double f;                                                           \
+    if (pic_int_p(a) && pic_int_p(b)) {                                 \
+      f = (double)pic_int(a) op (double)pic_int(b);                     \
+      return (INT_MIN <= f && f <= INT_MAX && guard)                    \
+        ? pic_int_value((int)f)                                         \
+        : pic_float_value(f);                                           \
+    } else if (pic_float_p(a) && pic_float_p(b)) {                      \
+      return pic_float_value(pic_float(a) op pic_float(b));             \
+    } else if (pic_int_p(a) && pic_float_p(b)) {                        \
+      return pic_float_value(pic_int(a) op pic_float(b));               \
+    } else if (pic_float_p(a) && pic_int_p(b)) {                        \
+      return pic_float_value(pic_float(a) op pic_int(b));               \
+    } else {                                                            \
+      pic_errorf(pic, #name ": non-number operand given");              \
+    }                                                                   \
+    PIC_UNREACHABLE();                                                  \
+  }
+
+pic_define_aop(pic_add, +, true)
+pic_define_aop(pic_sub, -, true)
+pic_define_aop(pic_mul, *, true)
+pic_define_aop(pic_div, /, f == (int)f)
+
+#define pic_define_cmp(name, op)                                        \
+  PIC_INLINE bool                                                       \
+  name(pic_state *pic, pic_value a, pic_value b)                        \
+  {                                                                     \
+    PIC_NORETURN void pic_errorf(pic_state *, const char *, ...);       \
+    if (pic_int_p(a) && pic_int_p(b)) {                                 \
+      return pic_int(a) op pic_int(b);                                  \
+    } else if (pic_float_p(a) && pic_float_p(b)) {                      \
+      return pic_float(a) op pic_float(b);                              \
+    } else if (pic_int_p(a) && pic_float_p(b)) {                        \
+      return pic_int(a) op pic_float(b);                                \
+    } else if (pic_float_p(a) && pic_int_p(b)) {                        \
+      return pic_float(a) op pic_int(b);                                \
+    } else {                                                            \
+      pic_errorf(pic, #name ": non-number operand given");              \
+    }                                                                   \
+    PIC_UNREACHABLE();                                                  \
+  }
+
+pic_define_cmp(pic_eq, ==)
+pic_define_cmp(pic_lt, <)
+pic_define_cmp(pic_le, <=)
+pic_define_cmp(pic_gt, >)
+pic_define_cmp(pic_ge, >=)
+
 #if defined(__cplusplus)
 }
 #endif

extlib/benz/include/picrin/vector.h

@@ -18,8 +18,7 @@ struct pic_vector {
 #define pic_vec_p(v) (pic_type(v) == PIC_TT_VECTOR)
 #define pic_vec_ptr(o) ((struct pic_vector *)pic_ptr(o))
 
-struct pic_vector *pic_make_vec(pic_state *, size_t);
-struct pic_vector *pic_make_vec_from_list(pic_state *, pic_value);
+pic_vec *pic_make_vec(pic_state *, size_t);
 
 #if defined(__cplusplus)
 }

extlib/benz/load.c

@@ -5,7 +5,7 @@
 #include "picrin.h"
 
 void
-pic_load_port(pic_state *pic, struct pic_port *port)
+pic_load(pic_state *pic, struct pic_port *port)
 {
   pic_value form;
   size_t ai = pic_gc_arena_preserve(pic);
@@ -23,7 +23,7 @@ pic_load_cstr(pic_state *pic, const char *src)
   struct pic_port *port = pic_open_input_string(pic, src);
 
   pic_try {
-    pic_load_port(pic, port);
+    pic_load(pic, port);
   }
   pic_catch {
     pic_close_port(pic, port);

extlib/benz/macro.c

@@ -56,7 +56,7 @@ pic_uniq(pic_state *pic, pic_value var)
 
   str = pic_format(pic, "%s.%d", pic_symbol_name(pic, pic_var_name(pic, var)), pic->ucnt++);
 
-  return pic_intern(pic, str);
+  return pic_intern_str(pic, str);
 }
 
 pic_sym *

extlib/benz/number.c

@@ -4,23 +4,119 @@
 
 #include "picrin.h"
 
-#if ! PIC_ENABLE_FLOAT
 static pic_value
-pic_number_id(pic_state *pic)
+pic_number_number_p(pic_state *pic)
 {
-  int i;
+  pic_value v;
 
-  pic_get_args(pic, "i", &i);
+  pic_get_args(pic, "o", &v);
 
-  return pic_int_value(i);
+  return pic_bool_value(pic_float_p(v) || pic_int_p(v));
 }
-#endif
 
-/**
- * Returns the length of string representing val.
- * radix is between 2 and 36 (inclusive).
- * No error checks are performed in this function.
- */
+static pic_value
+pic_number_exact_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_bool_value(pic_int_p(v));
+}
+
+static pic_value
+pic_number_inexact_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_bool_value(pic_float_p(v));
+}
+
+static pic_value
+pic_number_inexact(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+
+  return pic_float_value(f);
+}
+
+static pic_value
+pic_number_exact(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+
+  return pic_int_value((int)f);
+}
+
+#define DEFINE_CMP(op)                                  \
+  static pic_value                                      \
+  pic_number_##op(pic_state *pic)                       \
+  {                                                     \
+    size_t argc, i;                                     \
+    pic_value *argv;                                    \
+                                                        \
+    pic_get_args(pic, "*", &argc, &argv);               \
+                                                        \
+    if (argc < 2) {                                     \
+      return pic_true_value();                          \
+    }                                                   \
+                                                        \
+    for (i = 1; i < argc; ++i) {                        \
+      if (! pic_##op(pic, argv[i - 1], argv[i])) {      \
+        return pic_false_value();                       \
+      }                                                 \
+    }                                                   \
+    return pic_true_value();                            \
+  }
+
+DEFINE_CMP(eq)
+DEFINE_CMP(lt)
+DEFINE_CMP(le)
+DEFINE_CMP(gt)
+DEFINE_CMP(ge)
+
+#define DEFINE_AOP(op, v1, c0)                  \
+  static pic_value                              \
+  pic_number_##op(pic_state *pic)               \
+  {                                             \
+    size_t argc, i;                             \
+    pic_value *argv, tmp;                       \
+                                                \
+    pic_get_args(pic, "*", &argc, &argv);       \
+                                                \
+    if (argc == 0) {                            \
+      c0;                                       \
+    }                                           \
+    else if (argc == 1) {                       \
+      return v1;                                \
+    }                                           \
+                                                \
+    tmp = argv[0];                              \
+    for (i = 1; i < argc; ++i) {                \
+      tmp = pic_##op(pic, tmp, argv[i]);        \
+    }                                           \
+    return tmp;                                 \
+  }
+
+DEFINE_AOP(add, argv[0], do {
+    return pic_int_value(0);
+  } while (0))
+DEFINE_AOP(mul, argv[0], do {
+    return pic_int_value(1);
+  } while (0))
+DEFINE_AOP(sub, pic_sub(pic, pic_int_value(0), argv[0]), do {
+    pic_errorf(pic, "-: at least one argument required");
+  } while (0))
+DEFINE_AOP(div, pic_div(pic, pic_int_value(1), argv[0]), do {
+    pic_errorf(pic, "/: at least one argument required");
+  } while (0))
+
 static int
 number_string_length(int val, int radix)
 {
@@ -40,12 +136,6 @@ number_string_length(int val, int radix)
   return count;
 }
 
-/**
- * Returns the string representing val.
- * radix is between 2 and 36 (inclusive).
- * This function overwrites buffer and stores the result.
- * No error checks are performed in this function. It is caller's responsibility to avoid buffer-overrun.
- */
 static void
 number_string(int val, int radix, int length, char *buffer) {
   const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz";
@@ -69,485 +159,9 @@ number_string(int val, int radix, int length, char *buffer) {
   return;
 }
 
-static pic_value
-pic_number_real_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-#if PIC_ENABLE_FLOAT
-  return pic_bool_value(pic_float_p(v) || pic_int_p(v));
-#else
-  return pic_bool_value(pic_int_p(v));
-#endif
-}
-
-static pic_value
-pic_number_integer_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_int_p(v)) {
-    return pic_true_value();
-  }
-#if PIC_ENABLE_FLOAT
-  if (pic_float_p(v)) {
-    double f = pic_float(v);
-
-    if (isinf(f)) {
-      return pic_false_value();
-    }
-
-    if (f == round(f)) {
-      return pic_true_value();
-    }
-  }
-#endif
-  return pic_false_value();
-}
-
-static pic_value
-pic_number_exact_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_int_p(v));
-}
-
-static pic_value
-pic_number_inexact_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-#if PIC_ENABLE_FLOAT
-  return pic_bool_value(pic_float_p(v));
-#else
-  return pic_false_value();
-#endif
-}
-
-#define DEFINE_ARITH_CMP(op, name)			\
-  static pic_value					\
-  pic_number_##name(pic_state *pic)			\
-  {							\
-    size_t argc, i;                                     \
-    pic_value *argv;					\
-    double f,g;						\
-    							\
-    pic_get_args(pic, "ff*", &f, &g, &argc, &argv);	\
-    							\
-    if (! (f op g))					\
-      return pic_false_value();				\
-    							\
-    for (i = 0; i < argc; ++i) {			\
-      f = g;                                            \
-      if (pic_float_p(argv[i]))				\
-	g = pic_float(argv[i]);				\
-      else if (pic_int_p(argv[i]))			\
-	g = pic_int(argv[i]);				\
-      else						\
-	pic_errorf(pic, #op ": number required");	\
-      							\
-      if (! (f op g))					\
-	return pic_false_value();			\
-    }							\
-    							\
-    return pic_true_value();				\
-  }
-
-#define DEFINE_ARITH_CMP2(op, name)			\
-  static pic_value					\
-  pic_number_##name(pic_state *pic)			\
-  {							\
-    size_t argc, i;                                     \
-    pic_value *argv;					\
-    int f,g;						\
-    							\
-    pic_get_args(pic, "ii*", &f, &g, &argc, &argv);	\
-    							\
-    if (! (f op g))					\
-      return pic_false_value();				\
-    							\
-    for (i = 0; i < argc; ++i) {			\
-      f = g;                                            \
-      if (pic_int_p(argv[i]))                           \
-	g = pic_int(argv[i]);				\
-      else						\
-	pic_errorf(pic, #op ": number required");	\
-      							\
-      if (! (f op g))					\
-	return pic_false_value();			\
-    }							\
-    							\
-    return pic_true_value();				\
-  }
-
-#if PIC_ENABLE_FLOAT
-DEFINE_ARITH_CMP(==, eq)
-DEFINE_ARITH_CMP(<, lt)
-DEFINE_ARITH_CMP(>, gt)
-DEFINE_ARITH_CMP(<=, le)
-DEFINE_ARITH_CMP(>=, ge)
-#else
-DEFINE_ARITH_CMP2(==, eq)
-DEFINE_ARITH_CMP2(<, lt)
-DEFINE_ARITH_CMP2(>, gt)
-DEFINE_ARITH_CMP2(<=, le)
-DEFINE_ARITH_CMP2(>=, ge)
-#endif
-
-#define DEFINE_ARITH_OP(op, name, unit)                         \
-  static pic_value                                              \
-  pic_number_##name(pic_state *pic)                             \
-  {                                                             \
-    size_t argc, i;                                             \
-    pic_value *argv;                                            \
-    double f;                                                   \
-    bool e = true;                                              \
-                                                                \
-    pic_get_args(pic, "*", &argc, &argv);                       \
-                                                                \
-    f = unit;                                                   \
-    for (i = 0; i < argc; ++i) {                                \
-      if (pic_int_p(argv[i])) {                                 \
-        f op##= pic_int(argv[i]);                               \
-      }                                                         \
-      else if (pic_float_p(argv[i])) {                          \
-        e = false;                                              \
-        f op##= pic_float(argv[i]);                             \
-      }                                                         \
-      else {                                                    \
-        pic_errorf(pic, #op ": number required");               \
-      }                                                         \
-    }                                                           \
-                                                                \
-    return e ? pic_int_value((int)f) : pic_float_value(f);      \
-  }
-
-#define DEFINE_ARITH_OP2(op, name, unit)                        \
-  static pic_value                                              \
-  pic_number_##name(pic_state *pic)                             \
-  {                                                             \
-    size_t argc, i;                                             \
-    pic_value *argv;                                            \
-    int f;                                                      \
-                                                                \
-    pic_get_args(pic, "*", &argc, &argv);                       \
-                                                                \
-    f = unit;                                                   \
-    for (i = 0; i < argc; ++i) {                                \
-      if (pic_int_p(argv[i])) {                                 \
-        f op##= pic_int(argv[i]);                               \
-      }                                                         \
-      else {                                                    \
-        pic_errorf(pic, #op ": number required");               \
-      }                                                         \
-    }                                                           \
-                                                                \
-    return pic_int_value(f);                                    \
-  }
-
-#if PIC_ENABLE_FLOAT
-DEFINE_ARITH_OP(+, add, 0)
-DEFINE_ARITH_OP(*, mul, 1)
-#else
-DEFINE_ARITH_OP2(+, add, 0)
-DEFINE_ARITH_OP2(*, mul, 1)
-#endif
-
-#define DEFINE_ARITH_INV_OP(op, name, unit, exact)                      \
-  static pic_value                                                      \
-  pic_number_##name(pic_state *pic)                                     \
-  {                                                                     \
-    size_t argc, i;                                                     \
-    pic_value *argv;                                                    \
-    double f;                                                           \
-    bool e = true;                                                      \
-                                                                        \
-    pic_get_args(pic, "F*", &f, &e, &argc, &argv);                      \
-                                                                        \
-    e = e && exact;                                                     \
-                                                                        \
-    if (argc == 0) {                                                    \
-      f = unit op f;                                                    \
-    }                                                                   \
-    for (i = 0; i < argc; ++i) {                                        \
-      if (pic_int_p(argv[i])) {                                         \
-        f op##= pic_int(argv[i]);                                       \
-      }                                                                 \
-      else if (pic_float_p(argv[i])) {                                  \
-        e = false;                                                      \
-        f op##= pic_float(argv[i]);                                     \
-      }                                                                 \
-      else {                                                            \
-        pic_errorf(pic, #op ": number required");                       \
-      }                                                                 \
-    }                                                                   \
-                                                                        \
-    return e ? pic_int_value((int)f) : pic_float_value(f);              \
-  }
-
-#define DEFINE_ARITH_INV_OP2(op, name, unit)                            \
-  static pic_value                                                      \
-  pic_number_##name(pic_state *pic)                                     \
-  {                                                                     \
-    size_t argc, i;                                                     \
-    pic_value *argv;                                                    \
-    int f;                                                              \
-                                                                        \
-    pic_get_args(pic, "i*", &f, &argc, &argv);                          \
-                                                                        \
-    if (argc == 0) {                                                    \
-      f = unit op f;                                                    \
-    }                                                                   \
-    for (i = 0; i < argc; ++i) {                                        \
-      if (pic_int_p(argv[i])) {                                         \
-        f op##= pic_int(argv[i]);                                       \
-      }                                                                 \
-      else {                                                            \
-        pic_errorf(pic, #op ": number required");                       \
-      }                                                                 \
-    }                                                                   \
-                                                                        \
-    return pic_int_value(f);                                            \
-  }
-
-#if PIC_ENABLE_FLOAT
-DEFINE_ARITH_INV_OP(-, sub, 0, true)
-DEFINE_ARITH_INV_OP(/, div, 1, false)
-#else
-DEFINE_ARITH_INV_OP2(-, sub, 0)
-DEFINE_ARITH_INV_OP2(/, div, 1)
-#endif
-
-static pic_value
-pic_number_abs(pic_state *pic)
-{
-#if PIC_ENABLE_FLOAT
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value(f < 0 ? -f : f);
-  }
-  else {
-    return pic_float_value(fabs(f));
-  }
-#else
-  int i;
-
-  pic_get_args(pic, "i", &i);
-
-  return pic_int_value(i < 0 ? -i : i);
-#endif
-}
-
-static pic_value
-pic_number_expt(pic_state *pic)
-{
-#if PIC_ENABLE_FLOAT
-  double f, g, h;
-  bool e1, e2;
-
-  pic_get_args(pic, "FF", &f, &e1, &g, &e2);
-
-  h = pow(f, g);
-  if (e1 && e2) {
-    if (h <= INT_MAX) {
-      return pic_int_value((int)h);
-    }
-  }
-  return pic_float_value(h);
-#else
-  int x, y, i, e = 1, r = 1, s = 0;
-
-  pic_get_args(pic, "ii", &x, &y);
-
-  if (y < 0) {
-    s = 1;
-    y = -y;
-  }
-  e = x;
-  for (i = 0; y; ++i) {
-    if ((y & 1) != 0) {
-      r *= e;
-    }
-    e *= e;
-    y >>= 1;
-  }
-  if (s != 0) {
-    r = 1 / r;
-  }
-  return pic_int_value(r);
-#endif
-}
-
-static pic_value
-pic_number_floor2(pic_state *pic)
-{
-#if PIC_ENABLE_FLOAT
-  int i, j;
-  bool e1, e2;
-
-  pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
-  if (e1 && e2) {
-    int k;
-
-    k = (i < 0 && j < 0) || (0 <= i && 0 <= j)
-      ? i / j
-      : (i / j) - 1;
-
-    return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j));
-  }
-  else {
-    double q, r;
-
-    q = floor((double)i/j);
-    r = i - j * q;
-    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
-  }
-#else
-  int i, j, k;
-
-  pic_get_args(pic, "ii", &i, &j);
-
-  k = (i < 0 && j < 0) || (0 <= i && 0 <= j)
-    ? i / j
-    : (i / j) - 1;
-
-  return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j));
-#endif
-}
-
-static pic_value
-pic_number_trunc2(pic_state *pic)
-{
-#if PIC_ENABLE_FLOAT
-  int i, j;
-  bool e1, e2;
-
-  pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
-  if (e1 && e2) {
-    return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j));
-  }
-  else {
-    double q, r;
-
-    q = trunc((double)i/j);
-    r = i - j * q;
-
-    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
-  }
-#else
-  int i, j;
-
-  pic_get_args(pic, "ii", &i, &j);
-
-  return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j));
-#endif
-}
-
-#if PIC_ENABLE_FLOAT
-static pic_value
-pic_number_floor(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value((int)f);
-  }
-  else {
-    return pic_float_value(floor(f));
-  }
-}
-
-static pic_value
-pic_number_ceil(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value((int)f);
-  }
-  else {
-    return pic_float_value(ceil(f));
-  }
-}
-
-static pic_value
-pic_number_trunc(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value((int)f);
-  }
-  else {
-    return pic_float_value(trunc(f));
-  }
-}
-
-static pic_value
-pic_number_round(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value((int)f);
-  }
-  else {
-    return pic_float_value(round(f));
-  }
-}
-
-static pic_value
-pic_number_inexact(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_exact(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_int_value((int)(round(f)));
-}
-#endif
-
 static pic_value
 pic_number_number_to_string(pic_state *pic)
 {
-#if PIC_ENABLE_FLOAT
   double f;
   bool e;
   int radix = 10;
@@ -582,46 +196,16 @@ pic_number_number_to_string(pic_state *pic)
   }
 
   return pic_obj_value(str);
-#else
-  int f;
-  bool e;
-  int radix = 10;
-  pic_str *str;
-  size_t s;
-  char *buf;
-  int ival, ilen;
-
-  pic_get_args(pic, "i|i", &f, &e, &radix);
-
-  if (radix < 2 || radix > 36) {
-    pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix);
-  }
-
-  ival = f;
-  ilen = number_string_length(ival, radix);
-  s = ilen + 1;
-
-  buf = pic_malloc(pic, s);
-
-  number_string(ival, radix, ilen, buf);
-
-  str = pic_make_str(pic, buf, s - 1);
-
-  pic_free(pic, buf);
-
-  return pic_obj_value(str);
-#endif
 }
 
 static pic_value
 pic_number_string_to_number(pic_state *pic)
 {
-#if PIC_ENABLE_FLOAT
   const char *str;
   int radix = 10;
   long num;
   char *eptr;
-  double flo;
+  pic_value flo;
 
   pic_get_args(pic, "z|i", &str, &radix);
 
@@ -632,246 +216,44 @@ pic_number_string_to_number(pic_state *pic)
       : pic_float_value(num);
   }
 
-  flo = strtod(str, &eptr);
-  if (*eptr == '\0') {
-    return pic_float_value(flo);
+  flo = pic_read_cstr(pic, str);
+  if (pic_int_p(flo) || pic_float_p(flo)) {
+    return flo;
   }
 
   pic_errorf(pic, "invalid string given: %s", str);
-#else
-  const char *str;
-  int radix = 10;
-  long num;
-  char *eptr;
-
-  pic_get_args(pic, "z|i", &str, &radix);
-
-  num = strtol(str, &eptr, radix);
-  if (*eptr == '\0') {
-    return pic_int_value(num);
-  }
-
-  pic_errorf(pic, "invalid string given: %s", str);
-#endif
 }
 
-#if PIC_ENABLE_FLOAT
-static pic_value
-pic_number_finite_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_int_p(v))
-    return pic_true_value();
-  if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v))))
-    return pic_true_value();
-  else
-    return pic_false_value();
-}
-
-static pic_value
-pic_number_infinite_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_float_p(v) && isinf(pic_float(v)))
-    return pic_true_value();
-  else
-    return pic_false_value();
-}
-
-static pic_value
-pic_number_nan_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_float_p(v) && isnan(pic_float(v)))
-    return pic_true_value();
-  else
-    return pic_false_value();
-}
-
-static pic_value
-pic_number_exp(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  return pic_float_value(exp(f));
-}
-
-static pic_value
-pic_number_log(pic_state *pic)
-{
-  double f,g;
-  int argc;
-
-  argc = pic_get_args(pic, "f|f", &f, &g);
-  if (argc == 1) {
-    return pic_float_value(log(f));
-  }
-  else {
-    return pic_float_value(log(f) / log(g));
-  }
-}
-
-static pic_value
-pic_number_sin(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = sin(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_cos(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = cos(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_tan(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = tan(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_acos(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = acos(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_asin(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = asin(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_atan(pic_state *pic)
-{
-  double f,g;
-  int argc;
-
-  argc = pic_get_args(pic, "f|f", &f, &g);
-  if (argc == 1) {
-    f = atan(f);
-    return pic_float_value(f);
-  }
-  else {
-    return pic_float_value(atan2(f,g));
-  }
-}
-
-static pic_value
-pic_number_sqrt(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_float_value(sqrt(f));
-}
-#endif
-
 void
 pic_init_number(pic_state *pic)
 {
-  void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
-
   size_t ai = pic_gc_arena_preserve(pic);
 
-  pic_defun(pic, "number?", pic_number_real_p);
-  pic_defun(pic, "complex?", pic_number_real_p);
-  pic_defun(pic, "real?", pic_number_real_p);
-  pic_defun(pic, "rational?", pic_number_real_p);
-  pic_defun(pic, "integer?", pic_number_integer_p);
+  pic_defun(pic, "number?", pic_number_number_p);
   pic_gc_arena_restore(pic, ai);
 
   pic_defun(pic, "exact?", pic_number_exact_p);
   pic_defun(pic, "inexact?", pic_number_inexact_p);
   pic_gc_arena_restore(pic, ai);
 
-  pic_defun_vm(pic, "=", pic->uEQ, pic_number_eq);
-  pic_defun_vm(pic, "<", pic->uLT, pic_number_lt);
-  pic_defun_vm(pic, ">", pic->uGT, pic_number_gt);
-  pic_defun_vm(pic, "<=", pic->uLE, pic_number_le);
-  pic_defun_vm(pic, ">=", pic->uGE, pic_number_ge);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun_vm(pic, "+", pic->uADD, pic_number_add);
-  pic_defun_vm(pic, "-", pic->uSUB, pic_number_sub);
-  pic_defun_vm(pic, "*", pic->uMUL, pic_number_mul);
-  pic_defun_vm(pic, "/", pic->uDIV, pic_number_div);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "abs", pic_number_abs);
-  pic_defun(pic, "expt", pic_number_expt);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "floor/", pic_number_floor2);
-  pic_defun(pic, "truncate/", pic_number_trunc2);
-  pic_gc_arena_restore(pic, ai);
-
-#if PIC_ENABLE_FLOAT
-  pic_defun(pic, "floor", pic_number_floor);
-  pic_defun(pic, "ceiling", pic_number_ceil);
-  pic_defun(pic, "truncate", pic_number_trunc);
-  pic_defun(pic, "round", pic_number_round);
   pic_defun(pic, "inexact", pic_number_inexact);
   pic_defun(pic, "exact", pic_number_exact);
   pic_gc_arena_restore(pic, ai);
-#else
-  pic_defun(pic, "floor", pic_number_id);
-  pic_defun(pic, "ceiling", pic_number_id);
-  pic_defun(pic, "truncate", pic_number_id);
-  pic_defun(pic, "round", pic_number_id);
-  pic_defun(pic, "inexact", pic_number_id);
-  pic_defun(pic, "exact", pic_number_id);
+
+  pic_defun(pic, "=", pic_number_eq);
+  pic_defun(pic, "<", pic_number_lt);
+  pic_defun(pic, ">", pic_number_gt);
+  pic_defun(pic, "<=", pic_number_le);
+  pic_defun(pic, ">=", pic_number_ge);
+  pic_gc_arena_restore(pic, ai);
+
+  pic_defun(pic, "+", pic_number_add);
+  pic_defun(pic, "-", pic_number_sub);
+  pic_defun(pic, "*", pic_number_mul);
+  pic_defun(pic, "/", pic_number_div);
   pic_gc_arena_restore(pic, ai);
-#endif
 
   pic_defun(pic, "number->string", pic_number_number_to_string);
   pic_defun(pic, "string->number", pic_number_string_to_number);
   pic_gc_arena_restore(pic, ai);
-
-#if PIC_ENABLE_FLOAT
-  pic_defun(pic, "finite?", pic_number_finite_p);
-  pic_defun(pic, "infinite?", pic_number_infinite_p);
-  pic_defun(pic, "nan?", pic_number_nan_p);
-  pic_defun(pic, "sqrt", pic_number_sqrt);
-  pic_defun(pic, "exp", pic_number_exp);
-  pic_defun(pic, "log", pic_number_log);
-  pic_defun(pic, "sin", pic_number_sin);
-  pic_defun(pic, "cos", pic_number_cos);
-  pic_defun(pic, "tan", pic_number_tan);
-  pic_defun(pic, "acos", pic_number_acos);
-  pic_defun(pic, "asin", pic_number_asin);
-  pic_defun(pic, "atan", pic_number_atan);
-  pic_gc_arena_restore(pic, ai);
-#endif
 }

extlib/benz/pair.c

@@ -760,13 +760,11 @@ pic_pair_assoc(pic_state *pic)
 void
 pic_init_pair(pic_state *pic)
 {
-  void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
-
-  pic_defun_vm(pic, "pair?", pic->uPAIRP, pic_pair_pair_p);
-  pic_defun_vm(pic, "cons", pic->uCONS, pic_pair_cons);
-  pic_defun_vm(pic, "car", pic->uCAR, pic_pair_car);
-  pic_defun_vm(pic, "cdr", pic->uCDR, pic_pair_cdr);
-  pic_defun_vm(pic, "null?", pic->uNILP, pic_pair_null_p);
+  pic_defun(pic, "pair?", pic_pair_pair_p);
+  pic_defun(pic, "cons", pic_pair_cons);
+  pic_defun(pic, "car", pic_pair_car);
+  pic_defun(pic, "cdr", pic_pair_cdr);
+  pic_defun(pic, "null?", pic_pair_null_p);
 
   pic_defun(pic, "set-car!", pic_pair_set_car);
   pic_defun(pic, "set-cdr!", pic_pair_set_cdr);

extlib/benz/port.c

@@ -98,6 +98,16 @@ file_open(pic_state *pic, const char *name, const char *mode) {
   }
 }
 
+PIC_NORETURN static void
+file_error(pic_state *pic, const char *msg)
+{
+  struct pic_error *e;
+
+  e = pic_make_error(pic, pic_intern(pic, "file"), msg, pic_nil_value());
+
+  pic_raise(pic, pic_obj_value(e));
+}
+
 struct pic_port *
 pic_open_file(pic_state *pic, const char *name, int flags) {
   struct pic_port *port;
@@ -108,8 +118,7 @@ pic_open_file(pic_state *pic, const char *name, int flags) {
     mode = 'w';
   }
   if ((file = file_open(pic, name, &mode)) == NULL) {
-    pic_str *msg = pic_format(pic, "could not open file '%s'", name);
-    pic_raise(pic, pic_obj_value(pic_make_error(pic, pic->sFILE, pic_str_cstr(pic, msg), pic_nil_value())));
+    file_error(pic, pic_str_cstr(pic, pic_format(pic, "could not open file '%s'", name)));
   }
 
   port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);

extlib/benz/proc.c

@@ -42,19 +42,19 @@ pic_proc_env(pic_state *pic, struct pic_proc *proc)
 bool
 pic_proc_env_has(pic_state *pic, struct pic_proc *proc, const char *key)
 {
-  return pic_dict_has(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key));
+  return pic_dict_has(pic, pic_proc_env(pic, proc), pic_intern(pic, key));
 }
 
 pic_value
 pic_proc_env_ref(pic_state *pic, struct pic_proc *proc, const char *key)
 {
-  return pic_dict_ref(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key));
+  return pic_dict_ref(pic, pic_proc_env(pic, proc), pic_intern(pic, key));
 }
 
 void
 pic_proc_env_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value val)
 {
-  pic_dict_set(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key), val);
+  pic_dict_set(pic, pic_proc_env(pic, proc), pic_intern(pic, key), val);
 }
 
 static pic_value
@@ -86,7 +86,7 @@ pic_proc_apply(pic_state *pic)
     arg_list = pic_cons(pic, args[argc], arg_list);
   }
 
-  return pic_apply_trampoline(pic, proc, arg_list);
+  return pic_apply_trampoline_list(pic, proc, arg_list);
 }
 
 void

extlib/benz/read.c

@@ -14,7 +14,7 @@ read_error(pic_state *pic, const char *msg)
 {
   struct pic_error *e;
 
-  e = pic_make_error(pic, pic->sREAD, msg, pic_nil_value());
+  e = pic_make_error(pic, pic_intern(pic, "read"), msg, pic_nil_value());
 
   pic_raise(pic, pic_obj_value(e));
 }
@@ -64,7 +64,6 @@ isdelim(int c)
   return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
 }
 
-#if PIC_ENABLE_FLOAT
 static bool
 strcaseeq(const char *s1, const char *s2)
 {
@@ -76,7 +75,6 @@ strcaseeq(const char *s1, const char *s2)
   }
   return a == b;
 }
-#endif
 
 static int
 case_fold(pic_state *pic, int c)
@@ -216,7 +214,7 @@ read_symbol(pic_state *pic, struct pic_port *port, int c)
     buf[len] = 0;
   }
 
-  sym = pic_intern_cstr(pic, buf);
+  sym = pic_intern(pic, buf);
   pic_free(pic, buf);
 
   return pic_obj_value(sym);
@@ -267,22 +265,35 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c)
 {
   unsigned u;
   int exp, s, i, e;
-#if PIC_ENABLE_FLOAT
-  double f, g;
-#endif
 
   u = read_uinteger(pic, port, c);
 
   switch (peek(pic, port)) {
-#if PIC_ENABLE_FLOAT
-  case '.':
+#if PIC_ENABLE_LIBC
+  case '.': {
+    char buf[256];
+    i = sprintf(buf, "%d", u);
+    buf[i++] = next(pic, port);
+    while (isdigit(c = peek(pic, port))) {
+      buf[i++] = next(pic, port);
+    }
+    sprintf(buf + i, "e%d", read_suffix(pic, port));
+    return pic_float_value(atof(buf));
+  }
+#else
+  case '.': {
+    double f, g, h;
     next(pic, port);
     g = 0, e = 0;
     while (isdigit(c = peek(pic, port))) {
       g = g * 10 + (next(pic, port) - '0');
       e++;
     }
-    f = u + g * pow(10, -e);
+    h = 1.0;
+    while (e-- > 0) {
+      h /= 10;
+    }
+    f = u + g * h;
 
     exp = read_suffix(pic, port);
     if (exp >= 0) {
@@ -301,6 +312,7 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c)
       exp >>= 1;
     }
     return pic_float_value(f);
+  }
 #endif
 
   default:
@@ -334,15 +346,11 @@ read_number(pic_state *pic, struct pic_port *port, int c)
 static pic_value
 negate(pic_value n)
 {
-#if PIC_ENABLE_FLOAT
   if (pic_int_p(n)) {
     return pic_int_value(-pic_int(n));
   } else {
     return pic_float_value(-pic_float(n));
   }
-#else
-  return pic_int_value(-pic_int(n));
-#endif
 }
 
 static pic_value
@@ -355,14 +363,12 @@ read_minus(pic_state *pic, struct pic_port *port, int c)
   }
   else {
     sym = read_symbol(pic, port, c);
-#if PIC_ENABLE_FLOAT
     if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-inf.0")) {
-      return pic_float_value(-INFINITY);
+      return pic_float_value(-(1.0 / 0.0));
     }
     if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) {
-      return pic_float_value(-NAN);
+      return pic_float_value(-(0.0 / 0.0));
     }
-#endif
     return sym;
   }
 }
@@ -377,14 +383,12 @@ read_plus(pic_state *pic, struct pic_port *port, int c)
   }
   else {
     sym = read_symbol(pic, port, c);
-#if PIC_ENABLE_FLOAT
     if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+inf.0")) {
-      return pic_float_value(INFINITY);
+      return pic_float_value(1.0 / 0.0);
     }
     if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) {
-      return pic_float_value(NAN);
+      return pic_float_value(0.0 / 0.0);
     }
-#endif
     return sym;
   }
 }
@@ -525,7 +529,7 @@ read_pipe(pic_state *pic, struct pic_port *port, int c)
   }
   buf[cnt] = '\0';
 
-  sym = pic_intern_cstr(pic, buf);
+  sym = pic_intern(pic, buf);
   pic_free(pic, buf);
 
   return pic_obj_value(sym);
@@ -631,11 +635,19 @@ read_pair(pic_state *pic, struct pic_port *port, int c)
 static pic_value
 read_vector(pic_state *pic, struct pic_port *port, int c)
 {
-  pic_value list;
+  pic_value list, it, elem;
+  pic_vec *vec;
+  size_t i = 0;
 
   list = read(pic, port, c);
 
-  return pic_obj_value(pic_make_vec_from_list(pic, list));
+  vec = pic_make_vec(pic, pic_length(pic, list));
+
+  pic_for_each (elem, list, it) {
+    vec->data[i++] = elem;
+  }
+
+  return pic_obj_value(vec);
 }
 
 static pic_value
@@ -855,24 +867,24 @@ pic_reader_destroy(pic_state *pic)
 pic_value
 pic_read(pic_state *pic, struct pic_port *port)
 {
+  size_t ai = pic_gc_arena_preserve(pic);
   pic_value val;
-  int c = next(pic, port);
+  int c;
 
- retry:
-  c = skip(pic, port, c);
+  while ((c = skip(pic, port, next(pic, port))) != EOF) {
+    val = read_nullable(pic, port, c);
 
+    if (! pic_invalid_p(val)) {
+      break;
+    }
+    pic_gc_arena_restore(pic, ai);
+  }
   if (c == EOF) {
     return pic_eof_object();
   }
 
-  val = read_nullable(pic, port, c);
-
-  if (pic_invalid_p(val)) {
-    c = next(pic, port);
-    goto retry;
-  }
-
-  return val;
+  pic_gc_arena_restore(pic, ai);
+  return pic_gc_protect(pic, val);
 }
 
 pic_value

extlib/benz/record.c

@@ -15,7 +15,7 @@ pic_make_record(pic_state *pic, pic_value rectype)
   rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD);
   rec->data = data;
 
-  pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype);
+  pic_record_set(pic, rec, pic_intern(pic, "@@type"), rectype);
 
   return rec;
 }
@@ -23,7 +23,7 @@ pic_make_record(pic_state *pic, pic_value rectype)
 pic_value
 pic_record_type(pic_state *pic, struct pic_record *rec)
 {
-  return pic_record_ref(pic, rec, pic_intern_cstr(pic, "@@type"));
+  return pic_record_ref(pic, rec, pic_intern(pic, "@@type"));
 }
 
 pic_value

extlib/benz/reg.c

@@ -66,9 +66,9 @@ static pic_value
 reg_get(pic_state *pic, struct pic_reg *reg, void *key)
 {
   if (! pic_reg_has(pic, reg, key)) {
-    return pic_undef_value();
+    return pic_false_value();
   }
-  return pic_reg_ref(pic, reg, key);
+  return pic_cons(pic, pic_obj_value(key), pic_reg_ref(pic, reg, key));
 }
 
 static pic_value

extlib/benz/state.c

@@ -15,10 +15,9 @@ pic_set_argv(pic_state *pic, int argc, char *argv[], char **envp)
 void
 pic_add_feature(pic_state *pic, const char *feature)
 {
-  pic_push(pic, pic_obj_value(pic_intern_cstr(pic, feature)), pic->features);
+  pic_push(pic, pic_obj_value(pic_intern(pic, feature)), pic->features);
 }
 
-void pic_init_undef(pic_state *);
 void pic_init_bool(pic_state *);
 void pic_init_pair(pic_state *);
 void pic_init_port(pic_state *);
@@ -48,7 +47,10 @@ static void
 pic_init_features(pic_state *pic)
 {
   pic_add_feature(pic, "picrin");
+
+#if __STDC_IEC_559__
   pic_add_feature(pic, "ieee-float");
+#endif
 
 #if _POSIX_SOURCE
   pic_add_feature(pic, "posix");
@@ -110,12 +112,22 @@ pic_features(pic_state *pic)
 #define DONE pic_gc_arena_restore(pic, ai);
 
 #define define_builtin_syntax(uid, name)                                \
-  pic_define_syntactic_keyword_(pic, pic->lib->env, pic_intern_cstr(pic, name), uid)
+  pic_define_syntactic_keyword_(pic, pic->lib->env, pic_intern(pic, name), uid)
+
+#define VM(uid, name)                                                   \
+  pic_define_syntactic_keyword_(pic, pic->lib->env, pic_intern(pic, name), uid)
+
+#define VM3(name)                                       \
+  pic->c##name = pic_vm_gref_slot(pic, pic->u##name);
+
+#define VM2(proc, name)                         \
+  proc = pic_ref(pic, pic->lib, name)
 
 static void
 pic_init_core(pic_state *pic)
 {
   void pic_define_syntactic_keyword_(pic_state *, struct pic_env *, pic_sym *, pic_sym *);
+  pic_value pic_vm_gref_slot(pic_state *, pic_sym *);
 
   pic_init_features(pic);
 
@@ -132,7 +144,23 @@ pic_init_core(pic_state *pic)
 
     pic_defun(pic, "features", pic_features);
 
-    pic_init_undef(pic); DONE;
+    VM(pic->uCONS, "cons");
+    VM(pic->uCAR, "car");
+    VM(pic->uCDR, "cdr");
+    VM(pic->uNILP, "null?");
+    VM(pic->uSYMBOLP, "symbol?");
+    VM(pic->uPAIRP, "pair?");
+    VM(pic->uNOT, "not");
+    VM(pic->uADD, "+");
+    VM(pic->uSUB, "-");
+    VM(pic->uMUL, "*");
+    VM(pic->uDIV, "/");
+    VM(pic->uEQ, "=");
+    VM(pic->uLT, "<");
+    VM(pic->uLE, "<=");
+    VM(pic->uGT, ">");
+    VM(pic->uGE, ">=");
+
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
     pic_init_port(pic); DONE;
@@ -156,10 +184,48 @@ pic_init_core(pic_state *pic)
     pic_init_attr(pic); DONE;
     pic_init_reg(pic); DONE;
 
-    pic_load_cstr(pic, &pic_boot[0][0]);
-  }
+    VM3(CONS);
+    VM3(CAR);
+    VM3(CDR);
+    VM3(NILP);
+    VM3(SYMBOLP);
+    VM3(PAIRP);
+    VM3(NOT);
+    VM3(ADD);
+    VM3(SUB);
+    VM3(MUL);
+    VM3(DIV);
+    VM3(EQ);
+    VM3(LT);
+    VM3(LE);
+    VM3(GT);
+    VM3(GE);
 
-  pic_import(pic, pic->PICRIN_BASE);
+    VM2(pic->pCONS, "cons");
+    VM2(pic->pCAR, "car");
+    VM2(pic->pCDR, "cdr");
+    VM2(pic->pNILP, "null?");
+    VM2(pic->pSYMBOLP, "symbol?");
+    VM2(pic->pPAIRP, "pair?");
+    VM2(pic->pNOT, "not");
+    VM2(pic->pADD, "+");
+    VM2(pic->pSUB, "-");
+    VM2(pic->pMUL, "*");
+    VM2(pic->pDIV, "/");
+    VM2(pic->pEQ, "=");
+    VM2(pic->pLT, "<");
+    VM2(pic->pLE, "<=");
+    VM2(pic->pGT, ">");
+    VM2(pic->pGE, ">=");
+
+    pic_try {
+      pic_load_cstr(pic, &pic_boot[0][0]);
+    }
+    pic_catch {
+      pic_print_backtrace(pic, xstdout);
+      pic_panic(pic, "");
+    }
+  }
 }
 
 pic_state *
@@ -273,13 +339,8 @@ pic_open(pic_allocf allocf, void *userdata)
 
   ai = pic_gc_arena_preserve(pic);
 
-#define S(slot,name) pic->slot = pic_intern_cstr(pic, name)
+#define S(slot,name) pic->slot = pic_intern(pic, name)
 
-  S(sDEFINE, "define");
-  S(sLAMBDA, "lambda");
-  S(sIF, "if");
-  S(sBEGIN, "begin");
-  S(sSETBANG, "set!");
   S(sQUOTE, "quote");
   S(sQUASIQUOTE, "quasiquote");
   S(sUNQUOTE, "unquote");
@@ -288,50 +349,18 @@ pic_open(pic_allocf allocf, void *userdata)
   S(sSYNTAX_QUASIQUOTE, "syntax-quasiquote");
   S(sSYNTAX_UNQUOTE, "syntax-unquote");
   S(sSYNTAX_UNQUOTE_SPLICING, "syntax-unquote-splicing");
-  S(sDEFINE_MACRO, "define-macro");
   S(sIMPORT, "import");
   S(sEXPORT, "export");
   S(sDEFINE_LIBRARY, "define-library");
   S(sCOND_EXPAND, "cond-expand");
-  S(sAND, "and");
-  S(sOR, "or");
-  S(sELSE, "else");
-  S(sLIBRARY, "library");
-  S(sONLY, "only");
-  S(sRENAME, "rename");
-  S(sPREFIX, "prefix");
-  S(sEXCEPT, "except");
-  S(sCONS, "cons");
-  S(sCAR, "car");
-  S(sCDR, "cdr");
-  S(sNILP, "null?");
-  S(sSYMBOLP, "symbol?");
-  S(sPAIRP, "pair?");
-  S(sADD, "+");
-  S(sSUB, "-");
-  S(sMUL, "*");
-  S(sDIV, "/");
-  S(sMINUS, "minus");
-  S(sEQ, "=");
-  S(sLT, "<");
-  S(sLE, "<=");
-  S(sGT, ">");
-  S(sGE, ">=");
-  S(sNOT, "not");
-  S(sREAD, "read");
-  S(sFILE, "file");
   S(sCALL, "call");
-  S(sTAILCALL, "tail-call");
   S(sGREF, "gref");
   S(sLREF, "lref");
   S(sCREF, "cref");
-  S(sRETURN, "return");
-  S(sCALL_WITH_VALUES, "call-with-values");
-  S(sTAILCALL_WITH_VALUES, "tailcall-with-values");
 
   pic_gc_arena_restore(pic, ai);
 
-#define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern_cstr(pic, name)))
+#define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern(pic, name)))
 
   U(uDEFINE, "define");
   U(uLAMBDA, "lambda");
@@ -360,10 +389,26 @@ pic_open(pic_allocf allocf, void *userdata)
   U(uGT, ">");
   U(uGE, ">=");
   U(uNOT, "not");
-  U(uVALUES, "values");
-  U(uCALL_WITH_VALUES, "call-with-values");
   pic_gc_arena_restore(pic, ai);
 
+  /* system procedures */
+  pic->pCONS = pic_invalid_value();
+  pic->pCAR = pic_invalid_value();
+  pic->pCDR = pic_invalid_value();
+  pic->pNILP = pic_invalid_value();
+  pic->pSYMBOLP = pic_invalid_value();
+  pic->pPAIRP = pic_invalid_value();
+  pic->pNOT = pic_invalid_value();
+  pic->pADD = pic_invalid_value();
+  pic->pSUB = pic_invalid_value();
+  pic->pMUL = pic_invalid_value();
+  pic->pDIV = pic_invalid_value();
+  pic->pEQ = pic_invalid_value();
+  pic->pLT = pic_invalid_value();
+  pic->pLE = pic_invalid_value();
+  pic->pGT = pic_invalid_value();
+  pic->pGE = pic_invalid_value();
+
   /* root tables */
   pic->globals = pic_make_dict(pic);
   pic->macros = pic_make_dict(pic);
@@ -392,6 +437,23 @@ pic_open(pic_allocf allocf, void *userdata)
   /* turn on GC */
   pic->gc_enable = true;
 
+  pic->cCONS = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cCAR = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cCDR = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cNILP = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cSYMBOLP = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cPAIRP = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cNOT = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cADD = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cSUB = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cMUL = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cDIV = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cEQ = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cLT = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cLE = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cGT = pic_cons(pic, pic_false_value(), pic_invalid_value());
+  pic->cGE = pic_cons(pic, pic_false_value(), pic_invalid_value());
+
   pic_init_core(pic);
 
   pic_gc_arena_restore(pic, ai);

extlib/benz/string.c

@@ -240,25 +240,6 @@ pic_make_str_cstr(pic_state *pic, const char *cstr)
   return pic_make_str(pic, cstr, strlen(cstr));
 }
 
-pic_str *
-pic_make_str_fill(pic_state *pic, size_t len, char fill)
-{
-  size_t i;
-  char *buf = pic_malloc(pic, len);
-  pic_str *str;
-
-  for (i = 0; i < len; ++i) {
-    buf[i] = fill;
-  }
-  buf[i] = '\0';
-
-  str = pic_make_str(pic, buf, len);
-
-  pic_free(pic, buf);
-
-  return str;
-}
-
 size_t
 pic_str_len(pic_str *str)
 {
@@ -335,11 +316,9 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
       case 'p':
         xfprintf(pic, file, "%p", va_arg(ap, void *));
         break;
-#if PIC_ENABLE_FLOAT
       case 'f':
         xfprintf(pic, file, "%f", va_arg(ap, double));
         break;
-#endif
       }
       break;
     case '~':
@@ -471,10 +450,18 @@ pic_str_make_string(pic_state *pic)
 {
   size_t len;
   char c = ' ';
+  char *buf;
+  pic_value ret;
 
   pic_get_args(pic, "k|c", &len, &c);
 
-  return pic_obj_value(pic_make_str_fill(pic, len, c));
+  buf = pic_malloc(pic, len);
+  memset(buf, c, len);
+
+  ret = pic_obj_value(pic_make_str(pic, buf, len));
+
+  pic_free(pic, buf);
+  return ret;
 }
 
 static pic_value

extlib/benz/symbol.c

@@ -7,13 +7,13 @@
 KHASH_DEFINE(s, const char *, pic_sym *, kh_str_hash_func, kh_str_hash_equal)
 
 pic_sym *
-pic_intern(pic_state *pic, pic_str *str)
+pic_intern_str(pic_state *pic, pic_str *str)
 {
-  return pic_intern_cstr(pic, pic_str_cstr(pic, str));
+  return pic_intern(pic, pic_str_cstr(pic, str));
 }
 
 pic_sym *
-pic_intern_cstr(pic_state *pic, const char *cstr)
+pic_intern(pic_state *pic, const char *cstr)
 {
   khash_t(s) *h = &pic->syms;
   pic_sym *sym;
@@ -32,6 +32,8 @@ pic_intern_cstr(pic_state *pic, const char *cstr)
   strcpy(copy, cstr);
   kh_key(h, it) = copy;
 
+  kh_val(h, it) = pic->sQUOTE; /* insert dummy */
+
   sym = (pic_sym *)pic_obj_alloc(pic, sizeof(pic_sym), PIC_TT_SYMBOL);
   sym->cstr = copy;
   kh_val(h, it) = sym;
@@ -91,15 +93,13 @@ pic_symbol_string_to_symbol(pic_state *pic)
 
   pic_get_args(pic, "s", &str);
 
-  return pic_obj_value(pic_intern(pic, str));
+  return pic_obj_value(pic_intern_str(pic, str));
 }
 
 void
 pic_init_symbol(pic_state *pic)
 {
-  void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
-
-  pic_defun_vm(pic, "symbol?", pic->uSYMBOLP, pic_symbol_symbol_p);
+  pic_defun(pic, "symbol?", pic_symbol_symbol_p);
 
   pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
   pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);

extlib/benz/undef.c

@@ -1,21 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-
-static pic_value
-pic_undef_undefined_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_undef_p(v) ? pic_true_value() : pic_false_value();
-}
-
-void
-pic_init_undef(pic_state *pic)
-{
-  pic_defun(pic, "undefined?", pic_undef_undefined_p);
-}

extlib/benz/vector.c

@@ -19,22 +19,6 @@ pic_make_vec(pic_state *pic, size_t len)
   return vec;
 }
 
-struct pic_vector *
-pic_make_vec_from_list(pic_state *pic, pic_value data)
-{
-  struct pic_vector *vec;
-  size_t len, i;
-
-  len = pic_length(pic, data);
-
-  vec = pic_make_vec(pic, len);
-  for (i = 0; i < len; ++i) {
-    vec->data[i] = pic_car(pic, data);
-    data = pic_cdr(pic, data);
-  }
-  return vec;
-}
-
 static pic_value
 pic_vec_vector_p(pic_state *pic)
 {

extlib/benz/vm.c

@@ -3,6 +3,7 @@
  */
 
 #include "picrin.h"
+#include "picrin/opcode.h"
 
 #define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)])
 
@@ -102,7 +103,6 @@ pic_get_args(pic_state *pic, const char *format, ...)
       *p = GET_OPERAND(pic,i);
       break;
     }
-#if PIC_ENABLE_FLOAT
     case 'f': {
       double *f;
       pic_value v;
@@ -168,7 +168,6 @@ pic_get_args(pic_state *pic, const char *format, ...)
       }
       break;
     }
-#endif
     case 'i': {
       int *k;
       pic_value v;
@@ -177,11 +176,9 @@ pic_get_args(pic_state *pic, const char *format, ...)
 
       v = GET_OPERAND(pic, i);
       switch (pic_type(v)) {
-#if PIC_ENABLE_FLOAT
       case PIC_TT_FLOAT:
         *k = (int)pic_float(v);
         break;
-#endif
       case PIC_TT_INT:
         *k = pic_int(v);
         break;
@@ -389,6 +386,34 @@ pic_get_args(pic_state *pic, const char *format, ...)
   return argc;
 }
 
+pic_value
+pic_vm_gref_slot(pic_state *pic, pic_sym *uid)
+{
+  pic_value slot;
+
+  if (pic_dict_has(pic, pic->globals, uid)) {
+    return pic_dict_ref(pic, pic->globals, uid);
+  }
+  slot = pic_cons(pic, pic_obj_value(uid), pic_invalid_value());
+  pic_dict_set(pic, pic->globals, uid, slot);
+  return slot;
+}
+
+static pic_value
+vm_gref(pic_state *pic, pic_value slot)
+{
+  if (pic_invalid_p(pic_cdr(pic, slot))) {
+    pic_errorf(pic, "uninitialized global variable: ~a", pic_car(pic, slot));
+  }
+  return pic_cdr(pic, slot);
+}
+
+static void
+vm_gset(pic_state *pic, pic_value slot, pic_value value)
+{
+  pic_set_cdr(pic, slot, value);
+}
+
 static void
 vm_push_cxt(pic_state *pic)
 {
@@ -431,23 +456,6 @@ pic_vm_tear_off(pic_state *pic)
   }
 }
 
-static struct pic_irep *
-vm_get_irep(pic_state *pic)
-{
-  pic_value self;
-  struct pic_irep *irep;
-
-  self = pic->ci->fp[0];
-  if (! pic_proc_p(self)) {
-    pic_errorf(pic, "logic flaw");
-  }
-  irep = pic_proc_ptr(self)->u.i.irep;
-  if (! pic_proc_irep_p(pic_proc_ptr(self))) {
-    pic_errorf(pic, "logic flaw");
-  }
-  return irep;
-}
-
 #if VM_DEBUG
 # define OPCODE_EXEC_HOOK pic_dump_code(c)
 #else
@@ -552,8 +560,8 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
     &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET,
     &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
     &&L_OP_SYMBOLP, &&L_OP_PAIRP,
-    &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_MINUS,
-    &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP
+    &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV,
+    &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_GT, &&L_OP_GE, &&L_OP_STOP
   };
 #endif
 
@@ -618,31 +626,16 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
       NEXT;
     }
     CASE(OP_PUSHCONST) {
-      struct pic_irep *irep = vm_get_irep(pic);
-
-      PUSH(irep->pool[c.u.i]);
+      PUSH(pic->ci->irep->pool[c.u.i]);
       NEXT;
     }
     CASE(OP_GREF) {
-      struct pic_irep *irep = vm_get_irep(pic);
-      pic_sym *sym;
-
-      sym = irep->syms[c.u.i];
-      if (! pic_dict_has(pic, pic->globals, sym)) {
-        pic_errorf(pic, "uninitialized global variable: %s", pic_symbol_name(pic, sym));
-      }
-      PUSH(pic_dict_ref(pic, pic->globals, sym));
+      PUSH(vm_gref(pic, pic->ci->irep->pool[c.u.i]));
       NEXT;
     }
     CASE(OP_GSET) {
-      struct pic_irep *irep = vm_get_irep(pic);
-      pic_sym *sym;
-      pic_value val;
-
-      sym = irep->syms[c.u.i];
-
-      val = POP();
-      pic_dict_set(pic, pic->globals, sym, val);
+      vm_gset(pic, pic->ci->irep->pool[c.u.i], POP());
+      PUSH(pic_undef_value());
       NEXT;
     }
     CASE(OP_LREF) {
@@ -667,10 +660,12 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
         irep = pic_get_proc(pic)->u.i.irep;
         if (c.u.i >= irep->argc + irep->localc) {
           ci->cxt->regs[c.u.i - (ci->regs - ci->fp)] = POP();
+          PUSH(pic_undef_value());
           NEXT;
         }
       }
       pic->ci->fp[c.u.i] = POP();
+      PUSH(pic_undef_value());
       NEXT;
     }
     CASE(OP_CREF) {
@@ -693,6 +688,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
 	cxt = cxt->up;
       }
       cxt->regs[c.u.r.idx] = POP();
+      PUSH(pic_undef_value());
       NEXT;
     }
     CASE(OP_JMP) {
@@ -709,13 +705,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
       }
       NEXT;
     }
-    CASE(OP_NOT) {
-      pic_value v;
-
-      v = pic_false_p(POP()) ? pic_true_value() : pic_false_value();
-      PUSH(v);
-      NEXT;
-    }
     CASE(OP_CALL) {
       pic_value x, v;
       pic_callinfo *ci;
@@ -743,6 +732,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
       ci->retc = 1;
       ci->ip = pic->ip;
       ci->fp = pic->sp - c.u.i;
+      ci->irep = NULL;
       ci->cxt = NULL;
       if (pic_proc_func_p(pic_proc_ptr(x))) {
 
@@ -759,6 +749,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
 	int i;
 	pic_value rest;
 
+        ci->irep = irep;
 	if (ci->argc != irep->argc) {
 	  if (! (irep->varg && ci->argc >= irep->argc)) {
             pic_errorf(pic, "wrong number of arguments (%d for %s%d)", ci->argc - 1, (irep->varg ? "at least " : ""), irep->argc - 1);
@@ -833,7 +824,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
         vm_tear_off(pic->ci);
       }
 
-      pic->ci->retc = c.u.i;
+      assert(pic->ci->retc == 1);
 
     L_RET:
       retc = pic->ci->retc;
@@ -851,186 +842,163 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
       NEXT;
     }
     CASE(OP_LAMBDA) {
-      pic_value self;
-      struct pic_irep *irep;
-
-      self = pic->ci->fp[0];
-      if (! pic_proc_p(self)) {
-        pic_errorf(pic, "logic flaw");
-      }
-      irep = pic_proc_ptr(self)->u.i.irep;
-      if (! pic_proc_irep_p(pic_proc_ptr(self))) {
-        pic_errorf(pic, "logic flaw");
-      }
-
       if (pic->ci->cxt == NULL) {
         vm_push_cxt(pic);
       }
 
-      proc = pic_make_proc_irep(pic, irep->irep[c.u.i], pic->ci->cxt);
+      proc = pic_make_proc_irep(pic, pic->ci->irep->irep[c.u.i], pic->ci->cxt);
       PUSH(pic_obj_value(proc));
       pic_gc_arena_restore(pic, ai);
       NEXT;
     }
+
+#define check_condition(name, n) do {                                   \
+      if (! pic_eq_p(pic->p##name, pic_cdr(pic, pic->c##name)))         \
+        goto L_CALL;                                                    \
+      if (c.u.i != n + 1)                                               \
+        goto L_CALL;                                                    \
+    } while (0)
+
     CASE(OP_CONS) {
       pic_value a, b;
+      check_condition(CONS, 2);
       pic_gc_protect(pic, b = POP());
       pic_gc_protect(pic, a = POP());
+      (void)POP();
       PUSH(pic_cons(pic, a, b));
       pic_gc_arena_restore(pic, ai);
       NEXT;
     }
     CASE(OP_CAR) {
       pic_value p;
+      check_condition(CAR, 1);
       p = POP();
+      (void)POP();
       PUSH(pic_car(pic, p));
       NEXT;
     }
     CASE(OP_CDR) {
       pic_value p;
+      check_condition(CDR, 1);
       p = POP();
+      (void)POP();
       PUSH(pic_cdr(pic, p));
       NEXT;
     }
     CASE(OP_NILP) {
       pic_value p;
+      check_condition(NILP, 1);
       p = POP();
+      (void)POP();
       PUSH(pic_bool_value(pic_nil_p(p)));
       NEXT;
     }
-
     CASE(OP_SYMBOLP) {
       pic_value p;
+      check_condition(SYMBOLP, 1);
       p = POP();
+      (void)POP();
       PUSH(pic_bool_value(pic_sym_p(p)));
       NEXT;
     }
-
     CASE(OP_PAIRP) {
       pic_value p;
+      check_condition(PAIRP, 1);
       p = POP();
+      (void)POP();
       PUSH(pic_bool_value(pic_pair_p(p)));
       NEXT;
     }
-
-#define DEFINE_ARITH_OP(opcode, op, guard)			\
-    CASE(opcode) {						\
-      pic_value a, b;						\
-      b = POP();						\
-      a = POP();						\
-      if (pic_int_p(a) && pic_int_p(b)) {			\
-	double f = (double)pic_int(a) op (double)pic_int(b);	\
-	if (INT_MIN <= f && f <= INT_MAX && (guard)) {		\
-	  PUSH(pic_int_value((int)f));				\
-	}							\
-	else {							\
-	  PUSH(pic_float_value(f));				\
-	}							\
-      }								\
-      else if (pic_float_p(a) && pic_float_p(b)) {		\
-	PUSH(pic_float_value(pic_float(a) op pic_float(b)));	\
-      }								\
-      else if (pic_int_p(a) && pic_float_p(b)) {		\
-	PUSH(pic_float_value(pic_int(a) op pic_float(b)));	\
-      }								\
-      else if (pic_float_p(a) && pic_int_p(b)) {		\
-	PUSH(pic_float_value(pic_float(a) op pic_int(b)));	\
-      }								\
-      else {							\
-	pic_errorf(pic, #op " got non-number operands");        \
-      }								\
-      NEXT;							\
-    }
-
-#define DEFINE_ARITH_OP2(opcode, op)                            \
-    CASE(opcode) {						\
-      pic_value a, b;						\
-      b = POP();						\
-      a = POP();						\
-      if (pic_int_p(a) && pic_int_p(b)) {			\
-        PUSH(pic_int_value(pic_int(a) op pic_int(b)));          \
-      }								\
-      else {							\
-	pic_errorf(pic, #op " got non-number operands");        \
-      }								\
-      NEXT;							\
-    }
-
-#if PIC_ENABLE_FLOAT
-    DEFINE_ARITH_OP(OP_ADD, +, true);
-    DEFINE_ARITH_OP(OP_SUB, -, true);
-    DEFINE_ARITH_OP(OP_MUL, *, true);
-    DEFINE_ARITH_OP(OP_DIV, /, f == round(f));
-#else
-    DEFINE_ARITH_OP2(OP_ADD, +);
-    DEFINE_ARITH_OP2(OP_SUB, -);
-    DEFINE_ARITH_OP2(OP_MUL, *);
-    DEFINE_ARITH_OP2(OP_DIV, /);
-#endif
-
-    CASE(OP_MINUS) {
-      pic_value n;
-      n = POP();
-      if (pic_int_p(n)) {
-	PUSH(pic_int_value(-pic_int(n)));
-      }
-#if PIC_ENABLE_FLOAT
-      else if (pic_float_p(n)) {
-	PUSH(pic_float_value(-pic_float(n)));
-      }
-#endif
-      else {
-	pic_errorf(pic, "unary - got a non-number operand");
-      }
+    CASE(OP_NOT) {
+      pic_value v;
+      check_condition(NOT, 1);
+      v = pic_false_p(POP()) ? pic_true_value() : pic_false_value();
+      (void)POP();
+      PUSH(v);
       NEXT;
     }
 
-#define DEFINE_COMP_OP(opcode, op)				\
-    CASE(opcode) {						\
-      pic_value a, b;						\
-      b = POP();						\
-      a = POP();						\
-      if (pic_int_p(a) && pic_int_p(b)) {			\
-	PUSH(pic_bool_value(pic_int(a) op pic_int(b)));		\
-      }								\
-      else if (pic_float_p(a) && pic_float_p(b)) {		\
-	PUSH(pic_bool_value(pic_float(a) op pic_float(b)));	\
-      }								\
-      else if (pic_int_p(a) && pic_float_p(b)) {		\
-	PUSH(pic_bool_value(pic_int(a) op pic_float(b)));	\
-      }								\
-      else if (pic_float_p(a) && pic_int_p(b)) {		\
-	PUSH(pic_bool_value(pic_float(a) op pic_int(b)));	\
-      }								\
-      else {							\
-	pic_errorf(pic, #op " got non-number operands");        \
-      }								\
-      NEXT;							\
+    CASE(OP_ADD) {
+      pic_value a, b;
+      check_condition(ADD, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_add(pic, a, b));
+      NEXT;
     }
-
-#define DEFINE_COMP_OP2(opcode, op)				\
-    CASE(opcode) {						\
-      pic_value a, b;						\
-      b = POP();						\
-      a = POP();						\
-      if (pic_int_p(a) && pic_int_p(b)) {			\
-	PUSH(pic_bool_value(pic_int(a) op pic_int(b)));		\
-      }								\
-      else {							\
-	pic_errorf(pic, #op " got non-number operands");        \
-      }								\
-      NEXT;							\
+    CASE(OP_SUB) {
+      pic_value a, b;
+      check_condition(SUB, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_sub(pic, a, b));
+      NEXT;
+    }
+    CASE(OP_MUL) {
+      pic_value a, b;
+      check_condition(MUL, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_mul(pic, a, b));
+      NEXT;
+    }
+    CASE(OP_DIV) {
+      pic_value a, b;
+      check_condition(DIV, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_div(pic, a, b));
+      NEXT;
+    }
+    CASE(OP_EQ) {
+      pic_value a, b;
+      check_condition(EQ, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_bool_value(pic_eq(pic, a, b)));
+      NEXT;
+    }
+    CASE(OP_LE) {
+      pic_value a, b;
+      check_condition(LT, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_bool_value(pic_le(pic, a, b)));
+      NEXT;
+    }
+    CASE(OP_LT) {
+      pic_value a, b;
+      check_condition(LE, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_bool_value(pic_lt(pic, a, b)));
+      NEXT;
+    }
+    CASE(OP_GE) {
+      pic_value a, b;
+      check_condition(LT, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_bool_value(pic_ge(pic, a, b)));
+      NEXT;
+    }
+    CASE(OP_GT) {
+      pic_value a, b;
+      check_condition(LE, 2);
+      b = POP();
+      a = POP();
+      (void)POP();
+      PUSH(pic_bool_value(pic_gt(pic, a, b)));
+      NEXT;
     }
-
-#if PIC_ENABLE_FLOAT
-    DEFINE_COMP_OP(OP_EQ, ==);
-    DEFINE_COMP_OP(OP_LT, <);
-    DEFINE_COMP_OP(OP_LE, <=);
-#else
-    DEFINE_COMP_OP2(OP_EQ, ==);
-    DEFINE_COMP_OP2(OP_LT, <);
-    DEFINE_COMP_OP2(OP_LE, <=);
-#endif
 
     CASE(OP_STOP) {
 
@@ -1042,10 +1010,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
 }
 
 pic_value
-pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args)
+pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, size_t argc, pic_value *args)
 {
-  pic_value v, it, *sp;
+  pic_value *sp;
   pic_callinfo *ci;
+  size_t i;
 
   PIC_INIT_CODE_I(pic->iseq[0], OP_NOP, 0);
   PIC_INIT_CODE_I(pic->iseq[1], OP_TAILCALL, -1);
@@ -1053,22 +1022,37 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args)
   *pic->sp++ = pic_obj_value(proc);
 
   sp = pic->sp;
-  pic_for_each (v, args, it) {
-    *sp++ = v;
+  for (i = 0; i < argc; ++i) {
+    *sp++ = args[i];
   }
 
   ci = PUSHCI();
   ci->ip = pic->iseq;
   ci->fp = pic->sp;
-  ci->retc = (int)pic_length(pic, args);
+  ci->retc = (int)argc;
 
   if (ci->retc == 0) {
     return pic_undef_value();
   } else {
-    return pic_car(pic, args);
+    return args[0];
   }
 }
 
+pic_value
+pic_apply_trampoline_list(pic_state *pic, struct pic_proc *proc, pic_value args)
+{
+  size_t i, argc = pic_length(pic, args);
+  pic_value val, it;
+  pic_vec *argv = pic_make_vec(pic, argc);
+
+  i = 0;
+  pic_for_each (val, args, it) {
+    argv->data[i++] = val;
+  }
+
+  return pic_apply_trampoline(pic, proc, argc, argv->data);
+}
+
 pic_value
 pic_apply0(pic_state *pic, struct pic_proc *proc)
 {
@@ -1121,44 +1105,29 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym,
   }
 }
 
-void
-pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func)
-{
-  struct pic_proc *proc;
-  pic_sym *sym;
-
-  proc = pic_make_proc(pic, func);
-
-  sym = pic_intern_cstr(pic, name);
-
-  pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), uid);
-
-  pic_dict_set(pic, pic->globals, uid, pic_obj_value(proc));
-
-  pic_export(pic, sym);
-}
-
 void
 pic_define_(pic_state *pic, const char *name, pic_value val)
 {
   pic_sym *sym, *uid;
 
-  sym = pic_intern_cstr(pic, name);
+  sym = pic_intern(pic, name);
 
   if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) {
     uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym));
   } else {
-    pic_warnf(pic, "redefining global");
+    if (pic_dict_has(pic, pic->globals, uid)) {
+      pic_warnf(pic, "redefining variable: ~s", pic_obj_value(uid));
+    }
   }
 
-  pic_dict_set(pic, pic->globals, uid, val);
+  pic_set(pic, pic->lib, name, val);
 }
 
 void
 pic_define(pic_state *pic, const char *name, pic_value val)
 {
   pic_define_(pic, name, val);
-  pic_export(pic, pic_intern_cstr(pic, name));
+  pic_export(pic, pic_intern(pic, name));
 }
 
 void
@@ -1171,7 +1140,7 @@ void
 pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
 {
   pic_defun_(pic, name, cfunc);
-  pic_export(pic, pic_intern_cstr(pic, name));
+  pic_export(pic, pic_intern(pic, name));
 }
 
 void
@@ -1184,7 +1153,7 @@ void
 pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv)
 {
   pic_defvar_(pic, name, init, conv);
-  pic_export(pic, pic_intern_cstr(pic, name));
+  pic_export(pic, pic_intern(pic, name));
 }
 
 pic_value
@@ -1192,13 +1161,13 @@ pic_ref(pic_state *pic, struct pic_lib *lib, const char *name)
 {
   pic_sym *sym, *uid;
 
-  sym = pic_intern_cstr(pic, name);
+  sym = pic_intern(pic, name);
 
   if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) {
     pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
   }
 
-  return pic_dict_ref(pic, pic->globals, uid);
+  return vm_gref(pic, pic_vm_gref_slot(pic, uid));
 }
 
 void
@@ -1206,13 +1175,13 @@ pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
 {
   pic_sym *sym, *uid;
 
-  sym = pic_intern_cstr(pic, name);
+  sym = pic_intern(pic, name);
 
   if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) {
     pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
   }
 
-  pic_dict_set(pic, pic->globals, uid, val);
+  vm_gset(pic, pic_vm_gref_slot(pic, uid), val);
 }
 
 pic_value

extlib/benz/write.c

@@ -101,19 +101,19 @@ write_str(pic_state *pic, pic_str *str, xFILE *file, int mode)
   xfprintf(pic, file, "\"");
 }
 
-#if PIC_ENABLE_FLOAT
 static void
 write_float(pic_state *pic, double f, xFILE *file)
 {
-  if (isnan(f)) {
-    xfprintf(pic, file, signbit(f) ? "-nan.0" : "+nan.0");
-  } else if (isinf(f)) {
-    xfprintf(pic, file, signbit(f) ? "-inf.0" : "+inf.0");
+  if (f != f) {
+    xfprintf(pic, file, "+nan.0");
+  } else if (f == 1.0 / 0.0) {
+    xfprintf(pic, file, "+inf.0");
+  } else if (f == -1.0 / 0.0) {
+    xfprintf(pic, file, "-inf.0");
   } else {
     xfprintf(pic, file, "%f", f);
   }
 }
-#endif
 
 static void write_core(struct writer_control *p, pic_value);
 
@@ -291,11 +291,9 @@ write_core(struct writer_control *p, pic_value obj)
   case PIC_TT_INT:
     xfprintf(pic, file, "%d", pic_int(obj));
     break;
-#if PIC_ENABLE_FLOAT
   case PIC_TT_FLOAT:
     write_float(pic, pic_float(obj), file);
     break;
-#endif
   case PIC_TT_SYMBOL:
     xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj)));
     break;

piclib/picrin/base.scm

@@ -1,290 +0,0 @@
-(define-library (picrin base)
-
-  (export define
-          lambda
-          if
-          quote
-          set!
-          begin
-          define-macro)
-
-  (export syntax-error
-          define-syntax
-          let-syntax
-          letrec-syntax
-          syntax-quote
-          syntax-quasiquote
-          syntax-unquote
-          syntax-unquote-splicing)
-
-  (export let
-          let*
-          letrec
-          letrec*
-          quasiquote
-          unquote
-          unquote-splicing
-          and
-          or
-          cond
-          case
-          =>
-          else
-          do
-          when
-          unless)
-
-  (export let-values
-          let*-values
-          define-values)
-
-  (export eq?
-          eqv?
-          equal?)
-
-  (export undefined?)
-
-  (export boolean?
-          boolean=?
-          not)
-
-  (export symbol?
-          symbol->string
-          string->symbol
-          symbol=?)
-
-  (export char?
-          char->integer
-          integer->char
-          char=?
-          char<?
-          char>?
-          char<=?
-          char>=?)
-
-  (export number?
-          complex?
-          real?
-          rational?
-          integer?
-          exact?
-          inexact?
-          =
-          <
-          >
-          <=
-          >=
-          +
-          -
-          *
-          /
-          abs
-          floor/
-          truncate/
-          floor
-          ceiling
-          truncate
-          round
-          expt
-          number->string
-          string->number
-          finite?
-          infinite?
-          nan?
-          exp
-          log
-          sin
-          cos
-          tan
-          acos
-          asin
-          atan
-          sqrt)
-
-  (export pair?
-          cons
-          car
-          cdr
-          set-car!
-          set-cdr!
-          null?
-          caar
-          cadr
-          cdar
-          cddr)
-
-  (export list?
-          make-list
-          list
-          length
-          append
-          reverse
-          list-tail
-          list-ref
-          list-set!
-          list-copy
-          map
-          for-each
-          memq
-          memv
-          member
-          assq
-          assv
-          assoc)
-
-  (export bytevector?
-          bytevector
-          make-bytevector
-          bytevector-length
-          bytevector-u8-ref
-          bytevector-u8-set!
-          bytevector-copy
-          bytevector-copy!
-          bytevector-append
-          bytevector->list
-          list->bytevector)
-
-  (export 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)
-
-  (export string?
-          string
-          make-string
-          string-length
-          string-ref
-          string-copy
-          string-append
-          string-map
-          string-for-each
-          string->list
-          list->string
-          string=?
-          string<?
-          string>?
-          string<=?
-          string>=?)
-
-  (export make-dictionary
-          dictionary?
-          dictionary
-          dictionary-ref
-          dictionary-set!
-          dictionary-size
-          dictionary-map
-          dictionary-for-each
-          dictionary->plist
-          plist->dictionary
-          dictionary->alist
-          alist->dictionary)
-
-  (export make-record
-          record?
-          record-type
-          record-ref
-          record-set!)
-
-  (export current-input-port
-          current-output-port
-          current-error-port
-
-          call-with-port
-
-          port?
-          input-port?
-          output-port?
-          textual-port?
-          binary-port?
-
-          port-open?
-          close-port
-
-          open-input-string
-          open-output-string
-          get-output-string
-          open-input-bytevector
-          open-output-bytevector
-          get-output-bytevector
-
-          eof-object?
-          eof-object
-
-          read-char
-          peek-char
-          char-ready?
-          read-line
-          read-string
-
-          read-u8
-          peek-u8
-          u8-ready?
-          read-bytevector
-          read-bytevector!
-
-          newline
-          write-char
-          write-string
-          write-u8
-          write-bytevector
-          flush-output-port)
-
-  (export make-parameter
-          parameterize)
-
-  (export make-identifier
-          identifier?
-          identifier-variable
-          identifier-environment
-
-          variable?
-          variable=?)
-
-  (export make-library
-          find-library
-          current-library
-          library-exports
-          library-environment)
-
-  (export call-with-current-continuation
-          call/cc
-          dynamic-wind
-          values
-          call-with-values)
-
-  (export with-exception-handler
-          raise
-          raise-continuable
-          error
-          make-error-object
-          error-object?
-          error-object-message
-          error-object-irritants
-          error-object-type)
-
-  (export procedure?
-          apply
-          attribute)
-
-  (export read)
-
-  (export write
-          write-simple
-          write-shared
-          display)
-
-  (export eval)
-
-  (export features))

piclib/picrin/control.scm

@@ -1,6 +0,0 @@
-(define-library (picrin control)
-  (import (picrin base))
-
-  (define escape call/cc)               ; create a new global variable slot
-
-  (export escape))

piclib/picrin/experimental/lambda.scm

@@ -1,37 +0,0 @@
-(define-library (picrin experimental lambda)
-  (import (picrin base)
-          (picrin macro))
-
-  (define-syntax (destructuring-let formal value . body)
-    (cond
-     ((variable? formal)
-      #`(let ((#,formal #,value))
-          #,@body))
-     ((pair? formal)
-      #`(let ((value #,value))
-          (destructuring-let #,(car formal) (car value)
-            (destructuring-let #,(cdr formal) (cdr value)
-              #,@body))))
-     ((vector? formal)
-      ;; TODO
-      (error "fixme"))
-     (else
-      #`(if (equal? #,value '#,formal)
-            (begin
-              #,@body)
-            (error "match failure" #,value '#,formal)))))
-
-  (define-syntax (destructuring-lambda formal . body)
-    #`(lambda args
-        (destructuring-let #,formal args #,@body)))
-
-  (define-syntax (destructuring-define formal . body)
-    (if (variable? formal)
-        #`(define #,formal #,@body)
-        #`(destructuring-define #,(car formal)
-            (destructuring-lambda #,(cdr formal)
-              #,@body))))
-
-  (export (rename destructuring-let let)
-          (rename destructuring-lambda lambda)
-          (rename destructuring-define define)))

piclib/picrin/record.scm

@@ -1,59 +0,0 @@
-(define-library (picrin record)
-  (import (picrin base)
-          (picrin macro))
-
-  ;; record meta type
-
-  (define ((boot-make-record-type <meta-type>) name)
-    (let ((rectype (make-record <meta-type>)))
-      (record-set! rectype 'name name)
-      rectype))
-
-  (define <record-type>
-    (let ((<record-type> ((boot-make-record-type #t) 'record-type)))
-      (record-set! <record-type> '@@type <record-type>)
-      <record-type>))
-
-  (define make-record-type (boot-make-record-type <record-type>))
-
-  ;; define-record-type
-
-  (define-syntax (define-record-constructor type name . fields)
-    (let ((record #'record))
-      #`(define (#,name . #,fields)
-          (let ((#,record (make-record #,type)))
-            #,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
-            #,record))))
-
-  (define-syntax (define-record-predicate type name)
-    #`(define (#,name obj)
-        (and (record? obj)
-             (eq? (record-type obj) #,type))))
-
-  (define-syntax (define-record-accessor pred field accessor)
-    #`(define (#,accessor record)
-        (if (#,pred record)
-            (record-ref record '#,field)
-            (error (string-append (symbol->string  '#,accessor) ": wrong record type") record))))
-
-  (define-syntax (define-record-modifier pred field modifier)
-    #`(define (#,modifier record val)
-        (if (#,pred record)
-            (record-set! record '#,field val)
-            (error (string-append (symbol->string '#,modifier) ": wrong record type")  record))))
-
-  (define-syntax (define-record-field pred field accessor . modifier-opt)
-    (if (null? modifier-opt)
-        #`(define-record-accessor #,pred #,field #,accessor)
-        #`(begin
-            (define-record-accessor #,pred #,field #,accessor)
-            (define-record-modifier #,pred #,field #,(car modifier-opt)))))
-
-  (define-syntax (define-record-type name ctor pred . fields)
-    #`(begin
-        (define #,name (make-record-type '#,name))
-        (define-record-constructor #,name #,@ctor)
-        (define-record-predicate #,name #,pred)
-        #,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
-
-  (export define-record-type))

piclib/picrin/syntax-rules.scm

@@ -1,244 +0,0 @@
-(define-library (picrin syntax-rules)
-  (import (picrin base)
-          (picrin macro))
-
-  (define-syntax (define-auxiliary-syntax var)
-    #`(define-macro #,var
-        (lambda _
-          (error "invalid use of auxiliary syntax" '#,var))))
-
-  (define-auxiliary-syntax _)
-  (define-auxiliary-syntax ...)
-
-  (define (succ n)
-    (+ n 1))
-
-  (define (pred n)
-    (if (= n 0)
-        0
-        (- n 1)))
-
-  (define (every? args)
-    (if (null? args)
-        #t
-        (if (car args)
-            (every? (cdr args))
-            #f)))
-
-  (define (filter f list)
-    (if (null? list)
-        '()
-        (if (f (car list))
-            (cons (car list)
-                  (filter f (cdr list)))
-            (filter f (cdr list)))))
-
-  (define (take-tail n list)
-    (let drop ((n (- (length list) n)) (list list))
-      (if (= n 0)
-          list
-          (drop (- n 1) (cdr list)))))
-
-  (define (drop-tail n list)
-    (let take ((n (- (length list) n)) (list list))
-      (if (= n 0)
-          '()
-          (cons (car list) (take (- n 1) (cdr list))))))
-
-  (define (map-keys f assoc)
-    (map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
-
-  (define (map-values f assoc)
-    (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
-
-  ;; TODO
-  ;; - placeholder
-  ;; - vector
-  ;; - (... template) pattern
-
-  ;; p ::= constant
-  ;;     | var
-  ;;     | (p ... . p)      (in input pattern, tail p should be a proper list)
-  ;;     | (p . p)
-
-  (define (compile ellipsis literals rules)
-
-    (define (constant? obj)
-      (and (not (pair? obj))
-           (not (variable? obj))))
-
-    (define (literal? obj)
-      (and (variable? obj)
-           (memq obj literals)))
-
-    (define (many? pat)
-      (and (pair? pat)
-           (pair? (cdr pat))
-           (variable? (cadr pat))
-           (variable=? (cadr pat) ellipsis)))
-
-    (define (pattern-validator pat)      ; pattern -> validator
-      (letrec
-          ((pattern-validator
-            (lambda (pat form)
-              (cond
-               ((constant? pat)
-                #`(equal? '#,pat #,form))
-               ((literal? pat)
-                #`(and (variable? #,form) (variable=? #'#,pat #,form)))
-               ((variable? pat)
-                #t)
-               ((many? pat)
-                (let ((head #`(drop-tail #,(length (cddr pat)) #,form))
-                      (tail #`(take-tail #,(length (cddr pat)) #,form)))
-                  #`(and (list? #,form)
-                         (>= (length #,form) #,(length (cddr pat)))
-                         (every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head))
-                         #,(pattern-validator (cddr pat) tail))))
-               ((pair? pat)
-                #`(and (pair? #,form)
-                       #,(pattern-validator (car pat) #`(car #,form))
-                       #,(pattern-validator (cdr pat) #`(cdr #,form))))
-               (else
-                #f)))))
-        (pattern-validator pat 'it)))
-
-    (define (pattern-variables pat)       ; pattern -> (freevar)
-      (cond
-       ((constant? pat)
-        '())
-       ((literal? pat)
-        '())
-       ((variable? pat)
-        `(,pat))
-       ((many? pat)
-        (append (pattern-variables (car pat))
-                (pattern-variables (cddr pat))))
-       ((pair? pat)
-        (append (pattern-variables (car pat))
-                (pattern-variables (cdr pat))))))
-
-    (define (pattern-levels pat)          ; pattern -> ((var * int))
-      (cond
-       ((constant? pat)
-        '())
-       ((literal? pat)
-        '())
-       ((variable? pat)
-        `((,pat . 0)))
-       ((many? pat)
-        (append (map-values succ (pattern-levels (car pat)))
-                (pattern-levels (cddr pat))))
-       ((pair? pat)
-        (append (pattern-levels (car pat))
-                (pattern-levels (cdr pat))))))
-
-    (define (pattern-selectors pat)       ; pattern -> ((var * selector))
-      (letrec
-          ((pattern-selectors
-            (lambda (pat form)
-              (cond
-               ((constant? pat)
-                '())
-               ((literal? pat)
-                '())
-               ((variable? pat)
-                `((,pat . ,form)))
-               ((many? pat)
-                (let ((head #`(drop-tail #,(length (cddr pat)) #,form))
-                      (tail #`(take-tail #,(length (cddr pat)) #,form)))
-                  (let ((envs (pattern-selectors (car pat) 'it)))
-                    (append
-                     (map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs)
-                     (pattern-selectors (cddr pat) tail)))))
-               ((pair? pat)
-                (append (pattern-selectors (car pat) #`(car #,form))
-                        (pattern-selectors (cdr pat) #`(cdr #,form))))))))
-        (pattern-selectors pat 'it)))
-
-    (define (template-representation pat levels selectors)
-      (cond
-       ((constant? pat)
-        pat)
-       ((variable? pat)
-        (let ((it (assq pat levels)))
-          (if it
-              (if (= 0 (cdr it))
-                  (cdr (assq pat selectors))
-                  (error "unmatched pattern variable level" pat))
-              #`(#,'rename '#,pat))))
-       ((many? pat)
-        (letrec*
-            ((inner-pat
-              (car pat))
-             (inner-levels
-              (map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels))
-             (inner-freevars
-              (filter (lambda (v) (assq v levels)) (pattern-variables inner-pat)))
-             (inner-vars
-              ;; select only vars declared with ellipsis
-              (filter (lambda (v) (> (cdr (assq v levels)) 0)) inner-freevars))
-             (inner-tmps
-              (map (lambda (v) #'it) inner-vars))
-             (inner-selectors
-              ;; first env '(map cons ...)' shadows second env 'selectors'
-              (append (map cons inner-vars inner-tmps) selectors))
-             (inner-rep
-              (template-representation inner-pat inner-levels inner-selectors))
-             (sorted-selectors
-              (map (lambda (v) (assq v selectors)) inner-vars))
-             (list-of-selectors
-              ;; ((a . xs) (b . ys) (c . zs)) -> (xs ys zs)
-              (map cdr sorted-selectors)))
-          (let ((rep1 #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors))
-                (rep2 (template-representation (cddr pat) levels selectors)))
-            #`(append #,rep1 #,rep2))))
-       ((pair? pat)
-        #`(cons #,(template-representation (car pat) levels selectors)
-                #,(template-representation (cdr pat) levels selectors)))))
-
-    (define (compile-rule pattern template)
-      (let ((levels
-             (pattern-levels pattern))
-            (selectors
-             (pattern-selectors pattern)))
-        (template-representation template levels selectors)))
-
-    (define (compile-rules rules)
-      (if (null? rules)
-          #`(error "unmatch")
-          (let ((pattern (car (car rules)))
-                (template (cadr (car rules))))
-            #`(if #,(pattern-validator pattern)
-                  #,(compile-rule pattern template)
-                  #,(compile-rules (cdr rules))))))
-
-    (define (compile rules)
-      #`(call-with-current-environment
-         (lambda (env)
-           (letrec
-               ((#,'rename (let ((reg (make-register)))
-                             (lambda (x)
-                               (if (undefined? (reg x))
-                                   (let ((id (make-identifier x env)))
-                                     (reg x id)
-                                     id)
-                                   (reg x))))))
-             (lambda #,'it
-               #,(compile-rules rules))))))
-
-    (let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable
-      (compile rules)))
-
-  (define-syntax (syntax-rules . args)
-    (if (list? (car args))
-        #`(syntax-rules ... #,@args)
-        (let ((ellipsis (car args))
-              (literals (car (cdr args)))
-              (rules    (cdr (cdr args))))
-          (compile ellipsis literals rules))))
-
-
-  (export syntax-rules
-          _
-          ...))

t/array.scm

@@ -1,42 +0,0 @@
-(import (scheme base)
-        (scheme write)
-        (picrin array))
-
-(define ary (make-array))
-
-(write ary)
-(newline)
-(array-push! ary 1)
-(write ary)
-(newline)
-(array-push! ary 2)
-(write ary)
-(newline)
-(array-push! ary 3)
-(write ary)
-(newline)
-(write (array-pop! ary))
-(newline)
-(write (array-pop! ary))
-(newline)
-(write (array-pop! ary))
-(newline)
-
-(write ary)
-(newline)
-(array-unshift! ary 1)
-(write ary)
-(newline)
-(array-unshift! ary 2)
-(write ary)
-(newline)
-(array-unshift! ary 3)
-(write ary)
-(newline)
-(write (array-shift! ary))
-(newline)
-(write (array-shift! ary))
-(newline)
-(write (array-shift! ary))
-(newline)
-