From a9ef840df948688ab1f217dcfd80f4e69436b4b0 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Tue, 27 May 2014 21:35:19 +0900
Subject: [PATCH 001/216] vectors, blobs, strings with equal contets are equal

---
 src/bool.c | 24 ++++++++++++++++++++++++
 1 file changed, 24 insertions(+)

diff --git a/src/bool.c b/src/bool.c
index fa56fa31..ef497362 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -6,6 +6,9 @@
 
 #include "picrin.h"
 #include "picrin/pair.h"
+#include "picrin/vector.h"
+#include "picrin/blob.h"
+#include "picrin/string.h"
 
 bool
 pic_equal_p(pic_state *pic, pic_value x, pic_value y)
@@ -22,6 +25,27 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
   case PIC_TT_PAIR:
     return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y))
       && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y));
+  case PIC_TT_BLOB: {
+    int i;
+    struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y);
+    for(i = 0; i < v1->len; ++i){
+      if(v1->data[i] != v2->data[i])
+        return false;
+    }
+    return true;
+  }
+  case PIC_TT_VECTOR:{
+    size_t i;
+    struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y);
+    
+    for(i = 0; i < v1->len; ++i){
+      if(! pic_equal_p(pic, v1->data[i], v2->data[i]))
+        return false;
+    }
+    return true;
+  }
+  case PIC_TT_STRING:
+    return pic_strcmp(pic_str_ptr(x), pic_str_ptr(y)) == 0;
   default:
     return false;
   }

From dcef9579f59a89f7182c12389b3605de9bcf1860 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Wed, 28 May 2014 02:55:19 +0900
Subject: [PATCH 002/216] check length before compare contents

---
 src/bool.c | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/src/bool.c b/src/bool.c
index ef497362..904a21d6 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -28,6 +28,9 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
   case PIC_TT_BLOB: {
     int i;
     struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y);
+    if(v1->len != v2->len){
+      return false;
+    }
     for(i = 0; i < v1->len; ++i){
       if(v1->data[i] != v2->data[i])
         return false;
@@ -38,6 +41,9 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
     size_t i;
     struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y);
     
+    if(v1->len != v2->len){
+      return false;
+    }
     for(i = 0; i < v1->len; ++i){
       if(! pic_equal_p(pic, v1->data[i], v2->data[i]))
         return false;

From 86a27e95b7de358b8b9f43c707f191b9ca159457 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Wed, 28 May 2014 22:49:53 +0900
Subject: [PATCH 003/216] add alias of `modulo`, `remainder`, `quotient`

---
 src/number.c | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/src/number.c b/src/number.c
index fb9a4c1f..45fd54f1 100644
--- a/src/number.c
+++ b/src/number.c
@@ -777,6 +777,9 @@ pic_init_number(pic_state *pic)
   pic_defun(pic, "floor-remainder", pic_number_floor_remainder);
   pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient);
   pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder);
+  pic_defun(pic, "modulo", pic_number_floor_remainder);
+  pic_defun(pic, "quotient", pic_number_trunc_quotient);
+  pic_defun(pic, "remainder", pic_number_trunc_remainder);
   pic_gc_arena_restore(pic, ai);
 
   pic_defun(pic, "gcd", pic_number_gcd);

From a9c4cefe882968e61f663a81c8ce5e1946ec51e4 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Thu, 29 May 2014 01:22:19 +0900
Subject: [PATCH 004/216] `quotient` is defined in base

---
 piclib/srfi/95.scm | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/piclib/srfi/95.scm b/piclib/srfi/95.scm
index 9effaece..0036da62 100644
--- a/piclib/srfi/95.scm
+++ b/piclib/srfi/95.scm
@@ -14,9 +14,6 @@
   (define (identity x)
     x)
 
-  (define (quotient a b)
-    (exact (floor (/ a b))))
-
   (define (merge ls1 ls2 less? . opt-key)
     (let ((key (if (null? opt-key) identity (car opt-key))))
       (let rec ((arg1 ls1) (arg2 ls2))

From d706240adabde951fd95dec9173805b9f11b0c37 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Wed, 18 Jun 2014 00:47:50 +0900
Subject: [PATCH 005/216] implement circular refarence checking

---
 src/bool.c | 104 ++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 84 insertions(+), 20 deletions(-)

diff --git a/src/bool.c b/src/bool.c
index 904a21d6..8ed9cc02 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -10,33 +10,87 @@
 #include "picrin/blob.h"
 #include "picrin/string.h"
 
-bool
-pic_equal_p(pic_state *pic, pic_value x, pic_value y)
+bool pic_string_equal_p(struct pic_string *str1, struct pic_string *str2)
 {
+  return pic_strcmp(str1, str2) == 0;
+}
+
+bool pic_blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
+{
+  if(blob1->len != blob2->len){
+    return false;
+  }
+  size_t i;
+  for(i = 0; i < blob1->len; ++i){
+    if(blob1->data[i] != blob2->data[i])
+      return false;
+  }
+  return true;  
+}
+
+bool
+pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
+{
+
+  if (depth > 10){
+    if(depth > 200){
+      pic_errorf(pic, "Stack overflow in equal\n");
+    }
+    if (NULL == ht){
+      xh_init_ptr(ht, sizeof(void *));
+    }
+    switch(pic_type(x)){
+    case PIC_TT_PAIR:
+    case PIC_TT_VECTOR:{
+      xh_entry *e = xh_get(ht, pic_obj_ptr(x));
+      if(e){
+        /* `x' was seen already.  */
+        return true;
+      }else{
+        xh_put(ht, pic_obj_ptr(x), NULL);
+      }
+    }
+    default:;
+    }
+  }
+
   enum pic_tt type;
+  pic_value local = pic_nil_value();
+  size_t rapid_count = 0;
+
+ LOOP:
 
   if (pic_eqv_p(x, y))
     return true;
-
+  
   type = pic_type(x);
-  if (type != pic_type(y))
-    return false;
+  
+  if (type != pic_type(y)){
+    return false;    
+  }
+  
   switch (type) {
   case PIC_TT_PAIR:
-    return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y))
-      && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y));
-  case PIC_TT_BLOB: {
-    int i;
-    struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y);
-    if(v1->len != v2->len){
+    if(pic_nil_p(local)){
+      local = x;
+    }
+    if(pic_internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)){
+      x = pic_cdr(pic, x);
+      y = pic_cdr(pic, y);
+      ++rapid_count;
+      
+      if(rapid_count == 2){
+        rapid_count = 0;
+        local = pic_cdr(pic, local);
+        if (pic_eq_p(local, x)) {
+          return true;
+        }
+      }
+      goto LOOP;
+    }else{
       return false;
     }
-    for(i = 0; i < v1->len; ++i){
-      if(v1->data[i] != v2->data[i])
-        return false;
-    }
-    return true;
-  }
+      
   case PIC_TT_VECTOR:{
     size_t i;
     struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y);
@@ -45,18 +99,28 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
       return false;
     }
     for(i = 0; i < v1->len; ++i){
-      if(! pic_equal_p(pic, v1->data[i], v2->data[i]))
-        return false;
+      if(! pic_internal_equal_p(pic, v1->data[i], v2->data[i], depth + 1, ht)){
+        return false;          
+        }
     }
     return true;
   }
+  case PIC_TT_BLOB: 
+    return pic_blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
   case PIC_TT_STRING:
-    return pic_strcmp(pic_str_ptr(x), pic_str_ptr(y)) == 0;
+    return pic_string_equal_p(pic_str_ptr(x), pic_str_ptr(y));
   default:
     return false;
   }
 }
 
+bool
+pic_equal_p(pic_state *pic, pic_value x, pic_value y){
+  xhash ht;
+  xh_init_ptr(&ht, 0);
+  return pic_internal_equal_p(pic, x, y, 0, &ht);
+}
+
 static pic_value
 pic_bool_eq_p(pic_state *pic)
 {

From 2526474fb3356e02b8a00798317b5579a711a163 Mon Sep 17 00:00:00 2001
From: stibear <stibear1996@gmail.com>
Date: Thu, 26 Jun 2014 22:44:38 +0900
Subject: [PATCH 006/216] implements delete-duplicates(!) tail-recursively

---
 piclib/srfi/1.scm | 650 +++++++++++++++++++++++-----------------------
 1 file changed, 325 insertions(+), 325 deletions(-)

diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm
index 2eafdf0d..8859b06b 100644
--- a/piclib/srfi/1.scm
+++ b/piclib/srfi/1.scm
@@ -1,6 +1,6 @@
 (define-library (srfi 1)
   (import (scheme base)
-	  (scheme cxr))
+          (scheme cxr))
 
   ;; # Constructors
   ;; cons list
@@ -15,32 +15,32 @@
   (define (cons* x . args)
     (let rec ((acc '()) (x x) (lst args))
       (if (null? lst)
-	  (append-reverse acc x)
-	  (rec (cons x acc) (car lst) (cdr lst)))))
+          (append-reverse acc x)
+          (rec (cons x acc) (car lst) (cdr lst)))))
 
   (define (list-tabulate n init-proc)
     (let rec ((acc '()) (n (- n 1)))
       (if (zero? n)
-	  (cons n acc)
-	  (rec (cons n acc) (- n 1)))))
+          (cons n acc)
+          (rec (cons n acc) (- n 1)))))
 
   (define (circular-list elt . args)
     (let ((lst (cons elt args)))
       (let rec ((l lst))
-	(if (null? (cdr l))
-	    (set-cdr! l lst)
-	    (rec (cdr l))))
+        (if (null? (cdr l))
+            (set-cdr! l lst)
+            (rec (cdr l))))
       lst))
 
   (define (iota count . lst)
     (let ((start (if (pair? lst) (car lst) 0))
-	  (step (if (and (pair? lst) (pair? (cdr lst)))
-		    (cadr lst) 1)))
+          (step (if (and (pair? lst) (pair? (cdr lst)))
+                    (cadr lst) 1)))
       (let rec ((count (- count 1)) (acc '()))
-	(if (zero? count)
-	    (cons start acc)
-	    (rec (- count 1)
-		 (cons (+ start (* count step)) acc))))))
+        (if (zero? count)
+            (cons start acc)
+            (rec (- count 1)
+                 (cons (+ start (* count step)) acc))))))
 
   (export cons list xcons make-list list-tabulate list-copy circular-list iota)
 
@@ -55,38 +55,38 @@
   (define (circular-list? x)
     (let rec ((rapid x) (local x))
       (if (and (pair? rapid) (pair? (cdr rapid)))
-        (if (eq? (cddr rapid) (cdr local))
-          #t
-          (rec (cddr rapid) (cdr local)))
-        #f)))
+          (if (eq? (cddr rapid) (cdr local))
+              #t
+              (rec (cddr rapid) (cdr local)))
+          #f)))
 
   (define proper-list? list?)
 
   (define (dotted-list? x)
     (and (pair? x)
-	 (not (proper-list? x))
-	 (not (circular-list? x))))
+         (not (proper-list? x))
+         (not (circular-list? x))))
 
   (define (null-list? x)
     (cond ((pair? x) #f)
-	  ((null? x) #t)
-	  (else (error "null-list?: argument out of domain" x))))
+          ((null? x) #t)
+          (else (error "null-list?: argument out of domain" x))))
 
   (define (list= elt= . lists)
     (or (null? lists)
-	(let rec1 ((list1 (car lists)) (others (cdr lists)))
-	  (or (null? others)
-	      (let ((list2 (car others))
-		    (others (cdr others)))
-		(if (eq? list1 list2)
-		    (rec1 list2 others)
-		    (let rec2 ((l1 list1) (l2 list2))
-		      (if (null-list? l1)
-			  (and (null-list? l2)
-			       (rec1 list2 others))
-			  (and (not (null-list? l2))
-			       (elt= (car l1) (car l2))
-			       (rec2 (cdr l1) (cdr l2)))))))))))
+        (let rec1 ((list1 (car lists)) (others (cdr lists)))
+          (or (null? others)
+              (let ((list2 (car others))
+                    (others (cdr others)))
+                (if (eq? list1 list2)
+                    (rec1 list2 others)
+                    (let rec2 ((l1 list1) (l2 list2))
+                      (if (null-list? l1)
+                          (and (null-list? l2)
+                               (rec1 list2 others))
+                          (and (not (null-list? l2))
+                               (elt= (car l1) (car l2))
+                               (rec2 (cdr l1) (cdr l2)))))))))))
 
   (export pair? null? not-pair? proper-list? circular-list? null-list? list=)
 
@@ -124,17 +124,17 @@
   (define (take! x i)
     (let rec ((lis x) (n (- i 1)))
       (if (zero? n)
-	  (begin (set-cdr! lis '()) x)
-	  (rec (cdr lis) (- n 1)))))
+          (begin (set-cdr! lis '()) x)
+          (rec (cdr lis) (- n 1)))))
 
   (define (drop-right! flist i)
     (let ((lead (drop flist i)))
       (if (not-pair? lead)
-	  '()
-	  (let rec ((lis1 flist) (lis2 (cdr lead)))
-	    (if (pair? lis2)
-		(rec (cdr lis1) (cdr lis2))
-		(begin (set-cdr! lis1 '()) flist))))))
+          '()
+          (let rec ((lis1 flist) (lis2 (cdr lead)))
+            (if (pair? lis2)
+                (rec (cdr lis1) (cdr lis2))
+                (begin (set-cdr! lis1 '()) flist))))))
 
   (define (split-at x i)
     (values (take x i) (drop x i)))
@@ -167,12 +167,12 @@
 
 
   (export car cdr car+cdr list-ref
-	  caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
-	  caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
-	  cdadar cdaddr cddaar cddadr cdddar cddddr
-	  first second third fourth fifth sixth seventh eighth ninth tenth
+          caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
+          caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
+          cdadar cdaddr cddaar cddadr cdddar cddddr
+          first second third fourth fifth sixth seventh eighth ninth tenth
           take drop take-right drop-right take! drop-right!
-	  split-at split-at! last last-pair)
+          split-at split-at! last last-pair)
 
   ;; # Miscellaneous
   ;; length length+
@@ -183,19 +183,19 @@
   ;; count
   (define (length+ lst)
     (if (not (circular-list? lst))
-	(length lst)))
+        (length lst)))
 
   (define (concatenate lists)
     (apply append lists))
 
   (define (append! . lists)
     (if (null? lists)
-	'()
-	(let rec ((lst lists))
-	  (if (not-pair? (cdr lst))
-	      (car lst)
-	      (begin (set-cdr! (last-pair (car lst)) (cdr lst))
-		     (rec (cdr lst)))))))
+        '()
+        (let rec ((lst lists))
+          (if (not-pair? (cdr lst))
+              (car lst)
+              (begin (set-cdr! (last-pair (car lst)) (cdr lst))
+                     (rec (cdr lst)))))))
 
   (define (concatenate! lists)
     (apply append! lists))
@@ -203,10 +203,10 @@
   (define (reverse! list)
     (let rec ((lst list) (acc '()))
       (if (null? lst)
-	  acc
-	  (let ((rst (cdr lst)))
-	    (set-cdr! lst acc)
-	    (rec rst lst)))))
+          acc
+          (let ((rst (cdr lst)))
+            (set-cdr! lst acc)
+            (rec rst lst)))))
 
   (set! append-reverse
         (lambda (rev-head tail)
@@ -217,9 +217,9 @@
   (define (append-reverse! rev-head tail)
     (let ((rst (cdr rev-head)))
       (if (null? rev-head)
-	  tail
-	  (begin (set-cdr! rev-head tail)
-		 (append-reverse! rst rev-head)))))
+          tail
+          (begin (set-cdr! rev-head tail)
+                 (append-reverse! rst rev-head)))))
 
   (define (zip . lists)
     (apply map list lists))
@@ -229,37 +229,37 @@
 
   (define (unzip2 list)
     (values (map first list)
-	    (map second list)))
+            (map second list)))
 
   (define (unzip3 list)
     (values (map first list)
-	    (map second list)
-	    (map third list)))
+            (map second list)
+            (map third list)))
 
   (define (unzip4 list)
     (values (map first list)
-	    (map second list)
-	    (map third list)
-	    (map fourth list)))
+            (map second list)
+            (map third list)
+            (map fourth list)))
 
   (define (unzip5 list)
     (values (map first list)
-	    (map second list)
-	    (map third list)
-	    (map fourth list)
-	    (map fifth list)))
+            (map second list)
+            (map third list)
+            (map fourth list)
+            (map fifth list)))
 
   (define (count pred . clists)
     (let rec ((tflst (apply map pred clists)) (n 0))
       (if (null? tflst)
-	  n
-	  (rec (cdr tflst) (if (car tflst) (+ n 1) n)))))
+          n
+          (rec (cdr tflst) (if (car tflst) (+ n 1) n)))))
 
   (export length length+
-	  append append! concatenate concatenate!
-	  reverse reverse! append-reverse append-reverse!
-	  zip unzip1 unzip2 unzip3 unzip4 unzip5
-	  count)
+          append append! concatenate concatenate!
+          reverse reverse! append-reverse append-reverse!
+          zip unzip1 unzip2 unzip3 unzip4 unzip5
+          count)
 
   ;; # Fold, unfold & map
   ;; map for-each
@@ -273,80 +273,80 @@
 
   (define (fold kons knil clist . clists)
     (if (null? clists)
-	(let rec ((acc knil) (clist clist))
-	  (if (null? clist)
-	      acc
-	      (rec (kons (car clist) acc) (cdr clist))))
-	(let rec ((acc knil) (clists (cons clist clists)))
-	  (if (every pair? clists)
-	      (rec (apply kons (append (map car clists) (list acc)))
-		   (map cdr clists))
-	      acc))))
+        (let rec ((acc knil) (clist clist))
+          (if (null? clist)
+              acc
+              (rec (kons (car clist) acc) (cdr clist))))
+        (let rec ((acc knil) (clists (cons clist clists)))
+          (if (every pair? clists)
+              (rec (apply kons (append (map car clists) (list acc)))
+                   (map cdr clists))
+              acc))))
 
   (define (fold-right kons knil clist . clists)
     (if (null? clists)
-	(let rec ((clist clist) (cont values))
-	  (if (null? clist)
-	      (cont knil)
-	      (rec (cdr clist) (lambda (x) (cont (kons (car clist) x))))))
-	(let rec ((clists (cons clist clists)) (cont values))
-	  (if (every pair? clists)
-	      (rec (map cdr clists)
-		   (lambda (x)
-		     (cont (apply kons (append (map car clists) (list x))))))
-	      (cont knil)))))
+        (let rec ((clist clist) (cont values))
+          (if (null? clist)
+              (cont knil)
+              (rec (cdr clist) (lambda (x) (cont (kons (car clist) x))))))
+        (let rec ((clists (cons clist clists)) (cont values))
+          (if (every pair? clists)
+              (rec (map cdr clists)
+                   (lambda (x)
+                     (cont (apply kons (append (map car clists) (list x))))))
+              (cont knil)))))
 
   (define (pair-fold kons knil clist . clists)
     (if (null? clists)
-	(let rec ((acc knil) (clist clist))
-	  (if (null? clist)
-	      acc
-	      (let ((tail (cdr clist)))
-		(rec (kons clist acc) tail))))
-	(let rec ((acc knil) (clists (cons clist clists)))
-	  (if (every pair? clists)
-	      (let ((tail (map cdr clists)))
-		(rec (apply kons (append clists (list acc)))
-		     tail))
-	      acc))))
+        (let rec ((acc knil) (clist clist))
+          (if (null? clist)
+              acc
+              (let ((tail (cdr clist)))
+                (rec (kons clist acc) tail))))
+        (let rec ((acc knil) (clists (cons clist clists)))
+          (if (every pair? clists)
+              (let ((tail (map cdr clists)))
+                (rec (apply kons (append clists (list acc)))
+                     tail))
+              acc))))
 
   (define (pair-fold-right kons knil clist . clists)
     (if (null? clists)
-	(let rec ((clist clist) (cont values))
-	  (if (null? clist)
-	      (cont knil)
-	      (let ((tail (map cdr clists)))
-		(rec tail (lambda (x) (cont (kons clist x)))))))
-	(let rec ((clists (cons clist clists)) (cont values))
-	  (if (every pair? clists)
-	      (let ((tail (map cdr clists)))
-		(rec tail
-		     (lambda (x)
-		       (cont (apply kons (append clists (list x)))))))
-	      (cont knil)))))
+        (let rec ((clist clist) (cont values))
+          (if (null? clist)
+              (cont knil)
+              (let ((tail (map cdr clists)))
+                (rec tail (lambda (x) (cont (kons clist x)))))))
+        (let rec ((clists (cons clist clists)) (cont values))
+          (if (every pair? clists)
+              (let ((tail (map cdr clists)))
+                (rec tail
+                     (lambda (x)
+                       (cont (apply kons (append clists (list x)))))))
+              (cont knil)))))
 
   (define (reduce f ridentity list)
     (if (null? list)
-	ridentity
-	(fold f (car list) (cdr list))))
+        ridentity
+        (fold f (car list) (cdr list))))
 
   (define (reduce-right f ridentity list)
     (fold-right f ridentity list))
 
   (define (unfold p f g seed . tail-gen)
     (let ((tail-gen (if (null? tail-gen)
-			(lambda (x) '())
-			(car tail-gen))))
+                        (lambda (x) '())
+                        (car tail-gen))))
       (let rec ((seed seed) (cont values))
-	(if (p seed)
-	    (cont (tail-gen seed))
-	    (rec (g seed) (lambda (x) (cont (cons (f seed) x))))))))
+        (if (p seed)
+            (cont (tail-gen seed))
+            (rec (g seed) (lambda (x) (cont (cons (f seed) x))))))))
 
   (define (unfold-right p f g seed . tail)
     (let rec ((seed seed) (lst tail))
       (if (p seed)
-	  lst
-	  (rec (g seed) (cons (f seed) lst)))))
+          lst
+          (rec (g seed) (cons (f seed) lst)))))
 
   (define (append-map f . clists)
     (apply append (apply map f clists)))
@@ -356,47 +356,47 @@
 
   (define (pair-for-each f clist . clists)
     (if (null? clist)
-	(let rec ((clist clist))
-	  (if (pair? clist)
-	      (begin (f clist) (rec (cdr clist)))))
-	(let rec ((clists (cons clist clists)))
-	  (if (every pair? clists)
-	      (begin (apply f clists) (rec (map cdr clists)))))))
+        (let rec ((clist clist))
+          (if (pair? clist)
+              (begin (f clist) (rec (cdr clist)))))
+        (let rec ((clists (cons clist clists)))
+          (if (every pair? clists)
+              (begin (apply f clists) (rec (map cdr clists)))))))
 
   (define (map! f list . lists)
     (if (null? lists)
-	(pair-for-each (lambda (x) (set-car! x (f (car x)))) list)
-	(let rec ((list list) (lists lists))
-	  (if (pair? list)
-	      (let ((head (map car lists))
-		    (rest (map cdr lists)))
-		(set-car! list (apply f (car list) head))
-		(rec (cdr list) rest)))))
+        (pair-for-each (lambda (x) (set-car! x (f (car x)))) list)
+        (let rec ((list list) (lists lists))
+          (if (pair? list)
+              (let ((head (map car lists))
+                    (rest (map cdr lists)))
+                (set-car! list (apply f (car list) head))
+                (rec (cdr list) rest)))))
     list)
 
   (define (map-in-order f clist . clists)
     (if (null? clists)
-	(let rec ((clist clist) (acc '()))
-	  (if (null? clist)
-	      (reverse! acc)
-	      (rec (cdr clist) (cons (f (car clist)) acc))))
-	(let rec ((clists (cons clist clists)) (acc '()))
-	  (if (every pair? clists)
-	      (rec (map cdr clists)
-		   (cons* (apply f (map car clists)) acc))
-	      (reverse! acc)))))
+        (let rec ((clist clist) (acc '()))
+          (if (null? clist)
+              (reverse! acc)
+              (rec (cdr clist) (cons (f (car clist)) acc))))
+        (let rec ((clists (cons clist clists)) (acc '()))
+          (if (every pair? clists)
+              (rec (map cdr clists)
+                   (cons* (apply f (map car clists)) acc))
+              (reverse! acc)))))
 
   (define (filter-map f clist . clists)
     (let recur ((l (apply map f clist clists)))
       (cond ((null? l) '())
-	    ((car l)   (cons (car l) (recur (cdr l))))
-	    (else      (recur (cdr l))))))
+            ((car l)   (cons (car l) (recur (cdr l))))
+            (else      (recur (cdr l))))))
 
   (export map for-each
-	  fold unfold pair-fold reduce
-	  fold-right unfold-right pair-fold-right reduce-right
-	  append-map append-map!
-	  map! pair-for-each filter-map map-in-order)
+          fold unfold pair-fold reduce
+          fold-right unfold-right pair-fold-right reduce-right
+          append-map append-map!
+          map! pair-for-each filter-map map-in-order)
 
   ;; # Filtering & partitioning
   ;; filter partition remove
@@ -415,21 +415,21 @@
   (define (filter! pred list)
     (let rec ((lst list))
       (if (null? lst)
-	  lst
-	  (if (pred (car lst))
-	      (begin (set-cdr! lst (rec (cdr lst)))
-		     lst)
-	      (rec (cdr lst))))))
+          lst
+          (if (pred (car lst))
+              (begin (set-cdr! lst (rec (cdr lst)))
+                     lst)
+              (rec (cdr lst))))))
 
   (define (remove! pred list)
     (filter! (lambda (x) (not (pred x))) list))
 
   (define (partition! pred list)
     (values (filter! pred list)
-	    (remove! pred list)))
+            (remove! pred list)))
 
   (export filter partition remove
-	  filter! partition! remove!)
+          filter! partition! remove!)
 
   ;; # Searching
   ;; member memq memv
@@ -455,55 +455,55 @@
   (define (take-while pred clist)
     (let rec ((clist clist) (cont values))
       (if (null? clist)
-	  (cont '())
-	  (if (pred (car clist))
-	      (rec (cdr clist)
-		   (lambda (x) (cont (cons (car clist) x))))
-	      (cont '())))))
+          (cont '())
+          (if (pred (car clist))
+              (rec (cdr clist)
+                   (lambda (x) (cont (cons (car clist) x))))
+              (cont '())))))
 
   (define (take-while! pred clist)
     (let rec ((clist clist))
       (if (null? clist)
-	  '()
-	  (if (pred (car clist))
-	      (begin (set-cdr! clist (rec (cdr clist)))
-		     clist)
-	      '()))))
+          '()
+          (if (pred (car clist))
+              (begin (set-cdr! clist (rec (cdr clist)))
+                     clist)
+              '()))))
 
   (define (drop-while pred clist)
     (let rec ((clist clist))
       (if (null? clist)
-	  '()
-	  (if (pred (car clist))
-	      (rec (cdr clist))
-	      clist))))
+          '()
+          (if (pred (car clist))
+              (rec (cdr clist))
+              clist))))
 
   (define (span pred clist)
     (values (take-while pred clist)
-	    (drop-while pred clist)))
+            (drop-while pred clist)))
 
   (define (span! pred clist)
     (values (take-while! pred clist)
-	    (drop-while pred clist)))
+            (drop-while pred clist)))
 
   (define (break pred clist)
     (values (take-while (lambda (x) (not (pred x))) clist)
-	    (drop-while (lambda (x) (not (pred x))) clist)))
+            (drop-while (lambda (x) (not (pred x))) clist)))
 
   (define (break! pred clist)
     (values (take-while! (lambda (x) (not (pred x))) clist)
-	    (drop-while (lambda (x) (not (pred x))) clist)))
+            (drop-while (lambda (x) (not (pred x))) clist)))
 
   (define (any pred clist . clists)
     (if (null? clists)
-	(let rec ((clist clist))
-	  (if (pair? clist)
-	      (or (pred (car clist))
-		  (rec (cdr clist)))))
-	(let rec ((clists (cons clist clists)))
-	  (if (every pair? clists)
-	      (or (apply pred (map car clists))
-		  (rec (map cdr clists)))))))
+        (let rec ((clist clist))
+          (if (pair? clist)
+              (or (pred (car clist))
+                  (rec (cdr clist)))))
+        (let rec ((clists (cons clist clists)))
+          (if (every pair? clists)
+              (or (apply pred (map car clists))
+                  (rec (map cdr clists)))))))
 
   (set! every
         (lambda (pred clist . clists)
@@ -519,23 +519,23 @@
 
   (define (list-index pred clist . clists)
     (if (null? clists)
-	(let rec ((clist clist) (n 0))
-	  (if (pair? clist)
-	      (if (pred (car clist))
-		  n
-		  (rec (cdr clist) (+ n 1)))))
-	(let rec ((clists (cons clist clists)) (n 0))
-	  (if (every pair? clists)
-	      (if (apply pred (map car clists))
-		  n
-		  (rec (map cdr clists) (+ n 1)))))))
+        (let rec ((clist clist) (n 0))
+          (if (pair? clist)
+              (if (pred (car clist))
+                  n
+                  (rec (cdr clist) (+ n 1)))))
+        (let rec ((clists (cons clist clists)) (n 0))
+          (if (every pair? clists)
+              (if (apply pred (map car clists))
+                  n
+                  (rec (map cdr clists) (+ n 1)))))))
 
   (export member memq memv
-	  find find-tail
-	  any every
-	  list-index
-	  take-while drop-while take-while!
-	  span break span! break!)
+          find find-tail
+          any every
+          list-index
+          take-while drop-while take-while!
+          span break span! break!)
 
   ;; # Deleting
   ;; delete delete-duplicates
@@ -550,26 +550,26 @@
 
   (define (delete-duplicates list . =)
     (let ((= (if (null? =) equal? (car =))))
-      (let rec ((list list))
-	(if (null? list)
-	    list
-	    (let* ((x (car list))
-		   (rest (cdr list))
-		   (deleted (rec (delete x list =))))
-	      (if (eq? rest deleted) list (cons x deleted)))))))
+      (let rec ((list list) (cont values))
+        (if (null? list)
+            (cont '())
+            (let* ((x (car list))
+                   (rest (cdr list))
+                   (deleted (delete x rest =)))
+              (rec deleted (lambda (y) (cont (cons x y)))))))))
 
   (define (delete-duplicates! list . =)
     (let ((= (if (null? =) equal? (car =))))
-      (let rec ((list list))
-	(if (null? list)
-	    list
-	    (let* ((x (car list))
-		   (rest (cdr list))
-		   (deleted (rec (delete! x list =))))
-	      (if (eq? rest deleted) list (cons x deleted)))))))
+      (let rec ((list list) (cont values))
+        (if (null? list)
+            (cont '())
+            (let* ((x (car list))
+                   (rest (cdr list))
+                   (deleted (delete! x list =)))
+              (rec deleted (lambda (y) (cont (cons x y)))))))))
 
   (export delete delete-duplicates
-	  delete! delete-duplicates!)
+          delete! delete-duplicates!)
 
   ;; # Association lists
   ;; assoc assq assv
@@ -590,8 +590,8 @@
       (remove! (lambda (x) (= key (car x))) alist)))
 
   (export assoc assq assv
-	  alist-cons alist-copy
-	  alist-delete alist-delete!)
+          alist-cons alist-copy
+          alist-delete alist-delete!)
 
   ;; # Set operations on lists
   ;; lset<= lset= lset-adjoin
@@ -602,156 +602,156 @@
   ;; lset-diff+intersenction lset-diff+intersection!
   (define (lset<= = . lists)
     (or (null? lists)
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (or (null? rest)
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(and (or (eq? head next)
-			 (every (lambda (x) (member x next =)) head))
-		     (rec next rest)))))))
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (or (null? rest)
+              (let ((next (car rest)) (rest (cdr rest)))
+                (and (or (eq? head next)
+                         (every (lambda (x) (member x next =)) head))
+                     (rec next rest)))))))
 
   (define (lset= = . lists)
     (or (null? lists)
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (or (null? rest)
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(and (or (eq? head next)
-			 (and (every (lambda (x) (member x next =)) head)
-			      (every (lambda (x) (member x head =)) next))
-			 (rec next rest))))))))
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (or (null? rest)
+              (let ((next (car rest)) (rest (cdr rest)))
+                (and (or (eq? head next)
+                         (and (every (lambda (x) (member x next =)) head)
+                              (every (lambda (x) (member x head =)) next))
+                         (rec next rest))))))))
 
   (define (lset-adjoin = list . elts)
     (let rec ((list list) (elts elts))
       (if (null? elts)
-	  list
-	  (if (member (car elts) list)
-	      (rec list (cdr elts))
-	      (rec (cons (car elts) list) (cdr elts))))))
+          list
+          (if (member (car elts) list)
+              (rec list (cdr elts))
+              (rec (cons (car elts) list) (cdr elts))))))
 
   (define (lset-union = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    (rec head rest)
-		    (rec (apply lset-adjoin = head next) rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    (rec head rest)
+                    (rec (apply lset-adjoin = head next) rest)))))))
 
   (define (lset-intersection = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    (rec head rest)
-		    (rec (filter (lambda (x) (member x next =)) head)
-			 rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    (rec head rest)
+                    (rec (filter (lambda (x) (member x next =)) head)
+                         rest)))))))
 
   (define (lset-difference = list . lists)
     (let rec ((head list) (rest lists))
       (if (null? rest)
-	  head
-	  (let ((next (car rest)) (rest (cdr rest)))
-	    (if (eq? head next)
-		'()
-		(rec (remove (lambda (x) (member x next =)) head)
-		     rest))))))
+          head
+          (let ((next (car rest)) (rest (cdr rest)))
+            (if (eq? head next)
+                '()
+                (rec (remove (lambda (x) (member x next =)) head)
+                     rest))))))
 
   (define (lset-xor = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    '()
-		    (rec (append (remove (lambda (x) (member x next =)) head)
-				 (remove (lambda (x) (member x head =)) next))
-			 rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    '()
+                    (rec (append (remove (lambda (x) (member x next =)) head)
+                                 (remove (lambda (x) (member x head =)) next))
+                         rest)))))))
 
   (define (lset-diff+intersection = list . lists)
     (values (apply lset-difference = list lists)
-	    (lset-intersection = list (apply lset-union lists))))
+            (lset-intersection = list (apply lset-union lists))))
 
   (define (lset-adjoin! = list . elts)
     (let rec ((list list) (elts elts))
       (if (null? elts)
-	  list
-	  (if (member (car elts) list)
-	      (rec list (cdr elts))
-	      (let ((tail (cdr elts)))
-		(set-cdr! elts list)
-		(rec elts tail))))))
+          list
+          (if (member (car elts) list)
+              (rec list (cdr elts))
+              (let ((tail (cdr elts)))
+                (set-cdr! elts list)
+                (rec elts tail))))))
 
   (define (lset-union! = . lists)
     (letrec ((adjoin
-	      (lambda (lst1 lst2)
-		(if (null? lst2)
-		    lst1
-		    (if (member (car lst2) lst1 =)
-			(adjoin lst1 (cdr lst2))
-			(let ((tail (cdr lst2)))
-			  (set-cdr! lst2 lst1)
-			  (adjoin lst2 tail)))))))
+              (lambda (lst1 lst2)
+                (if (null? lst2)
+                    lst1
+                    (if (member (car lst2) lst1 =)
+                        (adjoin lst1 (cdr lst2))
+                        (let ((tail (cdr lst2)))
+                          (set-cdr! lst2 lst1)
+                          (adjoin lst2 tail)))))))
       (if (null? lists)
-	  lists
-	  (let rec ((head (car lists)) (rest (cdr lists)))
-	    (if (null? rest)
-		head
-		(let ((next (car rest)) (rest (cdr rest)))
-		  (if (eq? head next)
-		      (rec head rest)
-		      (rec (adjoin head next) rest))))))))
+          lists
+          (let rec ((head (car lists)) (rest (cdr lists)))
+            (if (null? rest)
+                head
+                (let ((next (car rest)) (rest (cdr rest)))
+                  (if (eq? head next)
+                      (rec head rest)
+                      (rec (adjoin head next) rest))))))))
 
   (define (lset-intersection! = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    (rec head rest)
-		    (rec (filter! (lambda (x) (member x next =)) head)
-			 rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    (rec head rest)
+                    (rec (filter! (lambda (x) (member x next =)) head)
+                         rest)))))))
 
   (define (lset-difference! = list . lists)
     (let rec ((head list) (rest lists))
       (if (null? rest)
-	  head
-	  (let ((next (car rest)) (rest (cdr rest)))
-	    (if (eq? head next)
-		'()
-		(rec (remove! (lambda (x) (member x next =)) head)
-		     rest))))))
+          head
+          (let ((next (car rest)) (rest (cdr rest)))
+            (if (eq? head next)
+                '()
+                (rec (remove! (lambda (x) (member x next =)) head)
+                     rest))))))
 
   (define (lset-xor! = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    '()
-		    (rec (append! (remove! (lambda (x) (member x next =)) head)
-				  (remove! (lambda (x) (member x head =)) next))
-			 rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    '()
+                    (rec (append! (remove! (lambda (x) (member x next =)) head)
+                                  (remove! (lambda (x) (member x head =)) next))
+                         rest)))))))
 
   (define (lset-diff+intersection! = list . lists)
     (values (apply lset-difference! = list lists)
-	    (lset-intersection! = list (apply lset-union! lists))))
+            (lset-intersection! = list (apply lset-union! lists))))
 
   (export lset<= lset= lset-adjoin
-	  lset-union lset-union!
-	  lset-intersection lset-intersection!
-	  lset-difference lset-difference!
-	  lset-xor lset-xor!
-	  lset-diff+intersection lset-diff+intersection!)
+          lset-union lset-union!
+          lset-intersection lset-intersection!
+          lset-difference lset-difference!
+          lset-xor lset-xor!
+          lset-diff+intersection lset-diff+intersection!)
 
   ;; # Primitive side-effects
   ;; set-car! set-cdr!

From 606f34420c0594d586966d1436701cb5f1cc3024 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 07:12:35 +0900
Subject: [PATCH 007/216] update gitignore

---
 .gitignore | 2 --
 1 file changed, 2 deletions(-)

diff --git a/.gitignore b/.gitignore
index 6b185c72..e0975baf 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,6 +1,4 @@
 build/*
-src/lex.yy.c
-src/lex.yy.h
 src/load_piclib.c
 .dir-locals.el
 GPATH

From 1eb4940b135bd810ea18be7e126b54c91459606a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 07:23:19 +0900
Subject: [PATCH 008/216] use isdigit

---
 src/read.c | 8 ++------
 1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/src/read.c b/src/read.c
index 95158fbd..96893f92 100644
--- a/src/read.c
+++ b/src/read.c
@@ -202,11 +202,9 @@ negate(pic_value n)
 static pic_value
 read_minus(pic_state *pic, struct pic_port *port, char c)
 {
-  static const char DIGITS[] = "0123456789";
-
   /* TODO: -inf.0, -nan.0 */
 
-  if (strchr(DIGITS, peek(port))) {
+  if (isdigit(peek(port))) {
     return negate(read_number(pic, port, c));
   }
   else {
@@ -217,11 +215,9 @@ read_minus(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_plus(pic_state *pic, struct pic_port *port, char c)
 {
-  static const char DIGITS[] = "0123456789";
-
   /* TODO: +inf.0, +nan.0 */
 
-  if (strchr(DIGITS, peek(port))) {
+  if (isdigit(peek(port))) {
     return read_number(pic, port, c);
   }
   else {

From bb43c8d9dc3a589cd6c8de875d5eb08f6ce62ffc Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 07:23:34 +0900
Subject: [PATCH 009/216] add isdelim

---
 src/read.c | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

diff --git a/src/read.c b/src/read.c
index 96893f92..b2d8c8f8 100644
--- a/src/read.c
+++ b/src/read.c
@@ -47,6 +47,12 @@ peek(struct pic_port *port)
   return c;
 }
 
+static bool
+isdelim(char c)
+{
+  return strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
+}
+
 static pic_value
 read_comment(pic_state *pic, struct pic_port *port, char c)
 {
@@ -127,7 +133,6 @@ read_comma(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_symbol(pic_state *pic, struct pic_port *port, char c)
 {
-  static const char TRAIL_SYMBOL[] = "+/*!$%&:@^~?<=>_.-";
   size_t len;
   char *buf;
   pic_sym sym;
@@ -142,7 +147,7 @@ read_symbol(pic_state *pic, struct pic_port *port, char c)
     len += 1;
     buf = pic_realloc(pic, buf, len);
     buf[len - 1] = c;
-  } while (isalnum(peek(port)) || strchr(TRAIL_SYMBOL, peek(port)));
+  } while (! isdelim(peek(port)));
 
   buf[len] = '\0';
   sym = pic_intern_cstr(pic, buf);
@@ -338,7 +343,7 @@ read_pair(pic_state *pic, struct pic_port *port, char c)
   if (c == tCLOSE) {
     return pic_nil_value();
   }
-  if (c == '.' && strchr("()#;,|'\" \t\n\r", peek(port)) != NULL) {
+  if (c == '.' && isdelim(peek(port))) {
     cdr = read(pic, port, next(port));
 
     if ((c = skip(port, ' ')) != tCLOSE) {

From 556a4606637aae9a97d2f921c05dfe0cfa979a9b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 07:28:46 +0900
Subject: [PATCH 010/216] [bugfix] EOF is a delimiter

---
 src/read.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index b2d8c8f8..f76e26f8 100644
--- a/src/read.c
+++ b/src/read.c
@@ -50,7 +50,7 @@ peek(struct pic_port *port)
 static bool
 isdelim(char c)
 {
-  return strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
+  return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
 }
 
 static pic_value

From a98411cd0bac26907c01509367d57768d587f65d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 07:28:56 +0900
Subject: [PATCH 011/216] syntax error around comma

---
 piclib/built-in.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 64e2ee10..4660cf89 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -1063,7 +1063,7 @@
 			 (let-values (((match1 vars1) (compile-match-base (car pattern))))
 			   (loop (cdr pattern)
 				 (cons `(,_if (,_pair? ,accessor)
-					      (,_let ((expr (,_car,accessor)))
+					      (,_let ((expr (,_car ,accessor)))
 						     ,match1)
 					      (exit #f))
 				       matches)

From 0b85e251a2882c5a61bfd0a902d74ca13e1f39e1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 07:59:25 +0900
Subject: [PATCH 012/216] fix negative number reader

---
 src/read.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index f76e26f8..d123059c 100644
--- a/src/read.c
+++ b/src/read.c
@@ -210,7 +210,7 @@ read_minus(pic_state *pic, struct pic_port *port, char c)
   /* TODO: -inf.0, -nan.0 */
 
   if (isdigit(peek(port))) {
-    return negate(read_number(pic, port, c));
+    return negate(read_number(pic, port, next(port)));
   }
   else {
     return read_symbol(pic, port, c);

From e1ca64b56ee438cf718a326969bc65a256e22c0c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 08:21:53 +0900
Subject: [PATCH 013/216] block comment reader must not consume the character
 right after the comment end

---
 src/read.c | 10 ++++------
 1 file changed, 4 insertions(+), 6 deletions(-)

diff --git a/src/read.c b/src/read.c
index d123059c..2e7bb19f 100644
--- a/src/read.c
+++ b/src/read.c
@@ -69,24 +69,22 @@ static pic_value
 read_block_comment(pic_state *pic, struct pic_port *port, char c)
 {
   char x, y;
-  int i;
+  int i = 1;
 
   UNUSED(pic);
   UNUSED(c);
 
-  x = next(port);
   y = next(port);
 
-  i = 1;
-  while (x != EOF && y != EOF && i > 0) {
+  while (y != EOF && i > 0) {
+    x = y;
+    y = next(port);
     if (x == '|' && y == '#') {
       i--;
     }
     if (x == '#' && y == '|') {
       i++;
     }
-    x = y;
-    y = next(port);
   }
 
   return pic_undef_value();

From 36e0aa6f697f1a765f7dfd69173d23a3d03dc677 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 08:34:00 +0900
Subject: [PATCH 014/216] [bugfix] compound literals should consider inner
 comments

---
 src/read.c | 21 ++++++++++++---------
 1 file changed, 12 insertions(+), 9 deletions(-)

diff --git a/src/read.c b/src/read.c
index 2e7bb19f..ccd055d9 100644
--- a/src/read.c
+++ b/src/read.c
@@ -15,6 +15,7 @@
 typedef pic_value (*read_func_t)(pic_state *, struct pic_port *, char);
 
 static pic_value read(pic_state *pic, struct pic_port *port, char c);
+static pic_value read_nullable(pic_state *pic, struct pic_port *port, char c);
 
 static noreturn void
 read_error(pic_state *pic, const char *msg)
@@ -336,6 +337,8 @@ read_pair(pic_state *pic, struct pic_port *port, char c)
   char tOPEN = c, tCLOSE = (tOPEN == '(') ? ')' : ']';
   pic_value car, cdr;
 
+ retry:
+
   c = skip(port, ' ');
 
   if (c == tCLOSE) {
@@ -350,7 +353,12 @@ read_pair(pic_state *pic, struct pic_port *port, char c)
     return cdr;
   }
   else {
-    car = read(pic, port, c);
+    car = read_nullable(pic, port, c);
+
+    if (pic_undef_p(car)) {
+      goto retry;
+    }
+
     cdr = read_pair(pic, port, tOPEN); /* FIXME: don't use recursion */
     return pic_cons(pic, car, cdr);
   }
@@ -359,16 +367,11 @@ read_pair(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_vector(pic_state *pic, struct pic_port *port, char c)
 {
-  pic_value val;
+  pic_value list;
 
-  c = next(port);
+  list = read(pic, port, c);
 
-  val = pic_nil_value();
-  while ((c = skip(port, c)) != ')') {
-    val = pic_cons(pic, read(pic, port, c), val);
-    c = next(port);
-  }
-  return pic_obj_value(pic_vec_new_from_list(pic, pic_reverse(pic, val)));
+  return pic_obj_value(pic_vec_new_from_list(pic, list));
 }
 
 static pic_value

From 195ccf199dc7da63f68b7bf4bcaf1b3531842535 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 08:41:42 +0900
Subject: [PATCH 015/216] [bugfix] make-promise makes a promise that is done
 all along

---
 piclib/built-in.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 4660cf89..ae9ecbce 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -926,7 +926,7 @@
   (define (make-promise obj)
     (if (promise? obj)
 	obj
-	(make-promise% #f obj)))
+	(make-promise% #t obj)))
 
   (export delay-force delay force make-promise promise?))
 

From 51b8344527c5c708cb311890acd65660cafe2280 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 08:54:32 +0900
Subject: [PATCH 016/216] support infinity and nan literals

---
 src/read.c | 20 +++++++++++++++++---
 1 file changed, 17 insertions(+), 3 deletions(-)

diff --git a/src/read.c b/src/read.c
index ccd055d9..03e72aa3 100644
--- a/src/read.c
+++ b/src/read.c
@@ -206,25 +206,39 @@ negate(pic_value n)
 static pic_value
 read_minus(pic_state *pic, struct pic_port *port, char c)
 {
-  /* TODO: -inf.0, -nan.0 */
+  pic_value sym;
 
   if (isdigit(peek(port))) {
     return negate(read_number(pic, port, next(port)));
   }
   else {
-    return read_symbol(pic, port, c);
+    sym = read_symbol(pic, port, c);
+    if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "-inf.0")))) {
+      return pic_float_value(-INFINITY);
+    }
+    if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "-nan.0")))) {
+      return pic_float_value(-NAN);
+    }
+    return sym;
   }
 }
 
 static pic_value
 read_plus(pic_state *pic, struct pic_port *port, char c)
 {
-  /* TODO: +inf.0, +nan.0 */
+  pic_value sym;
 
   if (isdigit(peek(port))) {
     return read_number(pic, port, c);
   }
   else {
+    sym = read_symbol(pic, port, c);
+    if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+inf.0")))) {
+      return pic_float_value(INFINITY);
+    }
+    if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+nan.0")))) {
+      return pic_float_value(NAN);
+    }
     return read_symbol(pic, port, c);
   }
 }

From 4501b9bd93bffdddb6f5227f7c5a286ff82ab27b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 17:35:00 +0900
Subject: [PATCH 017/216] update xrope

---
 extlib/xrope | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extlib/xrope b/extlib/xrope
index 3bc8a992..32d99fae 160000
--- a/extlib/xrope
+++ b/extlib/xrope
@@ -1 +1 @@
-Subproject commit 3bc8a992e249ef6aea6d05dedf3e158446e1339b
+Subproject commit 32d99fae069c1ec7bf0fc31345bfc27cae84b47a

From 3ee807a3473dfee189b9cd30f5cbd5453d566823 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 27 Jun 2014 17:40:43 +0900
Subject: [PATCH 018/216] fix xr_put

---
 src/string.c | 13 +++++++------
 1 file changed, 7 insertions(+), 6 deletions(-)

diff --git a/src/string.c b/src/string.c
index edaf1edc..e9a0095b 100644
--- a/src/string.c
+++ b/src/string.c
@@ -74,28 +74,29 @@ pic_str_ref(pic_state *pic, pic_str *str, size_t i)
 static xrope *
 xr_put(xrope *rope, size_t i, char c)
 {
-  xrope *x, *y;
-  char buf[1];
+  xrope *x, *y, *z;
+  char buf[2];
 
   if (xr_len(rope) <= i) {
     return NULL;
   }
 
   buf[0] = c;
+  buf[1] = '\0';
 
   x = xr_sub(rope, 0, i);
   y = xr_new_copy(buf, 1);
-  rope = xr_cat(x, y);
+  z = xr_cat(x, y);
   XROPE_DECREF(x);
   XROPE_DECREF(y);
 
-  x = rope;
+  x = z;
   y = xr_sub(rope, i + 1, xr_len(rope));
-  rope = xr_cat(x, y);
+  z = xr_cat(z, y);
   XROPE_DECREF(x);
   XROPE_DECREF(y);
 
-  return rope;
+  return z;
 }
 
 void

From 952814ec3d3c7139dc94207e567ff3835929888b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 10:12:53 +0900
Subject: [PATCH 019/216] make no-act: direct error logs to /dev/null

---
 CMakeLists.txt | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/CMakeLists.txt b/CMakeLists.txt
index 12347110..530e568a 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -43,7 +43,7 @@ add_custom_target(run bin/picrin DEPENDS repl)
 add_custom_target(test DEPENDS no-act test-r7rs)
 
 # $ make no-act
-add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl)
+add_custom_target(no-act bin/picrin -e '' > /dev/null 2> /dev/null DEPENDS repl)
 
 # $ make test-r7rs
 add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl)

From 8387397e1b1d72386b615733b0806c56a591d2e3 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 10:13:18 +0900
Subject: [PATCH 020/216] don't run make test in debug mode on travis

---
 .travis.yml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/.travis.yml b/.travis.yml
index fc6103f9..2d33fec2 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -7,4 +7,4 @@ before_script:
 script:
   - perl --version
   - cmake .. && make test
-  - cmake -DCMAKE_BUILD_TYPE=Debug .. && make test
+  - cmake -DCMAKE_BUILD_TYPE=Debug .. && make no-act

From e82a688a66c557265d432960749d0c1c99b6fa41 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 11:31:13 +0900
Subject: [PATCH 021/216] add number prefix to contrib libraries

---
 contrib/10.partcont/CMakeLists.txt                    | 2 ++
 contrib/{partcont => 10.partcont}/piclib/partcont.scm | 0
 contrib/{regexp => 10.regexp}/CMakeLists.txt          | 2 +-
 contrib/{regexp => 10.regexp}/src/regexp.c            | 0
 contrib/partcont/CMakeLists.txt                       | 2 --
 5 files changed, 3 insertions(+), 3 deletions(-)
 create mode 100644 contrib/10.partcont/CMakeLists.txt
 rename contrib/{partcont => 10.partcont}/piclib/partcont.scm (100%)
 rename contrib/{regexp => 10.regexp}/CMakeLists.txt (81%)
 rename contrib/{regexp => 10.regexp}/src/regexp.c (100%)
 delete mode 100644 contrib/partcont/CMakeLists.txt

diff --git a/contrib/10.partcont/CMakeLists.txt b/contrib/10.partcont/CMakeLists.txt
new file mode 100644
index 00000000..65f16fb2
--- /dev/null
+++ b/contrib/10.partcont/CMakeLists.txt
@@ -0,0 +1,2 @@
+file(GLOB PARTCONT_FILES ${PROJECT_SOURCE_DIR}/contrib/10.partcont/piclib/*.scm)
+list(APPEND PICLIB_CONTRIB_LIBS ${PARTCONT_FILES})
diff --git a/contrib/partcont/piclib/partcont.scm b/contrib/10.partcont/piclib/partcont.scm
similarity index 100%
rename from contrib/partcont/piclib/partcont.scm
rename to contrib/10.partcont/piclib/partcont.scm
diff --git a/contrib/regexp/CMakeLists.txt b/contrib/10.regexp/CMakeLists.txt
similarity index 81%
rename from contrib/regexp/CMakeLists.txt
rename to contrib/10.regexp/CMakeLists.txt
index 0e28d430..f71ccfc7 100644
--- a/contrib/regexp/CMakeLists.txt
+++ b/contrib/10.regexp/CMakeLists.txt
@@ -5,7 +5,7 @@ if (REGEX_FOUND)
   add_definitions(${REGEX_DEFINITIONS})
   include_directories(${REGEX_INCLUDE_DIR})
 
-  file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/regexp/src/*.c)
+  file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.regexp/src/*.c)
 
   list(APPEND PICRIN_CONTRIB_INITS "void pic_init_regexp(pic_state *)\; pic_init_regexp(pic)\;")
   list(APPEND PICRIN_CONTRIB_LIBRARIES ${REGEX_LIBRARIES})
diff --git a/contrib/regexp/src/regexp.c b/contrib/10.regexp/src/regexp.c
similarity index 100%
rename from contrib/regexp/src/regexp.c
rename to contrib/10.regexp/src/regexp.c
diff --git a/contrib/partcont/CMakeLists.txt b/contrib/partcont/CMakeLists.txt
deleted file mode 100644
index c1ad29ad..00000000
--- a/contrib/partcont/CMakeLists.txt
+++ /dev/null
@@ -1,2 +0,0 @@
-file(GLOB PARTCONT_FILES ${PROJECT_SOURCE_DIR}/contrib/partcont/piclib/*.scm)
-list(APPEND PICLIB_CONTRIB_LIBS ${PARTCONT_FILES})

From f37c88c174105874de9a7799aa22776948af3f69 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 11:32:23 +0900
Subject: [PATCH 022/216] add for macro library

---
 contrib/20.for/CMakeLists.txt |  2 ++
 contrib/20.for/piclib/for.scm | 18 ++++++++++++++++++
 2 files changed, 20 insertions(+)
 create mode 100644 contrib/20.for/CMakeLists.txt
 create mode 100644 contrib/20.for/piclib/for.scm

diff --git a/contrib/20.for/CMakeLists.txt b/contrib/20.for/CMakeLists.txt
new file mode 100644
index 00000000..ebe66a42
--- /dev/null
+++ b/contrib/20.for/CMakeLists.txt
@@ -0,0 +1,2 @@
+file(GLOB FOR_FILES ${PROJECT_SOURCE_DIR}/contrib/20.for/piclib/*.scm)
+list(APPEND PICLIB_CONTRIB_LIBS ${FOR_FILES})
diff --git a/contrib/20.for/piclib/for.scm b/contrib/20.for/piclib/for.scm
new file mode 100644
index 00000000..bd421ef8
--- /dev/null
+++ b/contrib/20.for/piclib/for.scm
@@ -0,0 +1,18 @@
+(define-library (picrin control list)
+  (import (scheme base)
+          (picrin control)
+          (scheme write))
+
+  (define-syntax for
+    (syntax-rules ()
+      ((_ expr)
+       (reset (lambda () expr)))))
+
+  (define (in m)
+    (shift (lambda (k)
+             (apply append (map k m)))))
+
+  (define (yield x)
+    (list x))
+
+  (export for in yield))

From 31acb210935c4ef17d1ada8913e311eece9dfefc Mon Sep 17 00:00:00 2001
From: stibear <stibear1996@gmail.com>
Date: Sat, 28 Jun 2014 11:48:30 +0900
Subject: [PATCH 023/216] rewrite an unavailable symbol into an available one

---
 piclib/srfi/43.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/piclib/srfi/43.scm b/piclib/srfi/43.scm
index a30757e6..88ebc083 100644
--- a/piclib/srfi/43.scm
+++ b/piclib/srfi/43.scm
@@ -50,7 +50,7 @@
 
                                         ; for the symmetry, this should be rather 'vector=?' than 'vector='.
   (define (vector= elt=? . vects)
-    (letrec ((2vector=
+    (letrec ((vector2=
               (lambda (v1 v2)
                 (let ((ln1 (vector-length v1)))
                   (and (= ln1 (vector-length v2))
@@ -67,7 +67,7 @@
                       (others (cdr others)))
                   (if (eq? vect1 vect2)
                       (rec1 vect1 others)
-                      (and (2vector= vect1 vect2)
+                      (and (vector2= vect1 vect2)
                            (rec1 vect2 others)))))))))
 
   

From c26fc144f31958b1a1870cc772e8336af18c97e5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 12:07:56 +0900
Subject: [PATCH 024/216] added null operator to (picrin control list)

---
 contrib/20.for/piclib/for.scm | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/contrib/20.for/piclib/for.scm b/contrib/20.for/piclib/for.scm
index bd421ef8..d37afd9f 100644
--- a/contrib/20.for/piclib/for.scm
+++ b/contrib/20.for/piclib/for.scm
@@ -15,4 +15,7 @@
   (define (yield x)
     (list x))
 
-  (export for in yield))
+  (define (null . x)
+    '())
+
+  (export for in yield null))

From 706a3a4965ebea6c3ce4bf5eb2ea2e0c88281f97 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 12:14:27 +0900
Subject: [PATCH 025/216] add (picrin control list) doc

---
 docs/libs.rst | 45 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 45 insertions(+)

diff --git a/docs/libs.rst b/docs/libs.rst
index 9d71963f..d4ed18d0 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -79,6 +79,51 @@ Delimited control operators.
 - **(reset h)**
 - **(shift k)**
 
+(picrin control list)
+---------------------
+
+Monadic list operators.
+
+The triple of for/in/yield enables you to write a list operation in a very easy and simple code. One of the best examples is list composition::
+
+  (for (let ((a (in '(1 2 3)))
+             (b (in '(2 3 4))))
+         (yield (+ a b))))
+
+  ;=> (5 6 7 6 7 8 7 8 9)
+
+All monadic operations are done in *for* macro. In this example, *in* operators choose an element from the given lists, a and b are bound here, then *yielding* the sum of them. Because a and b are values moving around in the list elements, the expression (+ a b) can become every possible result. *yield* operator is a operator that gathers the possibilities into a list, so *for* macro returns a list of 3 * 3 results in total. Since expression inside *for* macro is a normal expression, you can write everything that you can write elsewhere. The code below has perfectly the same effect to above one::
+
+  (for (yield (+ (in '(1 2 3))
+                 (in '(4 5 6)))))
+
+The second best exmaple is filtering. In the next case, we show that you can do something depending on the condition of chosen elements::
+
+  (for (let ((x (in (iota 10))))
+         (if (even? x)
+             (yield x)
+             (null))))
+
+  ;=> (0 2 4 6 8)
+
+This expression is equivalent to ``(filter even? (iota 10))`` but it is more procedual and non-magical.
+
+- **(for expr)**
+
+  [Macro] Executes expr in a list monad context.
+
+- **(in list)**
+
+  Choose a value from list. *in* function must only appear in *for* macro. The delimited continuation from the position of *in* function to the outside *for* macro is executed for each element in list. If list contains no values, that is ``(in '())``, the continuation is discarded.
+
+- **(yield value)**
+
+  Yields value from the monad context. The result of *for* will be a list of yielded values.
+
+- **(null . value)**
+
+  Returns ``()`` whatever value is given. The identity element of list composition. This operator corresponds to Haskell's fail method of Monad class.
+
 
 (picrin dictionary)
 -------------------

From 1e458d96919bf2427c8a23014d950132b26445e0 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 12:40:02 +0900
Subject: [PATCH 026/216] fix #153

---
 piclib/CMakeLists.txt | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index b795ad54..497d8cd1 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,6 +1,9 @@
 list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/built-in.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
+  ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm
+  ${PROJECT_SOURCE_DIR}/piclib/srfi/43.scm
+  ${PROJECT_SOURCE_DIR}/piclib/srfi/60.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/95.scm
   )

From 6fe87b8fa29a73f60734d91b309bdf23b6f12739 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 12:42:36 +0900
Subject: [PATCH 027/216] update docs. mentioning new srfi libraries

---
 docs/libs.rst | 14 +++++++++++++-
 1 file changed, 13 insertions(+), 1 deletion(-)

diff --git a/docs/libs.rst b/docs/libs.rst
index d4ed18d0..2a7a7a1f 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -20,12 +20,24 @@ SRFI libraries
 
 - (srfi 1)
 
-  List manipulation library.
+  List library.
+
+- (srfi 8)
+
+  ``receive`` macro.
 
 - (srfi 26)
 
   Cut/cute macros.
 
+- (srfi 43)
+
+  Vector library.
+
+- (srfi 60)
+
+  Bitwise operations.
+
 - (srfi 95)
 
   Sorting and Marging.

From 853387668205b88d98b244fa3cc27fad041e4e2e Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Tue, 27 May 2014 21:35:19 +0900
Subject: [PATCH 028/216] vectors, blobs, strings with equal contets are equal

---
 src/bool.c | 24 ++++++++++++++++++++++++
 1 file changed, 24 insertions(+)

diff --git a/src/bool.c b/src/bool.c
index fa56fa31..ef497362 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -6,6 +6,9 @@
 
 #include "picrin.h"
 #include "picrin/pair.h"
+#include "picrin/vector.h"
+#include "picrin/blob.h"
+#include "picrin/string.h"
 
 bool
 pic_equal_p(pic_state *pic, pic_value x, pic_value y)
@@ -22,6 +25,27 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
   case PIC_TT_PAIR:
     return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y))
       && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y));
+  case PIC_TT_BLOB: {
+    int i;
+    struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y);
+    for(i = 0; i < v1->len; ++i){
+      if(v1->data[i] != v2->data[i])
+        return false;
+    }
+    return true;
+  }
+  case PIC_TT_VECTOR:{
+    size_t i;
+    struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y);
+    
+    for(i = 0; i < v1->len; ++i){
+      if(! pic_equal_p(pic, v1->data[i], v2->data[i]))
+        return false;
+    }
+    return true;
+  }
+  case PIC_TT_STRING:
+    return pic_strcmp(pic_str_ptr(x), pic_str_ptr(y)) == 0;
   default:
     return false;
   }

From 49a4808a2262926b866207094000763d89758742 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Wed, 28 May 2014 02:55:19 +0900
Subject: [PATCH 029/216] check length before compare contents

---
 src/bool.c | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/src/bool.c b/src/bool.c
index ef497362..904a21d6 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -28,6 +28,9 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
   case PIC_TT_BLOB: {
     int i;
     struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y);
+    if(v1->len != v2->len){
+      return false;
+    }
     for(i = 0; i < v1->len; ++i){
       if(v1->data[i] != v2->data[i])
         return false;
@@ -38,6 +41,9 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
     size_t i;
     struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y);
     
+    if(v1->len != v2->len){
+      return false;
+    }
     for(i = 0; i < v1->len; ++i){
       if(! pic_equal_p(pic, v1->data[i], v2->data[i]))
         return false;

From 2fb97d16edb606dcb2d0f17bc3133e78aee6eea4 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 19:23:06 +0900
Subject: [PATCH 030/216] style fix

---
 src/bool.c | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/src/bool.c b/src/bool.c
index 904a21d6..07ddcffc 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -23,29 +23,29 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
     return false;
   switch (type) {
   case PIC_TT_PAIR:
-    return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y))
-      && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y));
+    return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y)) && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y));
   case PIC_TT_BLOB: {
     int i;
-    struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y);
-    if(v1->len != v2->len){
+    struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y);
+
+    if(u->len != v->len){
       return false;
     }
-    for(i = 0; i < v1->len; ++i){
-      if(v1->data[i] != v2->data[i])
+    for(i = 0; i < u->len; ++i){
+      if(u->data[i] != v->data[i])
         return false;
     }
     return true;
   }
-  case PIC_TT_VECTOR:{
+  case PIC_TT_VECTOR: {
     size_t i;
-    struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y);
-    
-    if(v1->len != v2->len){
+    struct pic_vector *u = pic_vec_ptr(x), *v = pic_vec_ptr(y);
+
+    if(u->len != v->len){
       return false;
     }
-    for(i = 0; i < v1->len; ++i){
-      if(! pic_equal_p(pic, v1->data[i], v2->data[i]))
+    for(i = 0; i < u->len; ++i){
+      if(! pic_equal_p(pic, u->data[i], v->data[i]))
         return false;
     }
     return true;

From 5ba0402221f053c8ccd1dca2338ab0995d22d593 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 19:23:24 +0900
Subject: [PATCH 031/216] fix type warning (int and size_t)

---
 src/bool.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/bool.c b/src/bool.c
index 07ddcffc..bb4fae82 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -25,7 +25,7 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
   case PIC_TT_PAIR:
     return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y)) && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y));
   case PIC_TT_BLOB: {
-    int i;
+    size_t i;
     struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y);
 
     if(u->len != v->len){

From cee98a9954b149c7121492bb9311bcbee485f244 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 19:43:49 +0900
Subject: [PATCH 032/216] [bugfix] support vector literal in quasiquote

---
 piclib/built-in.scm | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index ae9ecbce..ca2271fa 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -136,6 +136,22 @@
   (define (unquote-splicing? form compare?)
     (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing)))
 
+  (define (list->vector list)
+    (let ((vector (make-vector (length list))))
+      (let loop ((list list) (i 0))
+        (if (null? list)
+            vector
+            (begin
+              (vector-set! vector i (car list))
+              (loop (cdr list) (+ i 1)))))))
+
+  (define (vector->list vector)
+    (let ((length (vector-length vector)))
+      (let loop ((list '()) (i 0))
+        (if (= i length)
+            (reverse list)
+            (loop (cons (vector-ref vector i) list) (+ i 1))))))
+
   (define-syntax quasiquote
     (ir-macro-transformer
      (lambda (form inject compare)
@@ -170,6 +186,9 @@
            (list 'cons
                  (qq depth (car expr))
                  (qq depth (cdr expr))))
+          ;; vector
+          ((vector? expr)
+           (list 'list->vector (qq depth (vector->list expr))))
           ;; simple datum
           (else
            (list 'quote expr))))

From aae4bba98d86a97e88521a95c35cc950351e724d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 19:47:45 +0900
Subject: [PATCH 033/216] [bugfix] wrong size for read string

---
 src/read.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index 03e72aa3..1dae699f 100644
--- a/src/read.c
+++ b/src/read.c
@@ -299,7 +299,7 @@ read_string(pic_state *pic, struct pic_port *port, char c)
   }
   buf[cnt] = '\0';
 
-  str = pic_str_new(pic, buf, size);
+  str = pic_str_new(pic, buf, cnt);
   pic_free(pic, buf);
   return pic_obj_value(str);
 }

From 8f5a4e8980b3ce32a8ca0efb26a66495b05caeb8 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:02:06 +0900
Subject: [PATCH 034/216] unlock reader test

---
 t/r7rs-tests.scm | 90 ++++++++++++++++++++++++------------------------
 1 file changed, 45 insertions(+), 45 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index e5ce8af7..5836ed26 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -32,7 +32,7 @@
 ;        (scheme complex)
         (scheme time)
         (scheme file)
-;        (scheme read)
+        (scheme read)
         (scheme write)
 ;        (scheme eval)
         (scheme process-context)
@@ -1962,56 +1962,56 @@
 (test-begin "Read syntax")
 
 ;; check reading boolean followed by eof
-;; (test #t (read (open-input-string "#t")))
-;; (test #t (read (open-input-string "#true")))
-;; (test #f (read (open-input-string "#f")))
-;; (test #f (read (open-input-string "#false")))
-;; (define (read2 port)
-;;   (let* ((o1 (read port)) (o2 (read port)))
-;;     (cons o1 o2)))
-;; ;; check reading boolean followed by delimiter
-;; (test '(#t . (5)) (read2 (open-input-string "#t(5)")))
-;; (test '(#t . 6) (read2 (open-input-string "#true 6 ")))
-;; (test '(#f . 7) (read2 (open-input-string "#f 7")))
-;; (test '(#f . "8") (read2 (open-input-string "#false\"8\"")))
+(test #t (read (open-input-string "#t")))
+(test #t (read (open-input-string "#true")))
+(test #f (read (open-input-string "#f")))
+(test #f (read (open-input-string "#false")))
+(define (read2 port)
+  (let* ((o1 (read port)) (o2 (read port)))
+    (cons o1 o2)))
+;; check reading boolean followed by delimiter
+(test '(#t . (5)) (read2 (open-input-string "#t(5)")))
+(test '(#t . 6) (read2 (open-input-string "#true 6 ")))
+(test '(#f . 7) (read2 (open-input-string "#f 7")))
+(test '(#f . "8") (read2 (open-input-string "#false\"8\"")))
 
-;; (test '() (read (open-input-string "()")))
-;; (test '(1 2) (read (open-input-string "(1 2)")))
-;; (test '(1 . 2) (read (open-input-string "(1 . 2)")))
-;; (test '(1 2) (read (open-input-string "(1 . (2))")))
-;; (test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))")))
-;; (test '1 (cadr (read (open-input-string "#0=(1 . #0#)"))))
-;; (test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)"))))
+(test '() (read (open-input-string "()")))
+(test '(1 2) (read (open-input-string "(1 2)")))
+(test '(1 . 2) (read (open-input-string "(1 . 2)")))
+(test '(1 2) (read (open-input-string "(1 . (2))")))
+(test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))")))
+(test '1 (cadr (read (open-input-string "#0=(1 . #0#)"))))
+(test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)"))))
 
-;; (test '(quote (1 2)) (read (open-input-string "'(1 2)")))
-;; (test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)")))
-;; (test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)")))
-;; (test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)")))
+(test '(quote (1 2)) (read (open-input-string "'(1 2)")))
+(test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)")))
+(test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)")))
+(test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)")))
 
-;; (test #() (read (open-input-string "#()")))
-;; (test #(a b) (read (open-input-string "#(a b)")))
+(test #() (read (open-input-string "#()")))
+(test #(a b) (read (open-input-string "#(a b)")))
 
-;; (test #u8() (read (open-input-string "#u8()")))
-;; (test #u8(0 1) (read (open-input-string "#u8(0 1)")))
+(test #u8() (read (open-input-string "#u8()")))
+(test #u8(0 1) (read (open-input-string "#u8(0 1)")))
 
-;; (test 'abc (read (open-input-string "abc")))
-;; (test 'abc (read (open-input-string "abc def")))
-;; (test 'ABC (read (open-input-string "ABC")))
-;; (test 'Hello (read (open-input-string "|H\\x65;llo|")))
+(test 'abc (read (open-input-string "abc")))
+(test 'abc (read (open-input-string "abc def")))
+(test 'ABC (read (open-input-string "ABC")))
+(test 'Hello (read (open-input-string "|H\\x65;llo|")))
 
-;; (test 'abc (read (open-input-string "#!fold-case ABC")))
-;; (test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC")))
+(test 'abc (read (open-input-string "#!fold-case ABC")))
+(test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC")))
 
-;; (test 'def (read (open-input-string "#; abc def")))
-;; (test 'def (read (open-input-string "; abc \ndef")))
-;; (test 'def (read (open-input-string "#| abc |# def")))
-;; (test 'ghi (read (open-input-string "#| abc #| def |# |# ghi")))
-;; (test 'ghi (read (open-input-string "#; ; abc\n def ghi")))
-;; (test '(abs -16) (read (open-input-string "(#;sqrt abs -16)")))
-;; (test '(a d) (read (open-input-string "(a #; #;b c d)")))
-;; (test '(a e) (read (open-input-string "(a #;(b #;c d) e)")))
-;; (test '(a . c) (read (open-input-string "(a . #;b c)")))
-;; (test '(a . b) (read (open-input-string "(a . b #;c)")))
+(test 'def (read (open-input-string "#; abc def")))
+(test 'def (read (open-input-string "; abc \ndef")))
+(test 'def (read (open-input-string "#| abc |# def")))
+(test 'ghi (read (open-input-string "#| abc #| def |# |# ghi")))
+(test 'ghi (read (open-input-string "#; ; abc\n def ghi")))
+(test '(abs -16) (read (open-input-string "(#;sqrt abs -16)")))
+(test '(a d) (read (open-input-string "(a #; #;b c d)")))
+(test '(a e) (read (open-input-string "(a #;(b #;c d) e)")))
+(test '(a . c) (read (open-input-string "(a . #;b c)")))
+(test '(a . b) (read (open-input-string "(a . b #;c)")))
 
 ;; (define (test-read-error str)
 ;;   (test-assert
@@ -2058,7 +2058,7 @@
 ;; (test "line 1\n\nline 3\n" (read (open-input-string "\"line 1\\ \t \n \t \n\nline 3\n\"")))
 ;; (test #x03BB (char->integer (string-ref (read (open-input-string "\"\\x03BB;\"")) 0)))
 
-;; (test-end)
+(test-end)
 
 (test-begin "Numeric syntax")
 

From 4772441589553847a0de58bfe7cdcff57ee8b981 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:02:13 +0900
Subject: [PATCH 035/216] allow "(a . b #;c )"

---
 src/read.c | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/read.c b/src/read.c
index 1dae699f..66b1625f 100644
--- a/src/read.c
+++ b/src/read.c
@@ -361,7 +361,11 @@ read_pair(pic_state *pic, struct pic_port *port, char c)
   if (c == '.' && isdelim(peek(port))) {
     cdr = read(pic, port, next(port));
 
+  closing:
     if ((c = skip(port, ' ')) != tCLOSE) {
+      if (pic_undef_p(read_nullable(pic, port, c))) {
+        goto closing;
+      }
       read_error(pic, "unmatched parenthesis");
     }
     return cdr;

From 5869f13ae0216d2807ba68ba8b3e1299f61beb0c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:02:38 +0900
Subject: [PATCH 036/216] unlock some of environment-variable tests

---
 t/r7rs-tests.scm | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 5836ed26..f1439ff2 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -2226,17 +2226,17 @@
 
 ;; (test "/usr/local/bin:/usr/bin:/bin" (get-environment-variable "PATH"))
 
-;; (test #t (string? (get-environment-variable "PATH")))
+(test #t (string? (get-environment-variable "PATH")))
 
 ;; (test '(("USER" . "root") ("HOME" . "/")) (get-environment-variables))
 
-;; (let ((env (get-environment-variables)))
-;;   (define (env-pair? x)
-;;     (and (pair? x) (string? (car x)) (string? (cdr x))))
-;;   (define (all? pred ls)
-;;     (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls)))))
-;;   (test #t (list? env))
-;;   (test #t (all? env-pair? env)))
+(let ((env (get-environment-variables)))
+  (define (env-pair? x)
+    (and (pair? x) (string? (car x)) (string? (cdr x))))
+  (define (all? pred ls)
+    (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls)))))
+  (test #t (list? env))
+  (test #t (all? env-pair? env)))
 
 (test #t (list? (command-line)))
 

From a7c9537e067d7877c9a744101a113a781ff2f54d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:12:06 +0900
Subject: [PATCH 037/216] unlock more reader tests

---
 t/r7rs-tests.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index f1439ff2..4fc078a1 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -1802,9 +1802,9 @@
       (output-port-open? out)))
 
 (test #t (eof-object? (eof-object)))
-;; (test #t (eof-object? (read (open-input-string ""))))
+(test #t (eof-object? (read (open-input-string ""))))
 (test #t (char-ready? (open-input-string "42")))
-;; (test 42 (read (open-input-string " 42 ")))
+(test 42 (read (open-input-string " 42 ")))
 
 (test #t (eof-object? (read-char (open-input-string ""))))
 (test #\a (read-char (open-input-string "abc")))

From d294330aa56fc47409b95d83ff4fcef3c6654f7b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:13:06 +0900
Subject: [PATCH 038/216] delete trailing whitespaces

---
 t/r7rs-tests.scm | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 4fc078a1..6a101cef 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -310,7 +310,7 @@
 
 (test 3 (force (delay (+ 1 2))))
 
-(test '(3 3)  
+(test '(3 3)
     (let ((p (delay (+ 1 2))))
       (list (force p) (force p))))
 
@@ -328,7 +328,7 @@
 
 (define (stream-filter p? s)
   (delay-force
-   (if (null? (force s)) 
+   (if (null? (force s))
        (delay '())
        (let ((h (car (force s)))
              (t (cdr (force s))))
@@ -390,7 +390,7 @@
 (test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4)))
 
 ;; (define plus
-;;   (case-lambda 
+;;   (case-lambda
 ;;    (() 0)
 ;;    ((x) x)
 ;;    ((x y) (+ x y))
@@ -404,7 +404,7 @@
 ;; (test 10 (plus 1 2 3 4))
 
 ;; (define mult
-;;   (case-lambda 
+;;   (case-lambda
 ;;    (() 1)
 ;;    ((x) x)
 ;;    ((x y) (* x y))
@@ -1017,7 +1017,7 @@
 (test #t (symbol=? 'a 'a 'a))
 (test #f (symbol=? 'a 'a 'A))
 
-(test "flying-fish"     
+(test "flying-fish"
 (symbol->string 'flying-fish))
 (test "Martin" (symbol->string 'Martin))
 (test "Malvina" (symbol->string (string->symbol "Malvina")))
@@ -2168,7 +2168,7 @@
 ;; (test-numeric-syntax "0.5+3/4i" (make-rectangular 0.5 (/ 3 4))
 ;;   "0.5+0.75i" ".5+.75i" "0.5+3/4i" ".5+3/4i" "500.0e-3+750.0e-3i")
 ;; ;; Complex NaN, Inf (rectangular notation)
-;; ;;(test-numeric-syntax "+nan.0+nan.0i" (make-rectangular the-nan the-nan) "+NaN.0+NaN.0i") 
+;; ;;(test-numeric-syntax "+nan.0+nan.0i" (make-rectangular the-nan the-nan) "+NaN.0+NaN.0i")
 ;; (test-numeric-syntax "+inf.0+inf.0i" (make-rectangular +inf.0 +inf.0) "+Inf.0+Inf.0i")
 ;; (test-numeric-syntax "-inf.0+inf.0i" (make-rectangular -inf.0 +inf.0) "-Inf.0+Inf.0i")
 ;; (test-numeric-syntax "-inf.0-inf.0i" (make-rectangular -inf.0 -inf.0) "-Inf.0-Inf.0i")

From 0716ff8a03e0d5774ede76088148217e23861279 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:21:02 +0900
Subject: [PATCH 039/216] unlock a string test

---
 t/r7rs-tests.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 6a101cef..d89afd12 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -1151,7 +1151,7 @@
 ;;       (string-set! s 1 #\x1F700)
 ;;       s))
 
-#;(test #t (string=? "" ""))
+(test #t (string=? "" ""))
 (test #t (string=? "abc" "abc" "abc"))
 (test #f (string=? "" "abc"))
 (test #f (string=? "abc" "aBc"))

From c5400b4b2d6a3cf5cb0e67331aa448c6fa54edb9 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:29:49 +0900
Subject: [PATCH 040/216] support more than 2 argument-comparators

---
 src/codegen.c | 18 +++++++++++++-----
 1 file changed, 13 insertions(+), 5 deletions(-)

diff --git a/src/codegen.c b/src/codegen.c
index d097896f..8dd84b7a 100644
--- a/src/codegen.c
+++ b/src/codegen.c
@@ -690,6 +690,12 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos)
 	}						\
       } while (0)
 
+#define ARGC_ASSERT_WITH_FALLBACK(n) do {               \
+	if (pic_length(pic, obj) != (n) + 1) {		\
+          goto fallback;                                \
+	}						\
+      } while (0)
+
 #define CONSTRUCT_OP1(op)                                               \
       pic_list2(pic,                                                    \
                 pic_symbol_value(op),                                   \
@@ -768,23 +774,23 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
         return analyze_div(state, obj);
       }
       else if (sym == state->rEQ) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sEQ);
       }
       else if (sym == state->rLT) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sLT);
       }
       else if (sym == state->rLE) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sLE);
       }
       else if (sym == state->rGT) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sGT);
       }
       else if (sym == state->rGE) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sGE);
       }
       else if (sym == state->rNOT) {
@@ -798,6 +804,8 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
         return analyze_call_with_values(state, obj, tailpos);
       }
     }
+  fallback:
+
     return analyze_call(state, obj, tailpos);
   }
   case PIC_TT_BOOL:

From 015d0872c9590c0602be519b17ab4d5ee8e69aa4 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:30:10 +0900
Subject: [PATCH 041/216] unlock comparator tests

---
 t/r7rs-tests.scm | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index d89afd12..2bdea07e 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -648,14 +648,14 @@
 
 ;; (test #t (= 1 1.0 1.0+0.0i))
 ;; (test #f (= 1.0 1.0+1.0i))
-;; (test #t (< 1 2 3))
-;; (test #f (< 1 1 2))
-;; (test #t (> 3.0 2.0 1.0))
-;; (test #f (> -3.0 2.0 1.0))
-;; (test #t (<= 1 1 2))
-;; (test #f (<= 1 2 1))
-;; (test #t (>= 2 1 1))
-;; (test #f (>= 1 2 1))
+(test #t (< 1 2 3))
+(test #f (< 1 1 2))
+(test #t (> 3.0 2.0 1.0))
+(test #f (> -3.0 2.0 1.0))
+(test #t (<= 1 1 2))
+(test #f (<= 1 2 1))
+(test #t (>= 2 1 1))
+(test #f (>= 1 2 1))
 
 ;; From R7RS 6.2.6 Numerical operations:
 ;;

From 39b1e6c6bc9d1053cd963101679b2aec18a18161 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:30:19 +0900
Subject: [PATCH 042/216] [bugfix] comparator transitivity broken

---
 src/number.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/number.c b/src/number.c
index 42140260..b8960466 100644
--- a/src/number.c
+++ b/src/number.c
@@ -133,6 +133,7 @@ pic_number_nan_p(pic_state *pic)
       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]))			\

From c44803d2381e77624742082123e42f8734b2875e Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:45:41 +0900
Subject: [PATCH 043/216] [bugfix] using uninitializing variable

---
 src/var.c | 8 ++------
 1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/src/var.c b/src/var.c
index a779ddff..e667966d 100644
--- a/src/var.c
+++ b/src/var.c
@@ -48,10 +48,7 @@ get_var_from_proc(pic_state *pic, struct pic_proc *proc)
 {
   pic_value v;
 
-  if (! pic_proc_p(v)) {
-    goto typeerror;
-  }
-  if (! pic_proc_func_p(pic_proc_ptr(v))) {
+  if (! pic_proc_func_p(proc)) {
     goto typeerror;
   }
   if (pic_proc_cv_size(pic, proc) != 1) {
@@ -64,8 +61,7 @@ get_var_from_proc(pic_state *pic, struct pic_proc *proc)
   return pic_var_ptr(v);
 
  typeerror:
-  pic_error(pic, "expected parameter");
-  UNREACHABLE();
+  pic_errorf(pic, "expected parameter, but got ~s", v);
 }
 
 static pic_value

From 7da5786ef3bf963c2092c1407ab03251636cec2f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:46:04 +0900
Subject: [PATCH 044/216] unlock parameter tests

---
 t/r7rs-tests.scm | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 2bdea07e..c31b3dfa 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -364,18 +364,18 @@
 
 
 
-;; (define radix
-;;   (make-parameter
-;;    10
-;;    (lambda (x)
-;;      (if (and (integer? x) (<= 2 x 16))
-;;          x
-;;          (error "invalid radix")))))
-;; (define (f n) (number->string n (radix)))
-;; (test "12" (f 12))
-;; (test "1100" (parameterize ((radix 2))
-;;                            (f 12)))
-;; (test "12" (f 12))
+(define radix
+  (make-parameter
+   10
+   (lambda (x)
+     (if (and (integer? x) (<= 2 x 16))
+         x
+         (error "invalid radix")))))
+(define (f n) (number->string n (radix)))
+(test "12" (f 12))
+(test "1100" (parameterize ((radix 2))
+                           (f 12)))
+(test "12" (f 12))
 (test '(list 3 4) `(list ,(+ 1 2) 4))
 (let ((name 'a)) (test '(list a (quote a)) `(list ,name ',name)))
 (test '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))

From b2a14ca0f17fd2317a54f2ceb04e4a42874aed8b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 20:58:53 +0900
Subject: [PATCH 045/216] print test statistics at the end of all tests

---
 t/r7rs-tests.scm | 23 ++++++++++++++++++++---
 1 file changed, 20 insertions(+), 3 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index c31b3dfa..845cddde 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -44,11 +44,27 @@
 ;; support, the full numeric tower and all standard libraries
 ;; provided.
 
-(define (test-begin . o) #f)
+(define test-counter 0)
+(define counter 0)
+(define failure-counter 0)
 
-(define (test-end . o) #f)
+(define (print-statistics)
+  (newline)
+  (display "Test Result: ")
+  (write (- counter failure-counter))
+  (display " / ")
+  (write counter)
+  (display " [PASS/TOTAL]")
+  (display "")
+  (newline))
 
-(define counter 1)
+(define (test-begin . o)
+  (set! test-counter (+ test-counter 1)))
+
+(define (test-end . o)
+  (set! test-counter (- test-counter 1))
+  (if (= test-counter 0)
+      (print-statistics)))
 
 (define-syntax test
   (syntax-rules ()
@@ -66,6 +82,7 @@
          (newline)
          )
         ((not (equal? res expected))
+         (set! failure-counter (+ failure-counter 1))
          (display " FAIL: ")
          (write 'expr)
          (newline)

From 5d3c59fc985604f37c577844c197c316b92d8aba Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 21:41:35 +0900
Subject: [PATCH 046/216] reads number as accurate as possible

---
 src/read.c | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/src/read.c b/src/read.c
index 66b1625f..fab3ceaf 100644
--- a/src/read.c
+++ b/src/read.c
@@ -178,14 +178,18 @@ read_uinteger(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_number(pic_state *pic, struct pic_port *port, char c)
 {
-  int64_t i, j;
+  char buf[256], *cur;
+  int64_t i;
 
   i = read_uinteger(pic, port, c);
 
   if (peek(port) == '.') {
-    next(port);
-    j = read_uinteger(pic, port, next(port));
-    return pic_float_value(i + (double)j * pow(10, -snprintf(NULL, 0, "%lld", j)));
+    cur = buf + snprintf(buf, sizeof buf, "%lld", i);
+    do {
+      *cur++ = next(port);
+    } while (isdigit(peek(port)));
+    *cur = '\0';
+    return pic_float_value(atof(buf));
   }
   else {
     return pic_int_value(i);

From 1a1d380a78c5d255ed4600755304181fe4ff9e0c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 21:41:59 +0900
Subject: [PATCH 047/216] [bugfix] bad accuracy of test cases

---
 t/r7rs-tests.scm | 26 +++++++++++++-------------
 1 file changed, 13 insertions(+), 13 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 845cddde..6fc1ae64 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -822,7 +822,7 @@
 ;; (test #i1/3 (rationalize .3 1/10))
 
 (test 1.0 (inexact (exp 0))) ;; may return exact number
-(test 20.0855369231877 (exp 3))
+(test 20.0855369231876679236 (exp 3))
 
 (test 0.0 (inexact (log 1))) ;; may return exact number
 (test 1.0 (log (exp 1)))
@@ -835,30 +835,30 @@
 (test 1.0 (inexact (cos 0))) ;; may return exact number
 (test -1.0 (cos 3.14159265358979))
 (test 0.0 (inexact (tan 0))) ;; may return exact number
-(test 1.5574077246549 (tan 1))
+(test 1.5574077246549020703 (tan 1))
 
 (test 0.0 (asin 0))
-(test 1.5707963267949 (asin 1))
+(test 1.5707963267948965580 (asin 1))
 (test 0.0 (acos 1))
-(test 3.14159265358979 (acos -1))
+(test 3.1415926535897931160 (acos -1))
 
 (test 0.0 (atan 0.0 1.0))
 (test -0.0 (atan -0.0 1.0))
-(test 0.785398163397448 (atan 1.0 1.0))
-(test 1.5707963267949 (atan 1.0 0.0))
-(test 2.35619449019234 (atan 1.0 -1.0))
-(test 3.14159265358979 (atan 0.0 -1.0))
-(test -3.14159265358979 (atan -0.0 -1.0)) ;
-(test -2.35619449019234 (atan -1.0 -1.0))
-(test -1.5707963267949 (atan -1.0 0.0))
-(test -0.785398163397448 (atan -1.0 1.0))
+(test 0.7853981633974482790 (atan 1.0 1.0))
+(test 1.5707963267948965580 (atan 1.0 0.0))
+(test 2.3561944901923448370 (atan 1.0 -1.0))
+(test 3.1415926535897931160 (atan 0.0 -1.0))
+(test -3.1415926535897931160 (atan -0.0 -1.0)) ;
+(test -2.3561944901923448370 (atan -1.0 -1.0))
+(test -1.5707963267948965580 (atan -1.0 0.0))
+(test -0.7853981633974482790 (atan -1.0 1.0))
 ;; (test undefined (atan 0.0 0.0))
 
 (test 1764 (square 42))
 (test 4 (square 2))
 
 (test 3.0 (inexact (sqrt 9)))
-(test 1.4142135623731 (sqrt 2))
+(test 1.4142135623730951454 (sqrt 2))
 ;; (test 0.0+1.0i (inexact (sqrt -1)))
 
 (test '(2 0) (call-with-values (lambda () (exact-integer-sqrt 4)) list))

From 76220e1e8ed67df58c3987554ccf853688e29a0a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 21:43:44 +0900
Subject: [PATCH 048/216] infinity is not rational

---
 src/number.c | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/number.c b/src/number.c
index b8960466..c0a1e7ec 100644
--- a/src/number.c
+++ b/src/number.c
@@ -50,6 +50,10 @@ pic_number_integer_p(pic_state *pic)
   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();
     }

From 4fd99b5955a7b367ee5170a3899a5ae05baf99d6 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 21:53:14 +0900
Subject: [PATCH 049/216] [bugfix] return value from pic_get_args does not
 include proc object

---
 src/string.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/string.c b/src/string.c
index e9a0095b..6015688c 100644
--- a/src/string.c
+++ b/src/string.c
@@ -386,9 +386,9 @@ pic_str_string_fill_ip(pic_state *pic)
   n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end);
 
   switch (n) {
-  case 1:
-    start = 0;
   case 2:
+    start = 0;
+  case 3:
     end = pic_strlen(str);
   }
 

From 2d594064035ed6143b2d328abe2f7008326bfec1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 21:54:07 +0900
Subject: [PATCH 050/216] improve test value accuracy

---
 t/r7rs-tests.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 6fc1ae64..59903db3 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -257,7 +257,7 @@
             (mean / /))))
 (let*-values (((a b c) (means '(8 5 99 1 22))))
   (test 27 a)
-  (test 9.728 b)
+  (test 9.7280002558226410514 b)
   (test (/ 1800 497) c))
 
 (let*-values (((root rem) (exact-integer-sqrt 32)))

From 2615ce11bd02bf4495acd5c2a017ceaa621b8ed3 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 21:54:19 +0900
Subject: [PATCH 051/216] unlock string-fill! tests

---
 t/r7rs-tests.scm | 40 ++++++++++++++++++++--------------------
 1 file changed, 20 insertions(+), 20 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 59903db3..ec97e20c 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -1292,29 +1292,29 @@
 (test "b" (string-copy "abc" 1 2))
 (test "bc" (string-copy "abc" 1 3))
 
-;; (test "-----"
-;;     (let ((str (make-string 5 #\x))) (string-fill! str #\-) str))
-;; (test "xx---"
-;;     (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str))
-;; (test "xx-xx"
-;;     (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str))
+(test "-----"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\-) str))
+(test "xx---"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str))
+(test "xx-xx"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str))
 
-;; (test "a12de"
-;;     (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str))
-;; (test "-----"
-;;     (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str))
-;; (test "---xx"
-;;     (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str))
-;; (test "xx---"
-;;     (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str))
-;; (test "xx-xx"
-;;     (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str))
+(test "a12de"
+    (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str))
+(test "-----"
+    (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str))
+(test "---xx"
+    (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str))
+(test "xx---"
+    (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str))
+(test "xx-xx"
+    (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str))
 
 ;; same source and dest
-;; (test "aabde"
-;;     (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str))
-;; (test "abcab"
-;;     (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str))
+(test "aabde"
+    (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str))
+(test "abcab"
+    (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str))
 
 (test-end)
 

From 5c3e5b116ec56c23f9649fe6731769b88149696e Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 22:02:09 +0900
Subject: [PATCH 052/216] show success rate in statistics

---
 t/r7rs-tests.scm | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index ec97e20c..362247eb 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -54,6 +54,9 @@
   (write (- counter failure-counter))
   (display " / ")
   (write counter)
+  (display " (")
+  (write (* (/ (- counter failure-counter) counter) 100))
+  (display "%)")
   (display " [PASS/TOTAL]")
   (display "")
   (newline))

From 690e2cdba67e1781c7a589c7c4faf9596f6e0702 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 28 Jun 2014 22:32:26 +0900
Subject: [PATCH 053/216] refactor number parser

---
 src/read.c | 46 ++++++++++++++++++++++------------------------
 1 file changed, 22 insertions(+), 24 deletions(-)

diff --git a/src/read.c b/src/read.c
index fab3ceaf..0cf4cdaa 100644
--- a/src/read.c
+++ b/src/read.c
@@ -155,46 +155,43 @@ read_symbol(pic_state *pic, struct pic_port *port, char c)
   return pic_sym_value(sym);
 }
 
-static int64_t
-read_uinteger(pic_state *pic, struct pic_port *port, char c)
+static size_t
+read_uinteger(pic_state *pic, struct pic_port *port, char c, char buf[])
 {
-  int64_t n;
-
-  c = skip(port, c);
+  size_t i = 0;
 
   if (! isdigit(c)) {
     read_error(pic, "expected one or more digits");
   }
 
-  n = c - '0';
+  buf[i++] = c;
   while (isdigit(c = peek(port))) {
-    next(port);
-    n = n * 10 + c - '0';
+    buf[i++] = next(port);
   }
 
-  return n;
+  buf[i] = '\0';
+
+  return i;
 }
 
 static pic_value
 read_number(pic_state *pic, struct pic_port *port, char c)
 {
-  char buf[256], *cur;
-  int64_t i;
+  char buf[256];
+  size_t i;
 
-  i = read_uinteger(pic, port, c);
+  i = read_uinteger(pic, port, c, buf);
 
   if (peek(port) == '.') {
-    cur = buf + snprintf(buf, sizeof buf, "%lld", i);
     do {
-      *cur++ = next(port);
+      buf[i++] = next(port);
     } while (isdigit(peek(port)));
-    *cur = '\0';
+    buf[i] = '\0';
     return pic_float_value(atof(buf));
   }
   else {
-    return pic_int_value(i);
+    return pic_int_value(atoi(buf));
   }
-
 }
 
 static pic_value
@@ -313,7 +310,7 @@ read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
 {
   int nbits, n;
   size_t len;
-  char *buf;
+  char *dat, buf[256];
   pic_blob *blob;
 
   nbits = 0;
@@ -331,21 +328,22 @@ read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
   }
 
   len = 0;
-  buf = NULL;
+  dat = NULL;
   c = next(port);
   while ((c = skip(port, c)) != ')') {
-    n = read_uinteger(pic, port, c);
+    read_uinteger(pic, port, c, buf);
+    n = atoi(buf);
     if (n < 0 || (1 << nbits) <= n) {
       read_error(pic, "invalid element in bytevector literal");
     }
     len += 1;
-    buf = pic_realloc(pic, buf, len);
-    buf[len - 1] = n;
+    dat = pic_realloc(pic, dat, len);
+    dat[len - 1] = n;
     c = next(port);
   }
 
-  blob = pic_blob_new(pic, buf, len);
-  pic_free(pic, buf);
+  blob = pic_blob_new(pic, dat, len);
+  pic_free(pic, dat);
   return pic_obj_value(blob);
 }
 

From 89506d0ced16902ef5aca7b3d6e90a7b987b824e Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 00:54:20 +0900
Subject: [PATCH 054/216] [bugfix] allocate size was inefficient

---
 src/read.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index 0cf4cdaa..47321029 100644
--- a/src/read.c
+++ b/src/read.c
@@ -144,7 +144,7 @@ read_symbol(pic_state *pic, struct pic_port *port, char c)
       c = next(port);
     }
     len += 1;
-    buf = pic_realloc(pic, buf, len);
+    buf = pic_realloc(pic, buf, len + 1);
     buf[len - 1] = c;
   } while (! isdelim(peek(port)));
 

From fdbd7bd2c9ccd988ef014fb60fd553d5594455e6 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 01:06:07 +0900
Subject: [PATCH 055/216] [bugfix] glibc's getenv function does not igrore
 trailing '='

---
 src/system.c | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/system.c b/src/system.c
index efd53f48..73b27262 100644
--- a/src/system.c
+++ b/src/system.c
@@ -104,17 +104,17 @@ pic_system_getenvs(pic_state *pic)
   }
 
   for (envp = pic->envp; *envp; ++envp) {
-    pic_value key, val;
+    pic_str *key, *val;
     int i;
 
     for (i = 0; (*envp)[i] != '='; ++i)
       ;
 
-    key = pic_obj_value(pic_str_new(pic, *envp, i));
-    val = pic_obj_value(pic_str_new_cstr(pic, getenv(*envp)));
+    key = pic_str_new(pic, *envp, i);
+    val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key)));
 
     /* push */
-    data = pic_acons(pic, key, val, data);
+    data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);
 
     pic_gc_arena_restore(pic, ai);
     pic_gc_protect(pic, data);

From 85d513abe66abcc6dae26cecc4f22dc878d7d4a5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 01:23:21 +0900
Subject: [PATCH 056/216] remove "2> /dev/null" from make test command line

---
 CMakeLists.txt | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/CMakeLists.txt b/CMakeLists.txt
index 530e568a..12347110 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -43,7 +43,7 @@ add_custom_target(run bin/picrin DEPENDS repl)
 add_custom_target(test DEPENDS no-act test-r7rs)
 
 # $ make no-act
-add_custom_target(no-act bin/picrin -e '' > /dev/null 2> /dev/null DEPENDS repl)
+add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl)
 
 # $ make test-r7rs
 add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl)

From 5e12794467cab988038fcbd75d371d44c76b91ec Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 01:29:09 +0900
Subject: [PATCH 057/216] sort contrib libraries before include them

---
 contrib/CMakeLists.txt | 1 +
 1 file changed, 1 insertion(+)

diff --git a/contrib/CMakeLists.txt b/contrib/CMakeLists.txt
index 2a25b8b8..2487f0d0 100644
--- a/contrib/CMakeLists.txt
+++ b/contrib/CMakeLists.txt
@@ -1,4 +1,5 @@
 file(GLOB CONTRIBS ${PROJECT_SOURCE_DIR}/contrib/*/CMakeLists.txt)
+list(SORT CONTRIBS)
 foreach(contrib ${CONTRIBS})
   include(${contrib})
 endforeach()

From 8d9b7e9bf35b0c78ff8d1c4e492effbad845bdcc Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Sun, 29 Jun 2014 13:46:46 +0900
Subject: [PATCH 058/216] ensure flush contents into the port made in
 `open-input-bytevector`

---
 src/port.c | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/port.c b/src/port.c
index 168b5cce..2da85177 100644
--- a/src/port.c
+++ b/src/port.c
@@ -329,6 +329,8 @@ pic_port_open_input_blob(pic_state *pic)
   port->status = PIC_PORT_OPEN;
 
   xfwrite(blob->data, 1, blob->len, port->file);
+  xfflush(port->file);
+  xrewind(port->file);
 
   return pic_obj_value(port);
 }

From a6ac56d311489e426b6e420a28b006d507ece75c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 13:58:21 +0900
Subject: [PATCH 059/216] rewrite `include` macro with scheme

---
 docs/lang.rst       |  2 +-
 piclib/built-in.scm | 25 +++++++++++++++++++++++++
 src/macro.c         | 35 -----------------------------------
 3 files changed, 26 insertions(+), 36 deletions(-)

diff --git a/docs/lang.rst b/docs/lang.rst
index fe0e60f7..9e787548 100644
--- a/docs/lang.rst
+++ b/docs/lang.rst
@@ -38,7 +38,7 @@ section                                          status     comments
 4.1.4 Procedures                                 yes
 4.1.5 Conditionals                               yes        In picrin ``(if #f #f)`` returns ``#f``
 4.1.6 Assignments                                yes
-4.1.7 Inclusion                                  incomplete ``include-ci``. TODO: Once ``read`` is implemented rewrite ``include`` macro with it.
+4.1.7 Inclusion                                  incomplete ``include-ci``
 4.2.1 Conditionals                               incomplete TODO: ``cond-expand``
 4.2.2 Binding constructs                         yes
 4.2.3 Sequencing                                 yes
diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index ca2271fa..a58e0aa8 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -907,6 +907,31 @@
 
 (export call-with-port)
 
+;;; include syntax
+
+(import (scheme read)
+        (scheme file))
+
+(define (call-with-input-file filename callback)
+  (call-with-port (open-input-file filename) callback))
+
+(define (read-many filename)
+  (call-with-input-file filename
+    (lambda (port)
+      (let loop ((expr (read port)) (exprs '()))
+        (if (eof-object? expr)
+            (reverse exprs)
+            (loop (read port) (cons expr exprs)))))))
+
+(define-syntax include
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (let ((filenames (cdr form)))
+       (let ((exprs (apply append (map read-many filenames))))
+         `(,(rename 'begin) ,@exprs))))))
+
+(export include)
+
 ;;; Appendix A. Standard Libraries Lazy
 (define-library (scheme lazy)
   (import (scheme base)
diff --git a/src/macro.c b/src/macro.c
index 7783c0e4..1a0ed192 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -599,39 +599,6 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   return v;
 }
 
-/* once read.c is implemented move there */
-static pic_value
-pic_macro_include(pic_state *pic)
-{
-  size_t argc, i;
-  pic_value *argv, exprs, body;
-  FILE *file;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  /* FIXME unhygienic */
-  body = pic_list1(pic, pic_sym_value(pic->sBEGIN));
-
-  for (i = 0; i < argc; ++i) {
-    const char *filename;
-    if (! pic_str_p(argv[i])) {
-      pic_error(pic, "expected string");
-    }
-    filename = pic_str_cstr(pic_str_ptr(argv[i]));
-    file = fopen(filename, "r");
-    if (file == NULL) {
-      pic_error(pic, "could not open file");
-    }
-    exprs = pic_parse_file(pic, file);
-    if (pic_undef_p(exprs)) {
-      pic_error(pic, "parse error");
-    }
-    body = pic_append(pic, body, exprs);
-  }
-
-  return body;
-}
-
 static pic_value
 pic_macro_gensym(pic_state *pic)
 {
@@ -958,8 +925,6 @@ pic_macro_ir_macro_transformer(pic_state *pic)
 void
 pic_init_macro(pic_state *pic)
 {
-  pic_defmacro(pic, "include", pic_proc_new(pic, pic_macro_include, "<include-procedure>"));
-
   pic_deflibrary ("(picrin macro)") {
 
     /* export define-macro syntax */

From 2af2362b4fdddc71d5819d3e90c376dba4fa810e Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 15:07:52 +0900
Subject: [PATCH 060/216] support `(define-values (x y . z) ...)`

---
 piclib/built-in.scm | 73 ++++++++++++++++++++++++++++++++++-----------
 1 file changed, 56 insertions(+), 17 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index a58e0aa8..3f6eb5a7 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -343,24 +343,63 @@
      (lambda (form r c)
        `(,(r 'let*-values) ,@(cdr form)))))
 
+  (define (vector-map proc vect)
+    (do ((i 0 (+ i 1))
+         (u (make-vector (vector-length vect))))
+        ((= i (vector-length vect))
+         u)
+      (vector-set! u i (proc (vector-ref vect i)))))
+
+  (define (walk proc expr)
+    (cond
+     ((null? expr)
+      '())
+     ((pair? expr)
+      (cons (proc (car expr))
+            (walk proc (cdr expr))))
+     ((vector? expr)
+      (vector-map proc expr))
+     (else
+      (proc expr))))
+
+  (define (flatten expr)
+    (let ((list '()))
+      (walk
+       (lambda (x)
+         (set! list (cons x list)))
+       expr)
+      (reverse list)))
+
+  (define (predefine var)
+    `(define ,var #f))
+
+  (define (predefines vars)
+    (map predefine vars))
+
+  (define (assign var val)
+    `(set! ,var ,val))
+
+  (define (assigns vars vals)
+    (map assign vars vals))
+
+  (define uniq
+    (let ((counter 0))
+      (lambda (x)
+        (let ((sym (string->symbol (string-append "var$" (number->string counter)))))
+          (set! counter (+ counter 1))
+          sym))))
+
   (define-syntax define-values
-    (er-macro-transformer
-     (lambda (form r c)
-       (let ((formals (cadr form)))
-         `(,(r 'begin)
-            ,@(do ((vars formals (cdr vars))
-                   (defs '()))
-                  ((null? vars)
-                   defs)
-                (set! defs (cons `(,(r 'define) ,(car vars) #f) defs)))
-            (,(r 'call-with-values)
-                (,(r 'lambda) () ,@(cddr form))
-              (,(r 'lambda) (,@(map r formals))
-                ,@(do ((vars formals (cdr vars))
-                       (assn '()))
-                      ((null? vars)
-                       assn)
-                    (set! assn (cons `(,(r 'set!) ,(car vars) ,(r (car vars))) assn))))))))))
+    (ir-macro-transformer
+     (lambda (form inject compare)
+       (let* ((formal  (cadr form))
+              (formal* (walk uniq formal))
+              (exprs   (cddr form)))
+         `(begin
+            ,@(predefines (flatten formal))
+            (call-with-values (lambda () ,@exprs)
+              (lambda ,formal*
+                ,@(assigns (flatten formal) (flatten formal*)))))))))
 
   (export let-values
           let*-values

From 3c26c289f343b829be6694e44f87571aad1819f5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 15:08:04 +0900
Subject: [PATCH 061/216] unlock define-values tests

---
 t/r7rs-tests.scm | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 362247eb..da0a1cbb 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -520,10 +520,10 @@
     (let ()
       (define-values (x) (values 1))
       x))
-;; (test 3
-;;     (let ()
-;;       (define-values x (values 1 2))
-;;       (apply + x)))
+(test 3
+    (let ()
+      (define-values x (values 1 2))
+      (apply + x)))
 (test 3
     (let ()
       (define-values (x y) (values 1 2))
@@ -532,10 +532,10 @@
     (let ()
       (define-values (x y z) (values 1 2 3))
       (+ x y z)))
-;; (test 10
-;;     (let ()
-;;       (define-values (x y . z) (values 1 2 3 4))
-;;       (+ x y (car z) (cadr z))))
+(test 10
+    (let ()
+      (define-values (x y . z) (values 1 2 3 4))
+      (+ x y (car z) (cadr z))))
 
 (test '(2 1) (let ((x 1) (y 2))
   (define-syntax swap!

From 69c0e702c63b255b5959f7ce2754fa91aaf84a9b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 16:22:22 +0900
Subject: [PATCH 062/216] remove useless fflush

---
 src/error.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/error.c b/src/error.c
index f4b96675..773b5d2c 100644
--- a/src/error.c
+++ b/src/error.c
@@ -17,7 +17,6 @@ pic_abort(pic_state *pic, const char *msg)
   UNUSED(pic);
 
   fprintf(stderr, "abort: %s\n", msg);
-  fflush(stderr);
   abort();
 }
 

From 1402a973544011d70dcf48bf8b61376dc3719469 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 4 Jul 2014 13:32:45 +0900
Subject: [PATCH 063/216] change pic_throw API

---
 include/picrin/error.h |  3 ++-
 src/error.c            | 28 +++++++++++++++++++++-------
 src/macro.c            |  2 +-
 3 files changed, 24 insertions(+), 9 deletions(-)

diff --git a/include/picrin/error.h b/include/picrin/error.h
index 024d5d29..75361c1a 100644
--- a/include/picrin/error.h
+++ b/include/picrin/error.h
@@ -32,7 +32,8 @@ struct pic_jmpbuf {
 void pic_push_try(pic_state *);
 void pic_pop_try(pic_state *);
 
-noreturn void pic_throw(pic_state *, struct pic_error *);
+noreturn void pic_throw(pic_state *, short, const char *, pic_value);
+noreturn void pic_throw_error(pic_state *, struct pic_error *);
 
 struct pic_error {
   PIC_OBJECT_HEADER
diff --git a/src/error.c b/src/error.c
index 773b5d2c..21f6d487 100644
--- a/src/error.c
+++ b/src/error.c
@@ -87,7 +87,7 @@ error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs)
 }
 
 noreturn void
-pic_throw(pic_state *pic, struct pic_error *e)
+pic_throw_error(pic_state *pic, struct pic_error *e)
 {
   pic->err = e;
   if (! pic->jmp) {
@@ -97,6 +97,16 @@ pic_throw(pic_state *pic, struct pic_error *e)
   longjmp(*pic->jmp, 1);
 }
 
+noreturn void
+pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs)
+{
+  struct pic_error *e;
+
+  e = error_new(pic, type, pic_str_new_cstr(pic, msg), irrs);
+
+  pic_throw_error(pic, e);
+}
+
 const char *
 pic_errmsg(pic_state *pic)
 {
@@ -109,13 +119,17 @@ void
 pic_errorf(pic_state *pic, const char *fmt, ...)
 {
   va_list ap;
-  pic_value err_line;
+  pic_value err_line, irrs;
+  const char *msg;
 
   va_start(ap, fmt);
   err_line = pic_vformat(pic, fmt, ap);
   va_end(ap);
 
-  pic_throw(pic, error_new(pic, PIC_ERROR_OTHER, pic_str_ptr(pic_car(pic, err_line)), pic_cdr(pic, err_line)));
+  msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)));
+  irrs = pic_cdr(pic, err_line);
+
+  pic_throw(pic, PIC_ERROR_OTHER, msg, irrs);
 }
 
 static pic_value
@@ -146,19 +160,19 @@ pic_error_raise(pic_state *pic)
 
   pic_get_args(pic, "o", &v);
 
-  pic_throw(pic, error_new(pic, PIC_ERROR_RAISED, pic_str_new_cstr(pic, "object is raised"), pic_list1(pic, v)));
+  pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v));
 }
 
 noreturn static pic_value
 pic_error_error(pic_state *pic)
 {
-  pic_str *str;
+  const char *str;
   size_t argc;
   pic_value *argv;
 
-  pic_get_args(pic, "s*", &str, &argc, &argv);
+  pic_get_args(pic, "z*", &str, &argc, &argv);
 
-  pic_throw(pic, error_new(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv)));
+  pic_throw(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv));
 }
 
 static pic_value
diff --git a/src/macro.c b/src/macro.c
index 1a0ed192..ea200e7d 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -246,7 +246,7 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr)
   pic_catch {
     /* restores pic->lib even if an error occurs */
     pic_in_library(pic, prev->name);
-    pic_throw(pic, pic->err);
+    pic_throw_error(pic, pic->err);
   }
 
   return pic_none_value();

From d810e426668dac933608fcc3bb4a6f79ce7e0002 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 4 Jul 2014 13:32:54 +0900
Subject: [PATCH 064/216] throw READ_ERROR when parser raised

---
 src/read.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index 47321029..5ea58f4a 100644
--- a/src/read.c
+++ b/src/read.c
@@ -20,7 +20,7 @@ static pic_value read_nullable(pic_state *pic, struct pic_port *port, char c);
 static noreturn void
 read_error(pic_state *pic, const char *msg)
 {
-  pic_error(pic, msg);
+  pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value());
 }
 
 static char

From 6614f8fc4f964d36a05921d64c579e5e2c58a99d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 4 Jul 2014 13:44:30 +0900
Subject: [PATCH 065/216] support #true and #false literals

---
 src/read.c | 28 +++++++++++++++++++++++++++-
 1 file changed, 27 insertions(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index 5ea58f4a..7c995499 100644
--- a/src/read.c
+++ b/src/read.c
@@ -48,6 +48,19 @@ peek(struct pic_port *port)
   return c;
 }
 
+static bool
+expect(struct pic_port *port, const char *str)
+{
+  char c;
+
+  while ((c = *str++) != 0) {
+    if (c != next(port))
+      return false;
+  }
+
+  return true;
+}
+
 static bool
 isdelim(char c)
 {
@@ -250,13 +263,26 @@ read_boolean(pic_state *pic, struct pic_port *port, char c)
   UNUSED(pic);
   UNUSED(port);
 
-  /* TODO: support #true and #false */
+  if (! isdelim(peek(port))) {
+    if (c == 't') {
+      if (! expect(port, "rue")) {
+        goto fail;
+      }
+    } else {
+      if (! expect(port, "alse")) {
+        goto fail;
+      }
+    }
+  }
 
   if (c == 't') {
     return pic_true_value();
   } else {
     return pic_false_value();
   }
+
+ fail:
+  read_error(pic, "illegal character during reading boolean literal");
 }
 
 static pic_value

From 351d7948c07c20c24a31ebd30be46b731e655b29 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Mon, 7 Jul 2014 04:16:40 +0900
Subject: [PATCH 066/216] fix bug of `{bytevector, vector}-copy!` with the same
 src and dst

---
 piclib/built-in.scm | 42 +++++++++++++++++++++++++++---------------
 1 file changed, 27 insertions(+), 15 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 3f6eb5a7..c57aef21 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -777,14 +777,20 @@
   (apply vector list))
 
 (define (vector-copy! to at from . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (vector-length from))))
-    (do ((i at (+ i 1))
-	 (j start (+ j 1)))
-	((= j end))
-      (vector-set! to i (vector-ref from j)))))
+  (let* ((start (if (pair? opts) (car opts) 0))
+         (end (if (>= (length opts) 2)
+                  (cadr opts)
+                  (vector-length from)))
+         (vs #f))
+    (if (eq? from to)
+        (begin
+          (set! vs (make-vector (- end start)))
+          (vector-copy! vs 0 from start end)
+          (vector-copy! to at vs))
+        (do ((i at (+ i 1))
+             (j start (+ j 1)))
+            ((= j end))
+          (vector-set! to i (vector-ref from j))))))
 
 (define (vector-copy v . opts)
   (let ((start (if (pair? opts) (car opts) 0))
@@ -836,14 +842,20 @@
 	(bytevector-u8-set! v i (car l))))))
 
 (define (bytevector-copy! to at from . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
+  (let* ((start (if (pair? opts) (car opts) 0))
+         (end (if (>= (length opts) 2)
 		 (cadr opts)
-		 (bytevector-length from))))
-    (do ((i at (+ i 1))
-	 (j start (+ j 1)))
-	((= j end))
-      (bytevector-u8-set! to i (bytevector-u8-ref from j)))))
+		 (bytevector-length from)))
+         (vs #f))
+    (if (eq? from to)
+        (begin
+          (set! vs (make-bytevector (- end start)))
+          (bytevector-copy! vs 0 from start end)
+          (bytevector-copy! to at vs))
+        (do ((i at (+ i 1))
+             (j start (+ j 1)))
+            ((= j end))
+          (bytevector-u8-set! to i (bytevector-u8-ref from j))))))
 
 (define (bytevector-copy v . opts)
   (let ((start (if (pair? opts) (car opts) 0))

From 7aa17f5d1f7d347f0e1ab276d11bed8b6807b6fa Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 11 Jul 2014 22:44:44 +0900
Subject: [PATCH 067/216] read rational '123/456' literal

---
 src/read.c | 14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

diff --git a/src/read.c b/src/read.c
index 7c995499..3979755c 100644
--- a/src/read.c
+++ b/src/read.c
@@ -192,17 +192,25 @@ read_number(pic_state *pic, struct pic_port *port, char c)
 {
   char buf[256];
   size_t i;
+  long n;
 
   i = read_uinteger(pic, port, c, buf);
 
-  if (peek(port) == '.') {
+  switch (peek(port)) {
+  case '.':
     do {
       buf[i++] = next(port);
     } while (isdigit(peek(port)));
     buf[i] = '\0';
     return pic_float_value(atof(buf));
-  }
-  else {
+
+  case '/':
+    n = atoi(buf);
+    next(port);
+    read_uinteger(pic, port, next(port), buf);
+    return pic_float_value(n / (double)atoi(buf));
+
+  default:
     return pic_int_value(atoi(buf));
   }
 }

From 03bffef7488358cf0002855cd3409b0dbc853ae5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 12 Jul 2014 00:03:09 +0900
Subject: [PATCH 068/216] 'make tak' broken

---
 CMakeLists.txt | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/CMakeLists.txt b/CMakeLists.txt
index 12347110..c9311e1b 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -49,7 +49,7 @@ add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl)
 add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl)
 
 # $ make tak
-add_custom_target(tak bin/picrin etc/tak.scm DEPENDS repl)
+add_custom_target(tak bin/picrin ${PROJECT_SOURCE_DIR}/etc/tak.scm DEPENDS repl)
 
 # $ make lines
 add_custom_target(lines find . -name "*.[chyl]" | xargs wc -l WORKING_DIRECTORY ${PROJECT_SOURCE_DIR})

From 82de3cfe2f92f0a3dfc91e7085940e19871acff2 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 10:58:13 +0900
Subject: [PATCH 069/216] add pic_dict_new

---
 include/picrin/dict.h |  2 ++
 src/dict.c            | 15 ++++++++++++---
 2 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/include/picrin/dict.h b/include/picrin/dict.h
index bb720534..7d969818 100644
--- a/include/picrin/dict.h
+++ b/include/picrin/dict.h
@@ -17,6 +17,8 @@ struct pic_dict {
 #define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT)
 #define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v))
 
+struct pic_dict *pic_dict_new(pic_state *);
+
 #if defined(__cplusplus)
 }
 #endif
diff --git a/src/dict.c b/src/dict.c
index ddbe2cb5..9789f117 100644
--- a/src/dict.c
+++ b/src/dict.c
@@ -5,6 +5,17 @@
 #include "picrin.h"
 #include "picrin/dict.h"
 
+struct pic_dict *
+pic_dict_new(pic_state *pic)
+{
+  struct pic_dict *dict;
+
+  dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
+  xh_init_int(&dict->hash, sizeof(pic_value));
+
+  return dict;
+}
+
 static pic_value
 pic_dict_dict(pic_state *pic)
 {
@@ -12,9 +23,7 @@ pic_dict_dict(pic_state *pic)
 
   pic_get_args(pic, "");
 
-  dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
-
-  xh_init_int(&dict->hash, sizeof(pic_value));
+  dict = pic_dict_new(pic);
 
   return pic_obj_value(dict);
 }

From 56ae4de82643c0d4c7d48c0665a806b6ca7ffa3f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 10:58:21 +0900
Subject: [PATCH 070/216] add attribute information to closure objects

---
 include/picrin/proc.h |  3 +++
 src/gc.c              |  3 +++
 src/proc.c            | 12 ++++++++++++
 3 files changed, 18 insertions(+)

diff --git a/include/picrin/proc.h b/include/picrin/proc.h
index d96fb6c3..039a4384 100644
--- a/include/picrin/proc.h
+++ b/include/picrin/proc.h
@@ -31,6 +31,7 @@ struct pic_proc {
     struct pic_irep *irep;
   } u;
   struct pic_env *env;
+  struct pic_dict *attr;
 };
 
 #define PIC_PROC_KIND_FUNC 1
@@ -50,6 +51,8 @@ struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_en
 
 pic_sym pic_proc_name(struct pic_proc *);
 
+struct pic_dict *pic_proc_attr(pic_state *, struct pic_proc *);
+
 /* closed variables accessor */
 void pic_proc_cv_init(pic_state *, struct pic_proc *, size_t);
 int pic_proc_cv_size(pic_state *, struct pic_proc *);
diff --git a/src/gc.c b/src/gc.c
index efbd98f5..ea3c35b3 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -381,6 +381,9 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     if (proc->env) {
       gc_mark_object(pic, (struct pic_object *)proc->env);
     }
+    if (proc->attr) {
+      gc_mark_object(pic, (struct pic_object *)proc->attr);
+    }
     if (pic_proc_irep_p(proc)) {
       gc_mark_object(pic, (struct pic_object *)proc->u.irep);
     }
diff --git a/src/proc.c b/src/proc.c
index d4c73d7a..0fec6ac3 100644
--- a/src/proc.c
+++ b/src/proc.c
@@ -6,6 +6,7 @@
 #include "picrin/pair.h"
 #include "picrin/proc.h"
 #include "picrin/irep.h"
+#include "picrin/dict.h"
 
 struct pic_proc *
 pic_proc_new(pic_state *pic, pic_func_t func, const char *name)
@@ -19,6 +20,7 @@ pic_proc_new(pic_state *pic, pic_func_t func, const char *name)
   proc->u.func.f = func;
   proc->u.func.name = pic_intern_cstr(pic, name);
   proc->env = NULL;
+  proc->attr = NULL;
   return proc;
 }
 
@@ -31,6 +33,7 @@ pic_proc_new_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
   proc->kind = PIC_PROC_KIND_IREP;
   proc->u.irep = irep;
   proc->env = env;
+  proc->attr = NULL;
   return proc;
 }
 
@@ -46,6 +49,15 @@ pic_proc_name(struct pic_proc *proc)
   UNREACHABLE();
 }
 
+struct pic_dict *
+pic_proc_attr(pic_state *pic, struct pic_proc *proc)
+{
+  if (proc->attr == NULL) {
+    proc->attr = pic_dict_new(pic);
+  }
+  return proc->attr;
+}
+
 void
 pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size)
 {

From 378f01fa03be80fd8c2e1ca55cfafade5bda72ab Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 11:01:23 +0900
Subject: [PATCH 071/216] add attribute function

---
 src/proc.c | 14 ++++++++++++++
 1 file changed, 14 insertions(+)

diff --git a/src/proc.c b/src/proc.c
index 0fec6ac3..cfb9bcbb 100644
--- a/src/proc.c
+++ b/src/proc.c
@@ -218,6 +218,16 @@ pic_proc_for_each(pic_state *pic)
   return pic_none_value();
 }
 
+static pic_value
+pic_proc_attribute(pic_state *pic)
+{
+  struct pic_proc *proc;
+
+  pic_get_args(pic, "l", &proc);
+
+  return pic_obj_value(pic_proc_attr(pic, proc));
+}
+
 void
 pic_init_proc(pic_state *pic)
 {
@@ -225,4 +235,8 @@ pic_init_proc(pic_state *pic)
   pic_defun(pic, "apply", pic_proc_apply);
   pic_defun(pic, "map", pic_proc_map);
   pic_defun(pic, "for-each", pic_proc_for_each);
+
+  pic_deflibrary ("(picrin attribute)") {
+    pic_defun(pic, "attribute", pic_proc_attribute);
+  }
 }

From fce57ec8c9336415bd163c0b55dba66b2bf8d72b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 12 Jul 2014 14:41:56 +0900
Subject: [PATCH 072/216] remove get_var_from_proc (essentially the same as
 pic_unwrap_var)

---
 src/var.c | 44 +++++++++++++++++++-------------------------
 1 file changed, 19 insertions(+), 25 deletions(-)

diff --git a/src/var.c b/src/var.c
index e667966d..16f29064 100644
--- a/src/var.c
+++ b/src/var.c
@@ -43,27 +43,6 @@ pic_var_set_force(pic_state *pic, struct pic_var *var, pic_value value)
   var->value = value;
 }
 
-static struct pic_var *
-get_var_from_proc(pic_state *pic, struct pic_proc *proc)
-{
-  pic_value v;
-
-  if (! pic_proc_func_p(proc)) {
-    goto typeerror;
-  }
-  if (pic_proc_cv_size(pic, proc) != 1) {
-    goto typeerror;
-  }
-  v = pic_proc_cv_ref(pic, proc, 0);
-  if (! pic_var_p(v)) {
-    goto typeerror;
-  }
-  return pic_var_ptr(v);
-
- typeerror:
-  pic_errorf(pic, "expected parameter, but got ~s", v);
-}
-
 static pic_value
 var_call(pic_state *pic)
 {
@@ -105,7 +84,22 @@ pic_wrap_var(pic_state *pic, struct pic_var *var)
 struct pic_var *
 pic_unwrap_var(pic_state *pic, struct pic_proc *proc)
 {
-  return get_var_from_proc(pic, proc);
+  pic_value v;
+
+  if (! pic_proc_func_p(proc)) {
+    goto typeerror;
+  }
+  if (pic_proc_cv_size(pic, proc) != 1) {
+    goto typeerror;
+  }
+  v = pic_proc_cv_ref(pic, proc, 0);
+  if (! pic_var_p(v)) {
+    goto typeerror;
+  }
+  return pic_var_ptr(v);
+
+ typeerror:
+  pic_errorf(pic, "expected parameter, but got ~s", v);
 }
 
 static pic_value
@@ -129,7 +123,7 @@ pic_var_parameter_ref(pic_state *pic)
 
   pic_get_args(pic, "l", &proc);
 
-  var = get_var_from_proc(pic, proc);
+  var = pic_unwrap_var(pic, proc);
   return pic_var_ref(pic, var);
 }
 
@@ -142,7 +136,7 @@ pic_var_parameter_set(pic_state *pic)
 
   pic_get_args(pic, "lo", &proc, &v);
 
-  var = get_var_from_proc(pic, proc);
+  var = pic_unwrap_var(pic, proc);
   /* no convert */
   pic_var_set_force(pic, var, v);
   return pic_none_value();
@@ -156,7 +150,7 @@ pic_var_parameter_converter(pic_state *pic)
 
   pic_get_args(pic, "l", &proc);
 
-  var = get_var_from_proc(pic, proc);
+  var = pic_unwrap_var(pic, proc);
   if (var->conv) {
     return pic_obj_value(var->conv);
   }

From 13fec26c592966b86e33064d36bae07a106fce8a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 12 Jul 2014 14:47:18 +0900
Subject: [PATCH 073/216] remove var accessor and mutators

---
 include/picrin/var.h |  4 ----
 src/var.c            | 56 ++++++++++++++++++++++----------------------
 2 files changed, 28 insertions(+), 32 deletions(-)

diff --git a/include/picrin/var.h b/include/picrin/var.h
index bc098200..883b4612 100644
--- a/include/picrin/var.h
+++ b/include/picrin/var.h
@@ -23,10 +23,6 @@ struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc *);
 struct pic_proc *pic_wrap_var(pic_state *, struct pic_var *);
 struct pic_var *pic_unwrap_var(pic_state *, struct pic_proc *);
 
-pic_value pic_var_ref(pic_state *, struct pic_var *);
-void pic_var_set(pic_state *, struct pic_var *, pic_value);
-void pic_var_set_force(pic_state *, struct pic_var *, pic_value);
-
 #if defined(__cplusplus)
 }
 #endif
diff --git a/src/var.c b/src/var.c
index 16f29064..41dd7fef 100644
--- a/src/var.c
+++ b/src/var.c
@@ -6,6 +6,29 @@
 #include "picrin/proc.h"
 #include "picrin/var.h"
 
+static pic_value
+var_ref(pic_state *pic, struct pic_var *var)
+{
+  UNUSED(pic);
+  return var->value;
+}
+
+static void
+var_set_force(pic_state *pic, struct pic_var *var, pic_value value)
+{
+  UNUSED(pic);
+  var->value = value;
+}
+
+static void
+var_set(pic_state *pic, struct pic_var *var, pic_value value)
+{
+  if (var->conv) {
+    value = pic_apply1(pic, var->conv, value);
+  }
+  var_set_force(pic, var, value);
+}
+
 struct pic_var *
 pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv /* = NULL */)
 {
@@ -15,34 +38,11 @@ pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv /* = NULL */)
   var->value = pic_undef_value();
   var->conv = conv;
 
-  pic_var_set(pic, var, init);
+  var_set(pic, var, init);
 
   return var;
 }
 
-pic_value
-pic_var_ref(pic_state *pic, struct pic_var *var)
-{
-  UNUSED(pic);
-  return var->value;
-}
-
-void
-pic_var_set(pic_state *pic, struct pic_var *var, pic_value value)
-{
-  if (var->conv) {
-    value = pic_apply1(pic, var->conv, value);
-  }
-  pic_var_set_force(pic, var, value);
-}
-
-void
-pic_var_set_force(pic_state *pic, struct pic_var *var, pic_value value)
-{
-  UNUSED(pic);
-  var->value = value;
-}
-
 static pic_value
 var_call(pic_state *pic)
 {
@@ -56,12 +56,12 @@ var_call(pic_state *pic)
   c = pic_get_args(pic, "|o", &v);
   if (c == 0) {
     var = pic_var_ptr(proc->env->regs[0]);
-    return pic_var_ref(pic, var);
+    return var_ref(pic, var);
   }
   else if (c == 1) {
     var = pic_var_ptr(proc->env->regs[0]);
 
-    pic_var_set(pic, var, v);
+    var_set(pic, var, v);
     return pic_none_value();
   }
   else {
@@ -124,7 +124,7 @@ pic_var_parameter_ref(pic_state *pic)
   pic_get_args(pic, "l", &proc);
 
   var = pic_unwrap_var(pic, proc);
-  return pic_var_ref(pic, var);
+  return var_ref(pic, var);
 }
 
 static pic_value
@@ -138,7 +138,7 @@ pic_var_parameter_set(pic_state *pic)
 
   var = pic_unwrap_var(pic, proc);
   /* no convert */
-  pic_var_set_force(pic, var, v);
+  var_set_force(pic, var, v);
   return pic_none_value();
 }
 

From fe375a7224067a5b35a9ea546e2a87f0b516857f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 12 Jul 2014 22:07:06 +0900
Subject: [PATCH 074/216] add pic_funcall

---
 include/picrin.h |  2 ++
 src/vm.c         | 12 ++++++++++++
 2 files changed, 14 insertions(+)

diff --git a/include/picrin.h b/include/picrin.h
index 0e673dca..ec799d96 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -135,6 +135,8 @@ void pic_define(pic_state *, const char *, pic_value); /* automatic export */
 pic_value pic_ref(pic_state *, const char *);
 void pic_set(pic_state *, const char *, pic_value);
 
+pic_value pic_funcall(pic_state *pic, const char *name, pic_list args);
+
 struct pic_proc *pic_get_proc(pic_state *);
 int pic_get_args(pic_state *, const char *, ...);
 void pic_defun(pic_state *, const char *, pic_func_t);
diff --git a/src/vm.c b/src/vm.c
index 9e4509f4..432921d1 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -444,6 +444,18 @@ pic_set(pic_state *pic, const char *name, pic_value value)
   pic->globals[gid] = value;
 }
 
+pic_value
+pic_funcall(pic_state *pic, const char *name, pic_list args)
+{
+  pic_value proc;
+
+  proc = pic_ref(pic, name);
+
+  pic_assert_type(pic, proc, proc);
+
+  return pic_apply(pic, pic_proc_ptr(proc), args);
+}
+
 void
 pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
 {

From 05309a1d384cf81c2e52c168d65cdf2c0be369bb Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 12 Jul 2014 22:20:49 +0900
Subject: [PATCH 075/216] don't use pic_defvar

---
 include/picrin.h    |  1 -
 piclib/built-in.scm | 10 ++++++++++
 src/port.c          |  8 +++++---
 src/vm.c            |  9 ---------
 4 files changed, 15 insertions(+), 13 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index ec799d96..2bf9f9fd 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -141,7 +141,6 @@ struct pic_proc *pic_get_proc(pic_state *);
 int pic_get_args(pic_state *, const char *, ...);
 void pic_defun(pic_state *, const char *, pic_func_t);
 void pic_defmacro(pic_state *, const char *, struct pic_proc *);
-void pic_defvar(pic_state *, const char *, pic_value);
 
 bool pic_equal_p(pic_state *, pic_value, pic_value);
 
diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index c57aef21..d5a7b726 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -950,6 +950,16 @@
 
 ;;; 6.13. Input and output
 
+(import (picrin port))
+
+(define current-input-port (make-parameter standard-input-port))
+(define current-output-port (make-parameter standard-output-port))
+(define current-error-port (make-parameter standard-error-port))
+
+(export current-input-port
+        current-output-port
+        current-error-port)
+
 (define (call-with-port port proc)
   (dynamic-wind
       (lambda () #f)
diff --git a/src/port.c b/src/port.c
index 2da85177..42ba0863 100644
--- a/src/port.c
+++ b/src/port.c
@@ -684,9 +684,11 @@ pic_port_flush(pic_state *pic)
 void
 pic_init_port(pic_state *pic)
 {
-  pic_defvar(pic, "current-input-port", port_new_stdport(pic, xstdin, PIC_PORT_IN));
-  pic_defvar(pic, "current-output-port", port_new_stdport(pic, xstdout, PIC_PORT_OUT));
-  pic_defvar(pic, "current-error-port", port_new_stdport(pic, xstderr, PIC_PORT_OUT));
+  pic_deflibrary ("(picrin port)") {
+    pic_define(pic, "standard-input-port", port_new_stdport(pic, xstdin, PIC_PORT_IN));
+    pic_define(pic, "standard-output-port", port_new_stdport(pic, xstdout, PIC_PORT_OUT));
+    pic_define(pic, "standard-error-port", port_new_stdport(pic, xstderr, PIC_PORT_OUT));
+  }
 
   pic_defun(pic, "input-port?", pic_port_input_port_p);
   pic_defun(pic, "output-port?", pic_port_output_port_p);
diff --git a/src/vm.c b/src/vm.c
index 432921d1..cfa8355c 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -465,15 +465,6 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
   pic_define(pic, name, pic_obj_value(proc));
 }
 
-void
-pic_defvar(pic_state *pic, const char *name, pic_value init)
-{
-  struct pic_var *var;
-
-  var = pic_var_new(pic, init, NULL);
-  pic_define(pic, name, pic_obj_value(pic_wrap_var(pic, var)));
-}
-
 static void
 vm_push_env(pic_state *pic)
 {

From 114e4459015ea5da207cc4031b536ea0e0e0f8ff Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 12 Jul 2014 22:21:02 +0900
Subject: [PATCH 076/216] get rid of doubled semicolons

---
 src/port.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/port.c b/src/port.c
index 42ba0863..8a3534bc 100644
--- a/src/port.c
+++ b/src/port.c
@@ -306,7 +306,7 @@ pic_port_open_output_string(pic_state *pic)
 static pic_value
 pic_port_get_output_string(pic_state *pic)
 {
-  struct pic_port *port = pic_stdout(pic);;
+  struct pic_port *port = pic_stdout(pic);
 
   pic_get_args(pic, "|p", &port);
 
@@ -353,7 +353,7 @@ pic_port_open_output_bytevector(pic_state *pic)
 static pic_value
 pic_port_get_output_bytevector(pic_state *pic)
 {
-  struct pic_port *port = pic_stdout(pic);;
+  struct pic_port *port = pic_stdout(pic);
   long endpos;
   char *buf;
 

From c3106a96082276c72daabce0557042d0d1df7b9f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 12 Jul 2014 22:21:19 +0900
Subject: [PATCH 077/216] improve error message

---
 src/vm.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/vm.c b/src/vm.c
index cfa8355c..0063cb92 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -427,7 +427,7 @@ pic_ref(pic_state *pic, const char *name)
 
   gid = global_ref(pic, name);
   if (gid == SIZE_MAX) {
-    pic_error(pic, "symbol not defined");
+    pic_errorf(pic, "symbol \"%s\" not defined", name);
   }
   return pic->globals[gid];
 }

From 7ffcbb7a7deade7dd9e2684ba7b234eb13cff540 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 12 Jul 2014 22:30:50 +0900
Subject: [PATCH 078/216] refactor var. c api no longer supports converters.

---
 include/picrin/var.h |   7 +--
 piclib/built-in.scm  |  35 +++++++++--
 src/gc.c             |   3 -
 src/var.c            | 142 +++++++++++++------------------------------
 4 files changed, 75 insertions(+), 112 deletions(-)

diff --git a/include/picrin/var.h b/include/picrin/var.h
index 883b4612..73afaaba 100644
--- a/include/picrin/var.h
+++ b/include/picrin/var.h
@@ -12,16 +12,15 @@ extern "C" {
 struct pic_var {
   PIC_OBJECT_HEADER
   pic_value value;
-  struct pic_proc *conv;
 };
 
 #define pic_var_p(o) (pic_type(o) == PIC_TT_VAR)
 #define pic_var_ptr(o) ((struct pic_var *)pic_ptr(o))
 
-struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc *);
+struct pic_var *pic_var_new(pic_state *, pic_value);
 
-struct pic_proc *pic_wrap_var(pic_state *, struct pic_var *);
-struct pic_var *pic_unwrap_var(pic_state *, struct pic_proc *);
+pic_value pic_var_ref(pic_state *, const char *);
+void pic_var_set(pic_state *, const char *, pic_value);
 
 #if defined(__cplusplus)
 }
diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index d5a7b726..f598310a 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -410,10 +410,34 @@
   (import (scheme base)
           (scheme cxr)
           (picrin macro)
-          (picrin core-syntax))
+          (picrin core-syntax)
+          (picrin var))
 
-  ;; reopen (pircin parameter)
-  ;; see src/var.c
+  (define (single? x)
+    (and (list? x) (= (length x) 1)))
+
+  (define (double? x)
+    (and (list? x) (= (length x) 2)))
+
+  (define (%make-parameter init conv)
+    (let ((var (make-var (conv init))))
+      (lambda args
+        (cond
+         ((null? args)
+          (var-ref var))
+         ((single? args)
+          (var-set! var (conv (car args))))
+         ((double? args)
+          (var-set! var ((cadr args) (car args))))
+         (else
+          (error "invalid arguments for parameter"))))))
+
+  (define (make-parameter init . conv)
+    (let ((conv
+           (if (null? conv)
+               (lambda (x) x)
+               (car conv))))
+      (%make-parameter init conv)))
 
   (define-syntax parameterize
     (er-macro-transformer
@@ -432,11 +456,12 @@
               ,@bindings
               (,(r 'let) ((,(r 'result) (begin ,@body)))
                 ,@(map (lambda (var)
-                         `(,(r 'parameter-set!) ,var ,(r (gensym var))))
+                         `(,var ,(r (gensym var)) (,(r 'lambda) (x) x)))
                        vars)
                 ,(r 'result))))))))
 
-  (export parameterize))
+  (export make-parameter
+          parameterize))
 
 ;;; Record Type
 (define-library (picrin record)
diff --git a/src/gc.c b/src/gc.c
index ea3c35b3..cfaffa60 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -476,9 +476,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
   case PIC_TT_VAR: {
     struct pic_var *var = (struct pic_var *)obj;
     gc_mark(pic, var->value);
-    if (var->conv) {
-      gc_mark_object(pic, (struct pic_object *)var->conv);
-    }
     break;
   }
   case PIC_TT_IREP: {
diff --git a/src/var.c b/src/var.c
index 41dd7fef..76d3c297 100644
--- a/src/var.c
+++ b/src/var.c
@@ -14,158 +14,100 @@ var_ref(pic_state *pic, struct pic_var *var)
 }
 
 static void
-var_set_force(pic_state *pic, struct pic_var *var, pic_value value)
+var_set(pic_state *pic, struct pic_var *var, pic_value value)
 {
   UNUSED(pic);
   var->value = value;
 }
 
-static void
-var_set(pic_state *pic, struct pic_var *var, pic_value value)
-{
-  if (var->conv) {
-    value = pic_apply1(pic, var->conv, value);
-  }
-  var_set_force(pic, var, value);
-}
-
 struct pic_var *
-pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv /* = NULL */)
+pic_var_new(pic_state *pic, pic_value init)
 {
   struct pic_var *var;
 
   var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR);
-  var->value = pic_undef_value();
-  var->conv = conv;
-
-  var_set(pic, var, init);
+  var->value = init;
 
   return var;
 }
 
-static pic_value
-var_call(pic_state *pic)
+pic_value
+pic_var_ref(pic_state *pic, const char *name)
 {
-  struct pic_proc *proc;
+  pic_value v;
   struct pic_var *var;
-  pic_value v;
-  int c;
 
-  proc = pic_get_proc(pic);
+  v = pic_ref(pic, name);
 
-  c = pic_get_args(pic, "|o", &v);
-  if (c == 0) {
-    var = pic_var_ptr(proc->env->regs[0]);
-    return var_ref(pic, var);
-  }
-  else if (c == 1) {
-    var = pic_var_ptr(proc->env->regs[0]);
+  pic_assert_type(pic, v, var);
 
-    var_set(pic, var, v);
-    return pic_none_value();
-  }
-  else {
-    pic_abort(pic, "logic flaw");
-  }
-  UNREACHABLE();
+  var = pic_var_ptr(v);
+
+  return var_ref(pic, var);
 }
 
-struct pic_proc *
-pic_wrap_var(pic_state *pic, struct pic_var *var)
-{
-  struct pic_proc *proc;
-
-  proc = pic_proc_new(pic, var_call, "<var-procedure>");
-  pic_proc_cv_init(pic, proc, 1);
-  pic_proc_cv_set(pic, proc, 0, pic_obj_value(var));
-  return proc;
-}
-
-struct pic_var *
-pic_unwrap_var(pic_state *pic, struct pic_proc *proc)
+void
+pic_var_set(pic_state *pic, const char *name, pic_value value)
 {
   pic_value v;
+  struct pic_var *var;
 
-  if (! pic_proc_func_p(proc)) {
-    goto typeerror;
-  }
-  if (pic_proc_cv_size(pic, proc) != 1) {
-    goto typeerror;
-  }
-  v = pic_proc_cv_ref(pic, proc, 0);
-  if (! pic_var_p(v)) {
-    goto typeerror;
-  }
-  return pic_var_ptr(v);
+  v = pic_ref(pic, name);
 
- typeerror:
-  pic_errorf(pic, "expected parameter, but got ~s", v);
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+
+  var_set(pic, var, value);
 }
 
 static pic_value
-pic_var_make_parameter(pic_state *pic)
+pic_var_make_var(pic_state *pic)
 {
-  struct pic_proc *conv = NULL;
-  struct pic_var *var;
   pic_value init;
 
-  pic_get_args(pic, "o|l", &init, &conv);
+  pic_get_args(pic, "o", &init);
 
-  var = pic_var_new(pic, init, conv);
-  return pic_obj_value(pic_wrap_var(pic, var));
+  return pic_obj_value(pic_var_new(pic, init));
 }
 
 static pic_value
-pic_var_parameter_ref(pic_state *pic)
+pic_var_var_ref(pic_state *pic)
 {
-  struct pic_proc *proc;
   struct pic_var *var;
+  pic_value v;
 
-  pic_get_args(pic, "l", &proc);
+  pic_get_args(pic, "o", &v);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
 
-  var = pic_unwrap_var(pic, proc);
   return var_ref(pic, var);
 }
 
 static pic_value
-pic_var_parameter_set(pic_state *pic)
+pic_var_var_set(pic_state *pic)
 {
-  struct pic_proc *proc;
   struct pic_var *var;
-  pic_value v;
+  pic_value v, val;
 
-  pic_get_args(pic, "lo", &proc, &v);
+  pic_get_args(pic, "oo", &v, &val);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+  var_set(pic, var, val);
 
-  var = pic_unwrap_var(pic, proc);
-  /* no convert */
-  var_set_force(pic, var, v);
   return pic_none_value();
 }
 
-static pic_value
-pic_var_parameter_converter(pic_state *pic)
-{
-  struct pic_proc *proc;
-  struct pic_var *var;
-
-  pic_get_args(pic, "l", &proc);
-
-  var = pic_unwrap_var(pic, proc);
-  if (var->conv) {
-    return pic_obj_value(var->conv);
-  }
-  else {
-    return pic_false_value();
-  }
-}
-
 void
 pic_init_var(pic_state *pic)
 {
-  pic_deflibrary ("(picrin parameter)") {
-    pic_defun(pic, "make-parameter", pic_var_make_parameter);
-    pic_defun(pic, "parameter-ref", pic_var_parameter_ref);
-    pic_defun(pic, "parameter-set!", pic_var_parameter_set); /* no convert */
-    pic_defun(pic, "parameter-converter", pic_var_parameter_converter);
+  pic_deflibrary ("(picrin var)") {
+    pic_defun(pic, "make-var", pic_var_make_var);
+    pic_defun(pic, "var-ref", pic_var_var_ref);
+    pic_defun(pic, "var-set!", pic_var_var_set);
   }
 }

From 9e8d53088facac4c364c97982e415fb18449aa28 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 00:23:33 +0900
Subject: [PATCH 079/216] add pic_set_c[ad]r

---
 include/picrin/pair.h |  2 ++
 src/pair.c            | 26 ++++++++++++++++++++++++++
 2 files changed, 28 insertions(+)

diff --git a/include/picrin/pair.h b/include/picrin/pair.h
index 64d5d1cb..1f7fccfa 100644
--- a/include/picrin/pair.h
+++ b/include/picrin/pair.h
@@ -21,6 +21,8 @@ struct pic_pair {
 pic_value pic_cons(pic_state *, pic_value, pic_value);
 pic_value pic_car(pic_state *, pic_value);
 pic_value pic_cdr(pic_state *, pic_value);
+void pic_set_car(pic_state *, pic_value, pic_value);
+void pic_set_cdr(pic_state *, pic_value, pic_value);
 
 bool pic_list_p(pic_value);
 pic_value pic_list1(pic_state *, pic_value);
diff --git a/src/pair.c b/src/pair.c
index bb4ef0bb..499b7bb5 100644
--- a/src/pair.c
+++ b/src/pair.c
@@ -45,6 +45,32 @@ pic_cdr(pic_state *pic, pic_value obj)
   return pair->cdr;
 }
 
+void
+pic_set_car(pic_state *pic, pic_value obj, pic_value val)
+{
+  struct pic_pair *pair;
+
+  if (! pic_pair_p(obj)) {
+    pic_error(pic, "pair required");
+  }
+  pair = pic_pair_ptr(obj);
+
+  pair->car = val;
+}
+
+void
+pic_set_cdr(pic_state *pic, pic_value obj, pic_value val)
+{
+  struct pic_pair *pair;
+
+  if (! pic_pair_p(obj)) {
+    pic_error(pic, "pair required");
+  }
+  pair = pic_pair_ptr(obj);
+
+  pair->cdr = val;
+}
+
 bool
 pic_list_p(pic_value obj)
 {

From 2c4fd589bf86eb5a3f649b335a545def51140cdd Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 00:48:03 +0900
Subject: [PATCH 080/216] manage values in a stack

---
 include/picrin/var.h |  4 ++-
 src/gc.c             |  2 +-
 src/var.c            | 85 ++++++++++++++++++++++++++++++++++++++++----
 3 files changed, 83 insertions(+), 8 deletions(-)

diff --git a/include/picrin/var.h b/include/picrin/var.h
index 73afaaba..9926c092 100644
--- a/include/picrin/var.h
+++ b/include/picrin/var.h
@@ -11,7 +11,7 @@ extern "C" {
 
 struct pic_var {
   PIC_OBJECT_HEADER
-  pic_value value;
+  pic_value stack;
 };
 
 #define pic_var_p(o) (pic_type(o) == PIC_TT_VAR)
@@ -21,6 +21,8 @@ struct pic_var *pic_var_new(pic_state *, pic_value);
 
 pic_value pic_var_ref(pic_state *, const char *);
 void pic_var_set(pic_state *, const char *, pic_value);
+void pic_var_push(pic_state *, const char *, pic_value);
+void pic_var_pop(pic_state *, const char *);
 
 #if defined(__cplusplus)
 }
diff --git a/src/gc.c b/src/gc.c
index cfaffa60..97532671 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -475,7 +475,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
   }
   case PIC_TT_VAR: {
     struct pic_var *var = (struct pic_var *)obj;
-    gc_mark(pic, var->value);
+    gc_mark(pic, var->stack);
     break;
   }
   case PIC_TT_IREP: {
diff --git a/src/var.c b/src/var.c
index 76d3c297..9cbb00e5 100644
--- a/src/var.c
+++ b/src/var.c
@@ -3,21 +3,31 @@
  */
 
 #include "picrin.h"
-#include "picrin/proc.h"
 #include "picrin/var.h"
+#include "picrin/pair.h"
 
 static pic_value
 var_ref(pic_state *pic, struct pic_var *var)
 {
-  UNUSED(pic);
-  return var->value;
+  return pic_car(pic, var->stack);
 }
 
 static void
 var_set(pic_state *pic, struct pic_var *var, pic_value value)
 {
-  UNUSED(pic);
-  var->value = value;
+  pic_set_car(pic, var->stack, value);
+}
+
+static void
+var_push(pic_state *pic, struct pic_var *var, pic_value value)
+{
+  var->stack = pic_cons(pic, value, var->stack);
+}
+
+static void
+var_pop(pic_state *pic, struct pic_var *var)
+{
+  var->stack = pic_cdr(pic, var->stack);
 }
 
 struct pic_var *
@@ -26,7 +36,9 @@ pic_var_new(pic_state *pic, pic_value init)
   struct pic_var *var;
 
   var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR);
-  var->value = init;
+  var->stack = pic_nil_value();
+
+  var_push(pic, var, init);
 
   return var;
 }
@@ -61,6 +73,36 @@ pic_var_set(pic_state *pic, const char *name, pic_value value)
   var_set(pic, var, value);
 }
 
+void
+pic_var_push(pic_state *pic, const char *name, pic_value value)
+{
+  pic_value v;
+  struct pic_var *var;
+
+  v = pic_ref(pic, name);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+
+  var_push(pic, var, value);
+}
+
+void
+pic_var_pop(pic_state *pic, const char *name)
+{
+  pic_value v;
+  struct pic_var *var;
+
+  v = pic_ref(pic, name);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+
+  var_pop(pic, var);
+}
+
 static pic_value
 pic_var_make_var(pic_state *pic)
 {
@@ -98,7 +140,36 @@ pic_var_var_set(pic_state *pic)
 
   var = pic_var_ptr(v);
   var_set(pic, var, val);
+  return pic_none_value();
+}
 
+static pic_value
+pic_var_var_push(pic_state *pic)
+{
+  struct pic_var *var;
+  pic_value v, val;
+
+  pic_get_args(pic, "oo", &v, &val);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+  var_push(pic, var, val);
+  return pic_none_value();
+}
+
+static pic_value
+pic_var_var_pop(pic_state *pic)
+{
+  struct pic_var *var;
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+  var_pop(pic, var);
   return pic_none_value();
 }
 
@@ -109,5 +180,7 @@ pic_init_var(pic_state *pic)
     pic_defun(pic, "make-var", pic_var_make_var);
     pic_defun(pic, "var-ref", pic_var_var_ref);
     pic_defun(pic, "var-set!", pic_var_var_set);
+    pic_defun(pic, "var-push!", pic_var_var_push);
+    pic_defun(pic, "var-pop!", pic_var_var_pop);
   }
 }

From 9c78a9a51f70fc2afab146bbd7e20ab274ac4456 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 00:56:09 +0900
Subject: [PATCH 081/216] refactor parameterize

---
 piclib/built-in.scm | 56 +++++++++++++++++++++++++++------------------
 1 file changed, 34 insertions(+), 22 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index f598310a..e2131ab2 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -411,7 +411,9 @@
           (scheme cxr)
           (picrin macro)
           (picrin core-syntax)
-          (picrin var))
+          (picrin var)
+          (picrin attribute)
+          (picrin dictionary))
 
   (define (single? x)
     (and (list? x) (= (length x) 1)))
@@ -421,7 +423,7 @@
 
   (define (%make-parameter init conv)
     (let ((var (make-var (conv init))))
-      (lambda args
+      (define (parameter . args)
         (cond
          ((null? args)
           (var-ref var))
@@ -430,7 +432,11 @@
          ((double? args)
           (var-set! var ((cadr args) (car args))))
          (else
-          (error "invalid arguments for parameter"))))))
+          (error "invalid arguments for parameter"))))
+
+      (dictionary-set! (attribute parameter) '@@var var)
+
+      parameter))
 
   (define (make-parameter init . conv)
     (let ((conv
@@ -439,26 +445,32 @@
                (car conv))))
       (%make-parameter init conv)))
 
+  (define-syntax with
+    (ir-macro-transformer
+     (lambda (form inject compare)
+       (let ((before (car (cdr form)))
+             (after  (car (cdr (cdr form))))
+             (body   (cdr (cdr (cdr form)))))
+         `(begin
+            (,before)
+            (let ((result (begin ,@body)))
+              (,after)
+              result))))))
+
+  (define (var-of parameter)
+    (dictionary-ref (attribute parameter) '@@var))
+
   (define-syntax parameterize
-    (er-macro-transformer
-     (lambda (form r compare)
-       (let ((bindings (cadr form))
-             (body (cddr form)))
-         (let ((vars (map car bindings))
-               (gensym (lambda (var)
-                         (string->symbol
-                          (string-append
-                           "parameterize-"
-                           (symbol->string var))))))
-           `(,(r 'let) (,@(map (lambda (var)
-                                 `(,(r (gensym var)) (,var)))
-                            vars))
-              ,@bindings
-              (,(r 'let) ((,(r 'result) (begin ,@body)))
-                ,@(map (lambda (var)
-                         `(,var ,(r (gensym var)) (,(r 'lambda) (x) x)))
-                       vars)
-                ,(r 'result))))))))
+    (ir-macro-transformer
+     (lambda (form inject compare)
+       (let ((formal (car (cdr form)))
+             (body   (cdr (cdr form))))
+         (let ((vars (map car formal))
+               (vals (map cadr formal)))
+           `(with
+             (lambda () ,@(map (lambda (var val) `(var-push! (var-of ,var) ,val)) vars vals))
+             (lambda () ,@(map (lambda (var) `(var-pop! (var-of ,var))) vars))
+             ,@body))))))
 
   (export make-parameter
           parameterize))

From b0474aaec21dfb4fb410812023378d4d496f5619 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 12:07:07 +0900
Subject: [PATCH 082/216] add dictionary operators

---
 include/picrin/dict.h |  5 ++++
 src/dict.c            | 55 +++++++++++++++++++++++++++++++++----------
 2 files changed, 47 insertions(+), 13 deletions(-)

diff --git a/include/picrin/dict.h b/include/picrin/dict.h
index 7d969818..ae118e13 100644
--- a/include/picrin/dict.h
+++ b/include/picrin/dict.h
@@ -19,6 +19,11 @@ struct pic_dict {
 
 struct pic_dict *pic_dict_new(pic_state *);
 
+pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym);
+void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value);
+void pic_dict_del(pic_state *, struct pic_dict *, pic_sym);
+size_t pic_dict_size(pic_state *, struct pic_dict *);
+
 #if defined(__cplusplus)
 }
 #endif
diff --git a/src/dict.c b/src/dict.c
index 9789f117..2f7088cd 100644
--- a/src/dict.c
+++ b/src/dict.c
@@ -16,6 +16,44 @@ pic_dict_new(pic_state *pic)
   return dict;
 }
 
+pic_value
+pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym key)
+{
+  xh_entry *e;
+
+  e = xh_get_int(&dict->hash, key);
+  if (! e) {
+    pic_errorf(pic, "element not found for a key: ~s", pic_sym_value(key));
+  }
+  return xh_val(e, pic_value);
+}
+
+void
+pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_sym key, pic_value val)
+{
+  UNUSED(pic);
+
+  xh_put_int(&dict->hash, key, &val);
+}
+
+size_t
+pic_dict_size(pic_state *pic, struct pic_dict *dict)
+{
+  UNUSED(pic);
+
+  return dict->hash.count;
+}
+
+void
+pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key)
+{
+  if (xh_get_int(&dict->hash, key) == NULL) {
+    pic_errorf(pic, "no slot named ~s found in dictionary", pic_sym_value(key));
+  }
+
+  xh_del_int(&dict->hash, key);
+}
+
 static pic_value
 pic_dict_dict(pic_state *pic)
 {
@@ -43,15 +81,10 @@ pic_dict_dict_ref(pic_state *pic)
 {
   struct pic_dict *dict;
   pic_sym key;
-  xh_entry *e;
 
   pic_get_args(pic, "dm", &dict, &key);
 
-  e = xh_get_int(&dict->hash, key);
-  if (! e) {
-    pic_errorf(pic, "element not found for a key: ~s", pic_sym_value(key));
-  }
-  return xh_val(e, pic_value);
+  return pic_dict_ref(pic, dict , key);
 }
 
 static pic_value
@@ -63,7 +96,7 @@ pic_dict_dict_set(pic_state *pic)
 
   pic_get_args(pic, "dmo", &dict, &key, &val);
 
-  xh_put_int(&dict->hash, key, &val);
+  pic_dict_set(pic, dict, key, val);
 
   return pic_none_value();
 }
@@ -76,11 +109,7 @@ pic_dict_dict_del(pic_state *pic)
 
   pic_get_args(pic, "dm", &dict, &key);
 
-  if (xh_get_int(&dict->hash, key) == NULL) {
-    pic_errorf(pic, "no slot named ~s found in dictionary", pic_sym_value(key));
-  }
-
-  xh_del_int(&dict->hash, key);
+  pic_dict_del(pic, dict, key);
 
   return pic_none_value();
 }
@@ -92,7 +121,7 @@ pic_dict_dict_size(pic_state *pic)
 
   pic_get_args(pic, "d", &dict);
 
-  return pic_int_value(dict->hash.count);
+  return pic_int_value(pic_dict_size(pic, dict));
 }
 
 void

From 88593b1f9d2e10200e721b70024e48e311b144e7 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 12:07:56 +0900
Subject: [PATCH 083/216] rename 'dictionary' 'make-dictionary'

---
 src/dict.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/dict.c b/src/dict.c
index 2f7088cd..6c8fb3c5 100644
--- a/src/dict.c
+++ b/src/dict.c
@@ -128,7 +128,7 @@ void
 pic_init_dict(pic_state *pic)
 {
   pic_deflibrary ("(picrin dictionary)") {
-    pic_defun(pic, "dictionary", pic_dict_dict);
+    pic_defun(pic, "make-dictionary", pic_dict_dict);
     pic_defun(pic, "dictionary?", pic_dict_dict_p);
     pic_defun(pic, "dictionary-ref", pic_dict_dict_ref);
     pic_defun(pic, "dictionary-set!", pic_dict_dict_set);

From 71677d3e85b5640d2446461692ddc459ebfdaefc Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 12:18:39 +0900
Subject: [PATCH 084/216] add dictionary.scm

---
 piclib/CMakeLists.txt        |  1 +
 piclib/picrin/dictionary.scm | 31 +++++++++++++++++++++++++++++++
 2 files changed, 32 insertions(+)
 create mode 100644 piclib/picrin/dictionary.scm

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 497d8cd1..49f1c4b3 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,5 +1,6 @@
 list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/built-in.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm
diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm
new file mode 100644
index 00000000..ac23f8ab
--- /dev/null
+++ b/piclib/picrin/dictionary.scm
@@ -0,0 +1,31 @@
+(define-library (picrin dictionary)
+  (import (scheme base))
+
+  (define (dictionary->plist dict)
+    (error "not implemented"))
+
+  (define (plist->dictionary plist)
+    (let ((dict (make-dictionary)))
+      (do ((kv plist (cddr kv)))
+          ((null? kv)
+           dict)
+        (dictionary-set! dict (car kv) (cadr kv)))))
+
+  (define (dictionary->alist dict)
+    (error "not implemented"))
+
+  (define (alist->dictionary alist)
+    (let ((dict (make-dictionary)))
+      (do ((kv alist (cdr kv)))
+          ((null? kv)
+           dict)
+        (dictionary-set! dict (car kv) (cdr kv)))))
+
+  (define (dictionary . plist)
+    (plist->dictionary plist))
+
+  (export dictionary
+          dictionary->plist
+          plist->dictionary
+          dictionary->alist
+          alist->dictionary))

From 9e5b019e449d8a9fff63e6a76d90adfe94cf6aaa Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 12:27:03 +0900
Subject: [PATCH 085/216] add dictionary-for-each

---
 src/dict.c | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

diff --git a/src/dict.c b/src/dict.c
index 6c8fb3c5..e9fd5e80 100644
--- a/src/dict.c
+++ b/src/dict.c
@@ -124,6 +124,23 @@ pic_dict_dict_size(pic_state *pic)
   return pic_int_value(pic_dict_size(pic, dict));
 }
 
+static pic_value
+pic_dict_dict_for_each(pic_state *pic)
+{
+  struct pic_proc *proc;
+  struct pic_dict *dict;
+  xh_iter it;
+
+  pic_get_args(pic, "ld", &proc, &dict);
+
+  xh_begin(&it, &dict->hash);
+  while (xh_next(&it)) {
+    pic_apply2(pic, proc, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value));
+  }
+
+  return pic_none_value();
+}
+
 void
 pic_init_dict(pic_state *pic)
 {
@@ -134,5 +151,6 @@ pic_init_dict(pic_state *pic)
     pic_defun(pic, "dictionary-set!", pic_dict_dict_set);
     pic_defun(pic, "dictionary-delete", pic_dict_dict_del);
     pic_defun(pic, "dictionary-size", pic_dict_dict_size);
+    pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each);
   }
 }

From b7a44ee8106a25a30da052c6d67b05e49e52ef91 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 12:33:13 +0900
Subject: [PATCH 086/216] fix not-implemented errors

---
 piclib/picrin/dictionary.scm | 21 +++++++++++++++++++--
 1 file changed, 19 insertions(+), 2 deletions(-)

diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm
index ac23f8ab..a532b2e4 100644
--- a/piclib/picrin/dictionary.scm
+++ b/piclib/picrin/dictionary.scm
@@ -1,8 +1,21 @@
 (define-library (picrin dictionary)
   (import (scheme base))
 
+  (define (dictionary-map proc dict)
+    (let ((kvs '()))
+      (dictionary-for-each
+       (lambda (key val)
+         (set! kvs (cons (proc key val) kvs)))
+       dict)
+      (reverse kvs)))
+
   (define (dictionary->plist dict)
-    (error "not implemented"))
+    (let ((kvs '()))
+      (dictionary-for-each
+       (lambda (key val)
+         (set! kvs (cons val (cons key kvs))))
+       dict)
+      (reverse kvs)))
 
   (define (plist->dictionary plist)
     (let ((dict (make-dictionary)))
@@ -12,7 +25,10 @@
         (dictionary-set! dict (car kv) (cadr kv)))))
 
   (define (dictionary->alist dict)
-    (error "not implemented"))
+    (dictionary-map
+     (lambda (key val)
+       (cons key val))
+     dict))
 
   (define (alist->dictionary alist)
     (let ((dict (make-dictionary)))
@@ -25,6 +41,7 @@
     (plist->dictionary plist))
 
   (export dictionary
+          dictionary-map
           dictionary->plist
           plist->dictionary
           dictionary->alist

From 21b21cc3cce7fd120b8475040e97f625212efa9c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 12:37:15 +0900
Subject: [PATCH 087/216] update docs

---
 docs/libs.rst | 19 +++++++++++++++++--
 1 file changed, 17 insertions(+), 2 deletions(-)

diff --git a/docs/libs.rst b/docs/libs.rst
index 2a7a7a1f..102a1b54 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -144,9 +144,9 @@ Symbol to Object table. Internally it is implemented on hash-table.
 
 Note that dictionary is not a weak map; if you are going to make a highly memory-consuming program with dictionaries, you should know that dictionaries keep their bound objects and never let them free until you explicitly deletes bindings.
 
-- **(dictionary)**
+- **(dictionary . plist)**
 
-  Returns a newly allocated empty dictionary. In the future, it is planned to extend this function to take optional arguments for initial key/values.
+  Returns a newly allocated empty dictionary. The dictionary is initialized with the content of plist.
 
 - **(dictionary? obj)**
 
@@ -168,6 +168,21 @@ Note that dictionary is not a weak map; if you are going to make a highly memory
 
   Returns the number of registered elements in dict.
 
+- **(dicitonary-map proc dict)**
+
+  Perform mapping action onto dictionary object. ``proc`` is called by a sequence ``(proc key val)``.
+
+- **(dictionary-for-each proc dict)**
+
+  Similar to ``dictionary-map``, but discards the result.
+
+- **(dictionary->plist dict)**
+- **(plist->dictionary plist)**
+- **(dictionary->alist dict)**
+- **(alist->dictionary alist)**
+
+  Conversion between dictionary and alist/plist.
+
 
 (picrin user)
 -------------

From 73c406ed42febec6809506c8563c4d0a9cd7e61e Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 16:56:39 +0900
Subject: [PATCH 088/216] add translate function

---
 src/macro.c | 70 +++++++++++++++++++++++++++++------------------------
 1 file changed, 38 insertions(+), 32 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index ea200e7d..6edc62b3 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -156,6 +156,33 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass
   return senv;
 }
 
+static pic_sym
+translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box)
+{
+  pic_sym rename;
+  pic_value x;
+
+  if (! pic_interned_p(pic, sym)) {
+    return sym;
+  }
+  while (true) {
+    if (pic_find_rename(pic, senv, sym, &rename)) {
+      return rename;
+    }
+    if (! senv->up)
+      break;
+    senv = senv->up;
+  }
+  x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box));
+  if (pic_test(x)) {
+    return pic_sym(pic_cdr(pic, x));
+  } else {
+    rename = pic_gensym(pic, sym);
+    pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box)));
+    return rename;
+  }
+}
+
 static pic_value
 macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box)
 {
@@ -191,31 +218,10 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu
   return list;
 }
 
-static pic_sym
+static pic_value
 macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box)
 {
-  pic_sym rename;
-  pic_value x;
-
-  if (! pic_interned_p(pic, sym)) {
-    return sym;
-  }
-  while (true) {
-    if (pic_find_rename(pic, senv, sym, &rename)) {
-      return rename;
-    }
-    if (! senv->up)
-      break;
-    senv = senv->up;
-  }
-  x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box));
-  if (pic_test(x)) {
-    return pic_sym(pic_cdr(pic, x));
-  } else {
-    rename = pic_gensym(pic, sym);
-    pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box)));
-    return rename;
-  }
+  return pic_sym_value(translate(pic, sym, senv, assoc_box));
 }
 
 static pic_value
@@ -499,7 +505,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
     return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box);
   }
   case PIC_TT_SYMBOL: {
-    return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box));
+    return macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box);
   }
   case PIC_TT_PAIR: {
     pic_value car;
@@ -720,7 +726,7 @@ er_macro_rename(pic_state *pic)
   mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
   assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
 
-  return pic_sym_value(macroexpand_symbol(pic, sym, mac_env, assoc_box));
+  return pic_sym_value(translate(pic, sym, mac_env, assoc_box));
 }
 
 static pic_value
@@ -739,8 +745,8 @@ er_macro_compare(pic_state *pic)
   use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
   assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
 
-  m = macroexpand_symbol(pic, pic_sym(a), use_env, assoc_box);
-  n = macroexpand_symbol(pic, pic_sym(b), use_env, assoc_box);
+  m = translate(pic, pic_sym(a), use_env, assoc_box);
+  n = translate(pic, pic_sym(b), use_env, assoc_box);
 
   return pic_bool_value(m == n);
 }
@@ -805,7 +811,7 @@ ir_macro_inject(pic_state *pic)
   use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
   assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
 
-  return pic_sym_value(macroexpand_symbol(pic, sym, use_env, assoc_box));
+  return pic_sym_value(translate(pic, sym, use_env, assoc_box));
 }
 
 static pic_value
@@ -824,8 +830,8 @@ ir_macro_compare(pic_state *pic)
   mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
   assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
 
-  m = macroexpand_symbol(pic, pic_sym(a), mac_env, assoc_box);
-  n = macroexpand_symbol(pic, pic_sym(b), mac_env, assoc_box);
+  m = translate(pic, pic_sym(a), mac_env, assoc_box);
+  n = translate(pic, pic_sym(b), mac_env, assoc_box);
 
   return pic_bool_value(m == n);
 }
@@ -835,7 +841,7 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu
 {
   if (pic_sym_p(expr)) {
     pic_value r;
-    r = pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), use_env, assoc_box));
+    r = pic_sym_value(translate(pic, pic_sym(expr), use_env, assoc_box));
     *ir = pic_acons(pic, r, expr, *ir);
     return r;
   }
@@ -857,7 +863,7 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_va
     if (pic_test(r = pic_assq(pic, expr, *ir))) {
       return pic_cdr(pic, r);
     }
-    return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), mac_env, assoc_box));
+    return pic_sym_value(translate(pic, pic_sym(expr), mac_env, assoc_box));
   }
   else if (pic_pair_p(expr)) {
     return pic_cons(pic,

From 54d50d57a19570608cab7f7ecc9ac6260d054956 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 17:01:55 +0900
Subject: [PATCH 089/216] add pic_dict_has

---
 include/picrin/dict.h | 1 +
 src/dict.c            | 8 ++++++++
 2 files changed, 9 insertions(+)

diff --git a/include/picrin/dict.h b/include/picrin/dict.h
index ae118e13..8bc58ad8 100644
--- a/include/picrin/dict.h
+++ b/include/picrin/dict.h
@@ -23,6 +23,7 @@ pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym);
 void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value);
 void pic_dict_del(pic_state *, struct pic_dict *, pic_sym);
 size_t pic_dict_size(pic_state *, struct pic_dict *);
+bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym);
 
 #if defined(__cplusplus)
 }
diff --git a/src/dict.c b/src/dict.c
index e9fd5e80..d3eb895b 100644
--- a/src/dict.c
+++ b/src/dict.c
@@ -44,6 +44,14 @@ pic_dict_size(pic_state *pic, struct pic_dict *dict)
   return dict->hash.count;
 }
 
+bool
+pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key)
+{
+  UNUSED(pic);
+
+  return xh_get_int(&dict->hash, key) != NULL;
+}
+
 void
 pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key)
 {

From e1cba4b48e38f295dd0e365e7d200544569563cb Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 17:07:27 +0900
Subject: [PATCH 090/216] refactor translate to use pic_dict instead of boxes

---
 src/macro.c | 162 ++++++++++++++++++++++++++--------------------------
 1 file changed, 80 insertions(+), 82 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 6edc62b3..0cb7349f 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -9,7 +9,7 @@
 #include "picrin/macro.h"
 #include "picrin/lib.h"
 #include "picrin/error.h"
-#include "picrin/box.h"
+#include "picrin/dict.h"
 
 struct pic_senv *
 pic_null_syntactic_environment(pic_state *pic)
@@ -108,15 +108,15 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
   pic_export(pic, sym);
 }
 
-static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, pic_value);
+static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);
 
 static pic_value
-macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
   size_t ai = pic_gc_arena_preserve(pic);
   pic_value v;
 
-  v = macroexpand_node(pic, expr, senv, assoc_box);
+  v = macroexpand_node(pic, expr, senv, cxt);
 
   pic_gc_arena_restore(pic, ai);
   pic_gc_protect(pic, v);
@@ -124,7 +124,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value ass
 }
 
 static struct pic_senv *
-push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box)
+push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, struct pic_dict *cxt)
 {
   struct pic_senv *senv;
   pic_value a;
@@ -137,7 +137,7 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass
     pic_value v = pic_car(pic, a);
 
     if (! pic_sym_p(v)) {
-      v = macroexpand(pic, v, up, assoc_box);
+      v = macroexpand(pic, v, up, cxt);
     }
     if (! pic_sym_p(v)) {
       pic_error(pic, "syntax error");
@@ -145,7 +145,7 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass
     pic_add_rename(pic, senv, pic_sym(v));
   }
   if (! pic_sym_p(a)) {
-    a = macroexpand(pic, a, up, assoc_box);
+    a = macroexpand(pic, a, up, cxt);
   }
   if (pic_sym_p(a)) {
     pic_add_rename(pic, senv, pic_sym(a));
@@ -157,10 +157,9 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass
 }
 
 static pic_sym
-translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box)
+translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_sym rename;
-  pic_value x;
 
   if (! pic_interned_p(pic, sym)) {
     return sym;
@@ -173,18 +172,17 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_bo
       break;
     senv = senv->up;
   }
-  x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box));
-  if (pic_test(x)) {
-    return pic_sym(pic_cdr(pic, x));
+  if (pic_dict_has(pic, cxt, sym)) {
+    return pic_sym(pic_dict_ref(pic, cxt, sym));
   } else {
     rename = pic_gensym(pic, sym);
-    pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box)));
+    pic_dict_set(pic, cxt, sym, pic_sym_value(rename));
     return rename;
   }
 }
 
 static pic_value
-macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, struct pic_dict *cxt)
 {
   size_t ai = pic_gc_arena_preserve(pic);
   pic_value v, vs;
@@ -194,7 +192,7 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu
   while (pic_pair_p(list)) {
     v = pic_car(pic, list);
 
-    vs = pic_cons(pic, macroexpand(pic, v, senv, assoc_box), vs);
+    vs = pic_cons(pic, macroexpand(pic, v, senv, cxt), vs);
     list = pic_cdr(pic, list);
 
     pic_gc_arena_restore(pic, ai);
@@ -202,7 +200,7 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu
     pic_gc_protect(pic, list);
   }
 
-  list = macroexpand(pic, list, senv, assoc_box);
+  list = macroexpand(pic, list, senv, cxt);
 
   /* reverse the result */
   pic_for_each (v, vs) {
@@ -219,9 +217,9 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu
 }
 
 static pic_value
-macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
-  return pic_sym_value(translate(pic, sym, senv, assoc_box));
+  return pic_sym_value(translate(pic, sym, senv, cxt));
 }
 
 static pic_value
@@ -307,7 +305,7 @@ macroexpand_export(pic_state *pic, pic_value expr)
 }
 
 static pic_value
-macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_value var, val;
   pic_sym sym, rename;
@@ -318,7 +316,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic
 
   var = pic_cadr(pic, expr);
   if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv, assoc_box);
+    var = macroexpand(pic, var, senv, cxt);
   }
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
@@ -393,7 +391,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
 }
 
 static pic_value
-macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_sym sym;
   pic_value formals;
@@ -404,13 +402,13 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va
 
   formals = pic_cadr(pic, expr);
   if (pic_pair_p(formals)) {
-    struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, assoc_box);
+    struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, cxt);
     pic_value a;
 
     /* defined symbol */
     a = pic_car(pic, formals);
     if (! pic_sym_p(a)) {
-      a = macroexpand(pic, a, senv, assoc_box);
+      a = macroexpand(pic, a, senv, cxt);
     }
     if (! pic_sym_p(a)) {
       pic_error(pic, "binding to non-symbol object");
@@ -423,12 +421,12 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va
     /* binding value */
     return pic_cons(pic, pic_sym_value(pic->sDEFINE),
                     pic_cons(pic,
-                             macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box),
-                             macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box)));
+                             macroexpand_list(pic, pic_cadr(pic, expr), in, cxt),
+                             macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)));
   }
 
   if (! pic_sym_p(formals)) {
-    formals = macroexpand(pic, formals, senv, assoc_box);
+    formals = macroexpand(pic, formals, senv, cxt);
   }
   if (! pic_sym_p(formals)) {
     pic_error(pic, "binding to non-symbol object");
@@ -438,18 +436,18 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va
     pic_add_rename(pic, senv, sym);
   }
 
-  return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box));
+  return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt));
 }
 
 static pic_value
-macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
-  struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, assoc_box);
+  struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, cxt);
 
   return pic_cons(pic, pic_sym_value(pic->sLAMBDA),
                   pic_cons(pic,
-                           macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box),
-                           macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box)));
+                           macroexpand_list(pic, pic_cadr(pic, expr), in, cxt),
+                           macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)));
 }
 
 static pic_value
@@ -459,7 +457,7 @@ macroexpand_quote(pic_state *pic, pic_value expr)
 }
 
 static pic_value
-macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_value v, args;
 
@@ -488,11 +486,11 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
   puts("");
 #endif
 
-  return macroexpand(pic, v, senv, assoc_box);
+  return macroexpand(pic, v, senv, cxt);
 }
 
 static pic_value
-macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
 #if DEBUG
   printf("[macroexpand] expanding... ");
@@ -502,10 +500,10 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
 
   switch (pic_type(expr)) {
   case PIC_TT_SC: {
-    return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box);
+    return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, cxt);
   }
   case PIC_TT_SYMBOL: {
-    return macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box);
+    return macroexpand_symbol(pic, pic_sym(expr), senv, cxt);
   }
   case PIC_TT_PAIR: {
     pic_value car;
@@ -515,7 +513,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
       pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
     }
 
-    car = macroexpand(pic, pic_car(pic, expr), senv, assoc_box);
+    car = macroexpand(pic, pic_car(pic, expr), senv, cxt);
     if (pic_sym_p(car)) {
       pic_sym tag = pic_sym(car);
 
@@ -529,27 +527,27 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
         return macroexpand_export(pic, expr);
       }
       else if (tag == pic->sDEFINE_SYNTAX) {
-        return macroexpand_defsyntax(pic, expr, senv, assoc_box);
+        return macroexpand_defsyntax(pic, expr, senv, cxt);
       }
       else if (tag == pic->sDEFINE_MACRO) {
         return macroexpand_defmacro(pic, expr, senv);
       }
       else if (tag == pic->sLAMBDA) {
-        return macroexpand_lambda(pic, expr, senv, assoc_box);
+        return macroexpand_lambda(pic, expr, senv, cxt);
       }
       else if (tag == pic->sDEFINE) {
-        return macroexpand_define(pic, expr, senv, assoc_box);
+        return macroexpand_define(pic, expr, senv, cxt);
       }
       else if (tag == pic->sQUOTE) {
         return macroexpand_quote(pic, expr);
       }
 
       if ((mac = find_macro(pic, tag)) != NULL) {
-        return macroexpand_macro(pic, mac, expr, senv, assoc_box);
+        return macroexpand_macro(pic, mac, expr, senv, cxt);
       }
     }
 
-    return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box));
+    return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt));
   }
   case PIC_TT_EOF:
   case PIC_TT_NIL:
@@ -584,7 +582,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
 pic_value
 pic_macroexpand(pic_state *pic, pic_value expr)
 {
-  pic_value v, box;
+  pic_value v;
 
 #if DEBUG
   puts("before expand:");
@@ -592,9 +590,7 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   puts("");
 #endif
 
-  box = pic_box(pic, pic_nil_value());
-
-  v = macroexpand(pic, expr, pic->lib->senv, box);
+  v = macroexpand(pic, expr, pic->lib->senv, pic_dict_new(pic));
 
 #if DEBUG
   puts("after expand:");
@@ -653,16 +649,16 @@ sc_identifier_p(pic_value obj)
 static bool
 sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y)
 {
-  pic_value box;
+  struct pic_dict *cxt;
 
   if (! (sc_identifier_p(x) && sc_identifier_p(y))) {
     return false;
   }
 
-  box = pic_box(pic, pic_nil_value());
+  cxt = pic_dict_new(pic);
 
-  x = macroexpand(pic, x, e1, box);
-  y = macroexpand(pic, y, e2, box);
+  x = macroexpand(pic, x, e1, cxt);
+  y = macroexpand(pic, y, e2, cxt);
 
   return pic_eq_p(x, y);
 }
@@ -719,14 +715,14 @@ er_macro_rename(pic_state *pic)
 {
   pic_sym sym;
   struct pic_senv *mac_env;
-  pic_value assoc_box;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "m", &sym);
 
   mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
-  assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
+  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  return pic_sym_value(translate(pic, sym, mac_env, assoc_box));
+  return pic_sym_value(translate(pic, sym, mac_env, cxt));
 }
 
 static pic_value
@@ -735,7 +731,7 @@ er_macro_compare(pic_state *pic)
   pic_value a, b;
   struct pic_senv *use_env;
   pic_sym m, n;
-  pic_value assoc_box;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "oo", &a, &b);
 
@@ -743,10 +739,10 @@ er_macro_compare(pic_state *pic)
     return pic_false_value();   /* should be an error? */
 
   use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-  assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
+  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  m = translate(pic, pic_sym(a), use_env, assoc_box);
-  n = translate(pic, pic_sym(b), use_env, assoc_box);
+  m = translate(pic, pic_sym(a), use_env, cxt);
+  n = translate(pic, pic_sym(b), use_env, cxt);
 
   return pic_bool_value(m == n);
 }
@@ -754,8 +750,9 @@ er_macro_compare(pic_state *pic)
 static pic_value
 er_macro_call(pic_state *pic)
 {
-  pic_value expr, use_env, mac_env, box;
+  pic_value expr, use_env, mac_env;
   struct pic_proc *rename, *compare, *cb;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
 
@@ -766,19 +763,19 @@ er_macro_call(pic_state *pic)
     pic_error(pic, "unexpected type of argument 3");
   }
 
-  box = pic_box(pic, pic_nil_value());
+  cxt = pic_dict_new(pic);
 
   rename = pic_proc_new(pic, er_macro_rename, "<er-macro-renamer>");
   pic_proc_cv_init(pic, rename, 3);
   pic_proc_cv_set(pic, rename, 0, use_env);
   pic_proc_cv_set(pic, rename, 1, mac_env);
-  pic_proc_cv_set(pic, rename, 2, box);
+  pic_proc_cv_set(pic, rename, 2, pic_obj_value(cxt));
 
   compare = pic_proc_new(pic, er_macro_compare, "<er-macro-comparator>");
   pic_proc_cv_init(pic, compare, 3);
   pic_proc_cv_set(pic, compare, 0, use_env);
   pic_proc_cv_set(pic, compare, 1, mac_env);
-  pic_proc_cv_set(pic, compare, 2, box);
+  pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
 
   cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
 
@@ -804,14 +801,14 @@ ir_macro_inject(pic_state *pic)
 {
   pic_sym sym;
   struct pic_senv *use_env;
-  pic_value assoc_box;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "m", &sym);
 
   use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-  assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
+  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  return pic_sym_value(translate(pic, sym, use_env, assoc_box));
+  return pic_sym_value(translate(pic, sym, use_env, cxt));
 }
 
 static pic_value
@@ -820,7 +817,7 @@ ir_macro_compare(pic_state *pic)
   pic_value a, b;
   struct pic_senv *mac_env;
   pic_sym m, n;
-  pic_value assoc_box;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "oo", &a, &b);
 
@@ -828,27 +825,27 @@ ir_macro_compare(pic_state *pic)
     return pic_false_value();   /* should be an error? */
 
   mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
-  assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
+  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  m = translate(pic, pic_sym(a), mac_env, assoc_box);
-  n = translate(pic, pic_sym(b), mac_env, assoc_box);
+  m = translate(pic, pic_sym(a), mac_env, cxt);
+  n = translate(pic, pic_sym(b), mac_env, cxt);
 
   return pic_bool_value(m == n);
 }
 
 static pic_value
-ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_value assoc_box, pic_value *ir)
+ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct pic_dict *cxt, pic_value *ir)
 {
   if (pic_sym_p(expr)) {
     pic_value r;
-    r = pic_sym_value(translate(pic, pic_sym(expr), use_env, assoc_box));
+    r = pic_sym_value(translate(pic, pic_sym(expr), use_env, cxt));
     *ir = pic_acons(pic, r, expr, *ir);
     return r;
   }
   else if (pic_pair_p(expr)) {
     return pic_cons(pic,
-                    ir_macro_wrap(pic, pic_car(pic, expr), use_env, assoc_box, ir),
-                    ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, assoc_box, ir));
+                    ir_macro_wrap(pic, pic_car(pic, expr), use_env, cxt, ir),
+                    ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, cxt, ir));
   }
   else {
     return expr;
@@ -856,19 +853,19 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu
 }
 
 static pic_value
-ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_value assoc_box, pic_value *ir)
+ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct pic_dict *cxt, pic_value *ir)
 {
   if (pic_sym_p(expr)) {
     pic_value r;
     if (pic_test(r = pic_assq(pic, expr, *ir))) {
       return pic_cdr(pic, r);
     }
-    return pic_sym_value(translate(pic, pic_sym(expr), mac_env, assoc_box));
+    return pic_sym_value(translate(pic, pic_sym(expr), mac_env, cxt));
   }
   else if (pic_pair_p(expr)) {
     return pic_cons(pic,
-                    ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, assoc_box, ir),
-                    ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, assoc_box, ir));
+                    ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, cxt, ir),
+                    ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, cxt, ir));
   }
   else {
     return expr;
@@ -878,8 +875,9 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_va
 static pic_value
 ir_macro_call(pic_state *pic)
 {
-  pic_value expr, use_env, mac_env, box;
+  pic_value expr, use_env, mac_env;
   struct pic_proc *inject, *compare, *cb;
+  struct pic_dict *cxt;
   pic_value ir = pic_nil_value();
 
   pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
@@ -891,25 +889,25 @@ ir_macro_call(pic_state *pic)
     pic_error(pic, "unexpected type of argument 3");
   }
 
-  box = pic_box(pic, pic_nil_value());
+  cxt = pic_dict_new(pic);
 
   inject = pic_proc_new(pic, ir_macro_inject, "<ir-macro-injecter>");
   pic_proc_cv_init(pic, inject, 3);
   pic_proc_cv_set(pic, inject, 0, use_env);
   pic_proc_cv_set(pic, inject, 1, mac_env);
-  pic_proc_cv_set(pic, inject, 2, box);
+  pic_proc_cv_set(pic, inject, 2, pic_obj_value(cxt));
 
   compare = pic_proc_new(pic, ir_macro_compare, "<ir-macro-comparator>");
   pic_proc_cv_init(pic, compare, 3);
   pic_proc_cv_set(pic, compare, 0, use_env);
   pic_proc_cv_set(pic, compare, 1, mac_env);
-  pic_proc_cv_set(pic, compare, 2, box);
+  pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
 
   cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
 
-  expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), box, &ir);
+  expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), cxt, &ir);
   expr = pic_apply3(pic, cb, expr, pic_obj_value(inject), pic_obj_value(compare));
-  expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), box, &ir);
+  expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), cxt, &ir);
 
   return expr;
 }

From 601b54ba1f42c2b15d467c8c025fa055eb00673c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 20:06:08 +0900
Subject: [PATCH 091/216] cosmetic changes

---
 src/macro.c | 108 ++++++++++++++++++++++++++--------------------------
 1 file changed, 54 insertions(+), 54 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 0cb7349f..3181dd22 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -11,31 +11,7 @@
 #include "picrin/error.h"
 #include "picrin/dict.h"
 
-struct pic_senv *
-pic_null_syntactic_environment(pic_state *pic)
-{
-  struct pic_senv *senv;
-
-  senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
-  senv->up = NULL;
-  xh_init_int(&senv->renames, sizeof(pic_sym));
-
-  pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY);
-  pic_define_syntactic_keyword(pic, senv, pic->sIMPORT);
-  pic_define_syntactic_keyword(pic, senv, pic->sEXPORT);
-
-  return senv;
-}
-
-void
-pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym)
-{
-  pic_put_rename(pic, senv, sym, sym);
-
-  if (pic->lib && pic->lib->senv == senv) {
-    pic_export(pic, sym);
-  }
-}
+static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);
 
 pic_sym
 pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
@@ -94,35 +70,6 @@ find_macro(pic_state *pic, pic_sym rename)
   return xh_val(e, struct pic_macro *);
 }
 
-void
-pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
-{
-  pic_sym sym, rename;
-
-  /* symbol registration */
-  sym = pic_intern_cstr(pic, name);
-  rename = pic_add_rename(pic, pic->lib->senv, sym);
-  define_macro(pic, rename, macro, NULL);
-
-  /* auto export! */
-  pic_export(pic, sym);
-}
-
-static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);
-
-static pic_value
-macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value v;
-
-  v = macroexpand_node(pic, expr, senv, cxt);
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, v);
-  return v;
-}
-
 static struct pic_senv *
 push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, struct pic_dict *cxt)
 {
@@ -579,6 +526,19 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
   UNREACHABLE();
 }
 
+static pic_value
+macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+  pic_value v;
+
+  v = macroexpand_node(pic, expr, senv, cxt);
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, v);
+  return v;
+}
+
 pic_value
 pic_macroexpand(pic_state *pic, pic_value expr)
 {
@@ -601,6 +561,46 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   return v;
 }
 
+struct pic_senv *
+pic_null_syntactic_environment(pic_state *pic)
+{
+  struct pic_senv *senv;
+
+  senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
+  senv->up = NULL;
+  xh_init_int(&senv->renames, sizeof(pic_sym));
+
+  pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY);
+  pic_define_syntactic_keyword(pic, senv, pic->sIMPORT);
+  pic_define_syntactic_keyword(pic, senv, pic->sEXPORT);
+
+  return senv;
+}
+
+void
+pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym)
+{
+  pic_put_rename(pic, senv, sym, sym);
+
+  if (pic->lib && pic->lib->senv == senv) {
+    pic_export(pic, sym);
+  }
+}
+
+void
+pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
+{
+  pic_sym sym, rename;
+
+  /* symbol registration */
+  sym = pic_intern_cstr(pic, name);
+  rename = pic_add_rename(pic, pic->lib->senv, sym);
+  define_macro(pic, rename, macro, NULL);
+
+  /* auto export! */
+  pic_export(pic, sym);
+}
+
 static pic_value
 pic_macro_gensym(pic_state *pic)
 {

From 6d20c0e3e01f78a4da09890503563b87268df0a7 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 20:09:42 +0900
Subject: [PATCH 092/216] cosmetic changes again

---
 src/macro.c | 13 ++++++++-----
 1 file changed, 8 insertions(+), 5 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 3181dd22..5259a198 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -389,12 +389,15 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
 static pic_value
 macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
-  struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, cxt);
+  pic_value formal, body;
+  struct pic_senv *in;
 
-  return pic_cons(pic, pic_sym_value(pic->sLAMBDA),
-                  pic_cons(pic,
-                           macroexpand_list(pic, pic_cadr(pic, expr), in, cxt),
-                           macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)));
+  in = push_scope(pic, pic_cadr(pic, expr), senv, cxt);
+
+  formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt);
+  body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt);
+
+  return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body));
 }
 
 static pic_value

From 631926aa96596d83e1b3b1923cb83dcbbde59c49 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 20:19:45 +0900
Subject: [PATCH 093/216] function reorder

---
 src/macro.c | 207 ++++++++++++++++++++++++++--------------------------
 1 file changed, 103 insertions(+), 104 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 5259a198..683c429b 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -128,41 +128,6 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c
   }
 }
 
-static pic_value
-macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, struct pic_dict *cxt)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value v, vs;
-
-  /* macroexpand in order */
-  vs = pic_nil_value();
-  while (pic_pair_p(list)) {
-    v = pic_car(pic, list);
-
-    vs = pic_cons(pic, macroexpand(pic, v, senv, cxt), vs);
-    list = pic_cdr(pic, list);
-
-    pic_gc_arena_restore(pic, ai);
-    pic_gc_protect(pic, vs);
-    pic_gc_protect(pic, list);
-  }
-
-  list = macroexpand(pic, list, senv, cxt);
-
-  /* reverse the result */
-  pic_for_each (v, vs) {
-    list = pic_cons(pic, v, list);
-
-    pic_gc_arena_restore(pic, ai);
-    pic_gc_protect(pic, vs);
-    pic_gc_protect(pic, list);
-  }
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, list);
-  return list;
-}
-
 static pic_value
 macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
@@ -170,37 +135,9 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pi
 }
 
 static pic_value
-macroexpand_deflibrary(pic_state *pic, pic_value expr)
+macroexpand_quote(pic_state *pic, pic_value expr)
 {
-  struct pic_lib *prev = pic->lib;
-  pic_value v;
-
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  pic_make_library(pic, pic_cadr(pic, expr));
-
-  pic_try {
-    pic_in_library(pic, pic_cadr(pic, expr));
-
-    pic_for_each (v, pic_cddr(pic, expr)) {
-      size_t ai = pic_gc_arena_preserve(pic);
-
-      pic_eval(pic, v);
-
-      pic_gc_arena_restore(pic, ai);
-    }
-
-    pic_in_library(pic, prev->name);
-  }
-  pic_catch {
-    /* restores pic->lib even if an error occurs */
-    pic_in_library(pic, prev->name);
-    pic_throw_error(pic, pic->err);
-  }
-
-  return pic_none_value();
+  return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr));
 }
 
 static pic_value
@@ -251,6 +188,39 @@ macroexpand_export(pic_state *pic, pic_value expr)
   return pic_none_value();
 }
 
+static pic_value
+macroexpand_deflibrary(pic_state *pic, pic_value expr)
+{
+  struct pic_lib *prev = pic->lib;
+  pic_value v;
+
+  if (pic_length(pic, expr) < 2) {
+    pic_error(pic, "syntax error");
+  }
+
+  pic_make_library(pic, pic_cadr(pic, expr));
+
+  pic_try {
+    pic_in_library(pic, pic_cadr(pic, expr));
+
+    pic_for_each (v, pic_cddr(pic, expr)) {
+      size_t ai = pic_gc_arena_preserve(pic);
+
+      pic_eval(pic, v);
+
+      pic_gc_arena_restore(pic, ai);
+    }
+
+    pic_in_library(pic, prev->name);
+  }
+  pic_catch {
+    pic_in_library(pic, prev->name);    /* restores pic->lib even if an error occurs */
+    pic_throw_error(pic, pic->err);
+  }
+
+  return pic_none_value();
+}
+
 static pic_value
 macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
@@ -337,6 +307,74 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
   return pic_none_value();
 }
 
+static pic_value
+macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  pic_value v, args;
+
+#if DEBUG
+  puts("before expand-1:");
+  pic_debug(pic, expr);
+  puts("");
+#endif
+
+  if (mac->senv == NULL) { /* legacy macro */
+    args = pic_cdr(pic, expr);
+  }
+  else {
+    args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
+  }
+
+  pic_try {
+    v = pic_apply(pic, mac->proc, args);
+  } pic_catch {
+    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
+  }
+
+#if DEBUG
+  puts("after expand-1:");
+  pic_debug(pic, v);
+  puts("");
+#endif
+
+  return macroexpand(pic, v, senv, cxt);
+}
+
+static pic_value
+macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+  pic_value v, vs;
+
+  /* macroexpand in order */
+  vs = pic_nil_value();
+  while (pic_pair_p(list)) {
+    v = pic_car(pic, list);
+
+    vs = pic_cons(pic, macroexpand(pic, v, senv, cxt), vs);
+    list = pic_cdr(pic, list);
+
+    pic_gc_arena_restore(pic, ai);
+    pic_gc_protect(pic, vs);
+    pic_gc_protect(pic, list);
+  }
+
+  list = macroexpand(pic, list, senv, cxt);
+
+  /* reverse the result */
+  pic_for_each (v, vs) {
+    list = pic_cons(pic, v, list);
+
+    pic_gc_arena_restore(pic, ai);
+    pic_gc_protect(pic, vs);
+    pic_gc_protect(pic, list);
+  }
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, list);
+  return list;
+}
+
 static pic_value
 macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
@@ -400,45 +438,6 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
   return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body));
 }
 
-static pic_value
-macroexpand_quote(pic_state *pic, pic_value expr)
-{
-  return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr));
-}
-
-static pic_value
-macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
-{
-  pic_value v, args;
-
-#if DEBUG
-  puts("before expand-1:");
-  pic_debug(pic, expr);
-  puts("");
-#endif
-
-  if (mac->senv == NULL) { /* legacy macro */
-    args = pic_cdr(pic, expr);
-  }
-  else {
-    args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
-  }
-
-  pic_try {
-    v = pic_apply(pic, mac->proc, args);
-  } pic_catch {
-    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
-  }
-
-#if DEBUG
-  puts("after expand-1:");
-  pic_debug(pic, v);
-  puts("");
-#endif
-
-  return macroexpand(pic, v, senv, cxt);
-}
-
 static pic_value
 macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {

From c57f8a5016c962c5da702f6943434e62ac44e6f5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 20:20:04 +0900
Subject: [PATCH 094/216] add pic_void macro

---
 include/picrin.h | 7 +++++++
 src/macro.c      | 8 ++------
 2 files changed, 9 insertions(+), 6 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index 2bf9f9fd..e6846994 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -127,6 +127,13 @@ void pic_gc_run(pic_state *);
 pic_value pic_gc_protect(pic_state *, pic_value);
 size_t pic_gc_arena_preserve(pic_state *);
 void pic_gc_arena_restore(pic_state *, size_t);
+#define pic_void(exec)                          \
+  pic_void_(GENSYM(ai), exec)
+#define pic_void_(ai,exec) do {                 \
+    size_t ai = pic_gc_arena_preserve(pic);     \
+    exec;                                       \
+    pic_gc_arena_restore(pic, ai);              \
+  } while (0)
 
 pic_state *pic_open(int argc, char *argv[], char **envp);
 void pic_close(pic_state *);
diff --git a/src/macro.c b/src/macro.c
index 683c429b..1328581f 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -204,17 +204,13 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr)
     pic_in_library(pic, pic_cadr(pic, expr));
 
     pic_for_each (v, pic_cddr(pic, expr)) {
-      size_t ai = pic_gc_arena_preserve(pic);
-
-      pic_eval(pic, v);
-
-      pic_gc_arena_restore(pic, ai);
+      pic_void(pic_eval(pic, v));
     }
 
     pic_in_library(pic, prev->name);
   }
   pic_catch {
-    pic_in_library(pic, prev->name);    /* restores pic->lib even if an error occurs */
+    pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */
     pic_throw_error(pic, pic->err);
   }
 

From 6cf4fe942a99f1a4806d30b5a45dbaaff1be308a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 20:32:26 +0900
Subject: [PATCH 095/216] rewrite iteration with recursion. since we have
 variable-length arena now, it is no longer required to avoid big arena
 consumption.

---
 src/macro.c | 36 ++++++++++--------------------------
 1 file changed, 10 insertions(+), 26 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 1328581f..541e0c92 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -337,38 +337,22 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
 }
 
 static pic_value
-macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt)
 {
   size_t ai = pic_gc_arena_preserve(pic);
-  pic_value v, vs;
+  pic_value x, head, tail;
 
-  /* macroexpand in order */
-  vs = pic_nil_value();
-  while (pic_pair_p(list)) {
-    v = pic_car(pic, list);
-
-    vs = pic_cons(pic, macroexpand(pic, v, senv, cxt), vs);
-    list = pic_cdr(pic, list);
-
-    pic_gc_arena_restore(pic, ai);
-    pic_gc_protect(pic, vs);
-    pic_gc_protect(pic, list);
-  }
-
-  list = macroexpand(pic, list, senv, cxt);
-
-  /* reverse the result */
-  pic_for_each (v, vs) {
-    list = pic_cons(pic, v, list);
-
-    pic_gc_arena_restore(pic, ai);
-    pic_gc_protect(pic, vs);
-    pic_gc_protect(pic, list);
+  if (pic_pair_p(obj)) {
+    head = macroexpand(pic, pic_car(pic, obj), senv, cxt);
+    tail = macroexpand_list(pic, pic_cdr(pic, obj), senv, cxt);
+    x = pic_cons(pic, head, tail);
+  } else {
+    x = macroexpand(pic, obj, senv, cxt);
   }
 
   pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, list);
-  return list;
+  pic_gc_protect(pic, x);
+  return x;
 }
 
 static pic_value

From e08ec23a9fca75d8a1f19b955cc9e19aa6dee91a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 20:39:34 +0900
Subject: [PATCH 096/216] s/formals/formal/g

---
 src/macro.c | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 541e0c92..2c800cc3 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -359,19 +359,19 @@ static pic_value
 macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_sym sym;
-  pic_value formals;
+  pic_value formal;
 
   if (pic_length(pic, expr) < 2) {
     pic_error(pic, "syntax error");
   }
 
-  formals = pic_cadr(pic, expr);
-  if (pic_pair_p(formals)) {
-    struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, cxt);
+  formal = pic_cadr(pic, expr);
+  if (pic_pair_p(formal)) {
+    struct pic_senv *in = push_scope(pic, pic_cdr(pic, formal), senv, cxt);
     pic_value a;
 
     /* defined symbol */
-    a = pic_car(pic, formals);
+    a = pic_car(pic, formal);
     if (! pic_sym_p(a)) {
       a = macroexpand(pic, a, senv, cxt);
     }
@@ -390,13 +390,13 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
                              macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)));
   }
 
-  if (! pic_sym_p(formals)) {
-    formals = macroexpand(pic, formals, senv, cxt);
+  if (! pic_sym_p(formal)) {
+    formal = macroexpand(pic, formal, senv, cxt);
   }
-  if (! pic_sym_p(formals)) {
+  if (! pic_sym_p(formal)) {
     pic_error(pic, "binding to non-symbol object");
   }
-  sym = pic_sym(formals);
+  sym = pic_sym(formal);
   if (! pic_find_rename(pic, senv, sym, NULL)) {
     pic_add_rename(pic, senv, sym);
   }

From 1989a972cbd537e31df90690837fa6c910647b27 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 21:01:30 +0900
Subject: [PATCH 097/216] refactor macroexpand_define. make use of
 macroexpand_lambda function

---
 src/macro.c | 87 +++++++++++++++++++++++------------------------------
 1 file changed, 38 insertions(+), 49 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 2c800cc3..d9782f60 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -355,55 +355,6 @@ macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pi
   return x;
 }
 
-static pic_value
-macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
-{
-  pic_sym sym;
-  pic_value formal;
-
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  formal = pic_cadr(pic, expr);
-  if (pic_pair_p(formal)) {
-    struct pic_senv *in = push_scope(pic, pic_cdr(pic, formal), senv, cxt);
-    pic_value a;
-
-    /* defined symbol */
-    a = pic_car(pic, formal);
-    if (! pic_sym_p(a)) {
-      a = macroexpand(pic, a, senv, cxt);
-    }
-    if (! pic_sym_p(a)) {
-      pic_error(pic, "binding to non-symbol object");
-    }
-    sym = pic_sym(a);
-    if (! pic_find_rename(pic, senv, sym, NULL)) {
-      pic_add_rename(pic, senv, sym);
-    }
-
-    /* binding value */
-    return pic_cons(pic, pic_sym_value(pic->sDEFINE),
-                    pic_cons(pic,
-                             macroexpand_list(pic, pic_cadr(pic, expr), in, cxt),
-                             macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)));
-  }
-
-  if (! pic_sym_p(formal)) {
-    formal = macroexpand(pic, formal, senv, cxt);
-  }
-  if (! pic_sym_p(formal)) {
-    pic_error(pic, "binding to non-symbol object");
-  }
-  sym = pic_sym(formal);
-  if (! pic_find_rename(pic, senv, sym, NULL)) {
-    pic_add_rename(pic, senv, sym);
-  }
-
-  return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt));
-}
-
 static pic_value
 macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
@@ -418,6 +369,44 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
   return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body));
 }
 
+static pic_value
+macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  pic_sym sym;
+  pic_value formal, body, var, val;
+
+  if (pic_length(pic, expr) < 2) {
+    pic_error(pic, "syntax error");
+  }
+
+  formal = pic_cadr(pic, expr);
+  if (pic_pair_p(formal)) {
+    var = pic_car(pic, formal);
+  } else {
+    if (pic_length(pic, expr) != 3) {
+      pic_error(pic, "syntax error");
+    }
+    var = formal;
+  }
+  if (! pic_sym_p(var)) {
+    var = macroexpand(pic, var, senv, cxt);
+  }
+  if (! pic_sym_p(var)) {
+    pic_error(pic, "binding to non-symbol object");
+  }
+  sym = pic_sym(var);
+  if (! pic_find_rename(pic, senv, sym, NULL)) {
+    pic_add_rename(pic, senv, sym);
+  }
+  body = pic_cddr(pic, expr);
+  if (pic_pair_p(formal)) {
+    val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv, cxt);
+  } else {
+    val = macroexpand(pic, pic_car(pic, body), senv, cxt);
+  }
+  return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val);
+}
+
 static pic_value
 macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {

From 730cfc860147e3bd6c943467c88807c3e3104244 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 21:05:57 +0900
Subject: [PATCH 098/216] refactor macroexpand_lambda

---
 src/macro.c | 67 +++++++++++++++++++++++++----------------------------
 1 file changed, 31 insertions(+), 36 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index d9782f60..6af79e51 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -11,8 +11,6 @@
 #include "picrin/error.h"
 #include "picrin/dict.h"
 
-static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);
-
 pic_sym
 pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
 {
@@ -70,39 +68,6 @@ find_macro(pic_state *pic, pic_sym rename)
   return xh_val(e, struct pic_macro *);
 }
 
-static struct pic_senv *
-push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, struct pic_dict *cxt)
-{
-  struct pic_senv *senv;
-  pic_value a;
-
-  senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
-  senv->up = up;
-  xh_init_int(&senv->renames, sizeof(pic_sym));
-
-  for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) {
-    pic_value v = pic_car(pic, a);
-
-    if (! pic_sym_p(v)) {
-      v = macroexpand(pic, v, up, cxt);
-    }
-    if (! pic_sym_p(v)) {
-      pic_error(pic, "syntax error");
-    }
-    pic_add_rename(pic, senv, pic_sym(v));
-  }
-  if (! pic_sym_p(a)) {
-    a = macroexpand(pic, a, up, cxt);
-  }
-  if (pic_sym_p(a)) {
-    pic_add_rename(pic, senv, pic_sym(a));
-  }
-  else if (! pic_nil_p(a)) {
-    pic_error(pic, "syntax error");
-  }
-  return senv;
-}
-
 static pic_sym
 translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
@@ -128,6 +93,8 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c
   }
 }
 
+static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);
+
 static pic_value
 macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
@@ -360,8 +327,36 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
 {
   pic_value formal, body;
   struct pic_senv *in;
+  pic_value a;
 
-  in = push_scope(pic, pic_cadr(pic, expr), senv, cxt);
+  if (pic_length(pic, expr) < 2) {
+    pic_error(pic, "syntax error");
+  }
+
+  in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
+  in->up = senv;
+  xh_init_int(&in->renames, sizeof(pic_sym));
+
+  for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
+    pic_value v = pic_car(pic, a);
+
+    if (! pic_sym_p(v)) {
+      v = macroexpand(pic, v, senv, cxt);
+    }
+    if (! pic_sym_p(v)) {
+      pic_error(pic, "syntax error");
+    }
+    pic_add_rename(pic, in, pic_sym(v));
+  }
+  if (! pic_sym_p(a)) {
+    a = macroexpand(pic, a, senv, cxt);
+  }
+  if (pic_sym_p(a)) {
+    pic_add_rename(pic, in, pic_sym(a));
+  }
+  else if (! pic_nil_p(a)) {
+    pic_error(pic, "syntax error");
+  }
 
   formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt);
   body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt);

From 6c45bb3c5d2c777760c146154de96193a8fd3b00 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 22:36:30 +0900
Subject: [PATCH 099/216] support let-syntax

---
 include/picrin.h |   1 +
 src/init.c       |   2 +
 src/macro.c      | 284 +++++++++++++++++++++++++++--------------------
 src/state.c      |   2 +
 4 files changed, 170 insertions(+), 119 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index e6846994..6b6629a5 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -81,6 +81,7 @@ typedef struct {
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
   pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
+  pic_sym sLET_SYNTAX, sLETREC_SYNTAX;
   pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
   pic_sym sCONS, sCAR, sCDR, sNILP;
   pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
diff --git a/src/init.c b/src/init.c
index 5770d819..b6051a3f 100644
--- a/src/init.c
+++ b/src/init.c
@@ -75,6 +75,8 @@ pic_init_core(pic_state *pic)
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX);
 
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
diff --git a/src/macro.c b/src/macro.c
index 6af79e51..c9da6aee 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -184,125 +184,6 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr)
   return pic_none_value();
 }
 
-static pic_value
-macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
-{
-  pic_value var, val;
-  pic_sym sym, rename;
-
-  if (pic_length(pic, expr) != 3) {
-    pic_error(pic, "syntax error");
-  }
-
-  var = pic_cadr(pic, expr);
-  if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv, cxt);
-  }
-  if (! pic_sym_p(var)) {
-    pic_error(pic, "binding to non-symbol object");
-  }
-  sym = pic_sym(var);
-  if (! pic_find_rename(pic, senv, sym, &rename)) {
-    rename = pic_add_rename(pic, senv, sym);
-  }
-
-  val = pic_cadr(pic, pic_cdr(pic, expr));
-
-  pic_try {
-    val = pic_eval(pic, val);
-  } pic_catch {
-    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
-  }
-
-  if (! pic_proc_p(val)) {
-    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
-  }
-
-  define_macro(pic, rename, pic_proc_ptr(val), senv);
-
-  return pic_none_value();
-}
-
-static pic_value
-macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  pic_value var, val;
-  pic_sym sym, rename;
-
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  var = pic_car(pic, pic_cdr(pic, expr));
-  if (pic_pair_p(var)) {
-    /* FIXME: unhygienic */
-    val = pic_cons(pic, pic_sym_value(pic->sLAMBDA),
-                   pic_cons(pic, pic_cdr(pic, var),
-                            pic_cdr(pic, pic_cdr(pic, expr))));
-    var = pic_car(pic, var);
-  }
-  else {
-    if (pic_length(pic, expr) != 3) {
-      pic_error(pic, "syntax_error");
-    }
-    val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
-  }
-  if (! pic_sym_p(var)) {
-    pic_error(pic, "syntax error");
-  }
-  sym = pic_sym(var);
-  if (! pic_find_rename(pic, senv, sym, &rename)) {
-    rename = pic_add_rename(pic, senv, sym);
-  }
-
-  pic_try {
-    val = pic_eval(pic, val);
-  } pic_catch {
-    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
-  }
-
-  if (! pic_proc_p(val)) {
-    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
-  }
-
-  define_macro(pic, rename, pic_proc_ptr(val), NULL);
-
-  return pic_none_value();
-}
-
-static pic_value
-macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
-{
-  pic_value v, args;
-
-#if DEBUG
-  puts("before expand-1:");
-  pic_debug(pic, expr);
-  puts("");
-#endif
-
-  if (mac->senv == NULL) { /* legacy macro */
-    args = pic_cdr(pic, expr);
-  }
-  else {
-    args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
-  }
-
-  pic_try {
-    v = pic_apply(pic, mac->proc, args);
-  } pic_catch {
-    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
-  }
-
-#if DEBUG
-  puts("after expand-1:");
-  pic_debug(pic, v);
-  puts("");
-#endif
-
-  return macroexpand(pic, v, senv, cxt);
-}
-
 static pic_value
 macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt)
 {
@@ -402,6 +283,165 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
   return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val);
 }
 
+static pic_value
+macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  pic_value var, val;
+  pic_sym sym, rename;
+
+  if (pic_length(pic, expr) != 3) {
+    pic_error(pic, "syntax error");
+  }
+
+  var = pic_cadr(pic, expr);
+  if (! pic_sym_p(var)) {
+    var = macroexpand(pic, var, senv, cxt);
+  }
+  if (! pic_sym_p(var)) {
+    pic_error(pic, "binding to non-symbol object");
+  }
+  sym = pic_sym(var);
+  if (! pic_find_rename(pic, senv, sym, &rename)) {
+    rename = pic_add_rename(pic, senv, sym);
+  }
+
+  val = pic_cadr(pic, pic_cdr(pic, expr));
+
+  pic_try {
+    val = pic_eval(pic, val);
+  } pic_catch {
+    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
+  }
+
+  if (! pic_proc_p(val)) {
+    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
+  }
+
+  define_macro(pic, rename, pic_proc_ptr(val), senv);
+
+  return pic_none_value();
+}
+
+static pic_value
+macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
+{
+  pic_value var, val;
+  pic_sym sym, rename;
+
+  if (pic_length(pic, expr) < 2) {
+    pic_error(pic, "syntax error");
+  }
+
+  var = pic_car(pic, pic_cdr(pic, expr));
+  if (pic_pair_p(var)) {
+    /* FIXME: unhygienic */
+    val = pic_cons(pic, pic_sym_value(pic->sLAMBDA),
+                   pic_cons(pic, pic_cdr(pic, var),
+                            pic_cdr(pic, pic_cdr(pic, expr))));
+    var = pic_car(pic, var);
+  }
+  else {
+    if (pic_length(pic, expr) != 3) {
+      pic_error(pic, "syntax_error");
+    }
+    val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
+  }
+  if (! pic_sym_p(var)) {
+    pic_error(pic, "syntax error");
+  }
+  sym = pic_sym(var);
+  if (! pic_find_rename(pic, senv, sym, &rename)) {
+    rename = pic_add_rename(pic, senv, sym);
+  }
+
+  pic_try {
+    val = pic_eval(pic, val);
+  } pic_catch {
+    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
+  }
+
+  if (! pic_proc_p(val)) {
+    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
+  }
+
+  define_macro(pic, rename, pic_proc_ptr(val), NULL);
+
+  return pic_none_value();
+}
+
+static pic_value
+macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  struct pic_senv *in;
+  pic_value formal, v, var, val;
+  pic_sym sym, rename;
+
+  in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
+  in->up = senv;
+  xh_init_int(&in->renames, sizeof(pic_sym));
+
+  if (pic_length(pic, expr) < 2) {
+    pic_error(pic, "syntax error");
+  }
+
+  formal = pic_cadr(pic, expr);
+  if (! pic_list_p(formal)) {
+    pic_error(pic, "syntax error");
+  }
+  pic_for_each (v, formal) {
+    var = pic_car(pic, v);
+    if (! pic_sym_p(var)) {
+      var = macroexpand(pic, var, senv, cxt);
+    }
+    if (! pic_sym_p(var)) {
+      pic_error(pic, "binding to non-symbol object");
+    }
+    sym = pic_sym(var);
+    if (! pic_find_rename(pic, in, sym, &rename)) {
+      rename = pic_add_rename(pic, in, sym);
+    }
+    val = pic_eval(pic, pic_cadr(pic, v));
+    if (! pic_proc_p(val)) {
+      pic_errorf(pic, "macro definition \"~s\" evaluated to non-procedure object", var);
+    }
+    define_macro(pic, rename, pic_proc_ptr(val), senv);
+  }
+  return pic_cons(pic, pic_sym_value(pic->sBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt));
+}
+
+static pic_value
+macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  pic_value v, args;
+
+#if DEBUG
+  puts("before expand-1:");
+  pic_debug(pic, expr);
+  puts("");
+#endif
+
+  if (mac->senv == NULL) { /* legacy macro */
+    args = pic_cdr(pic, expr);
+  }
+  else {
+    args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
+  }
+
+  pic_try {
+    v = pic_apply(pic, mac->proc, args);
+  } pic_catch {
+    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
+  }
+
+#if DEBUG
+  puts("after expand-1:");
+  pic_debug(pic, v);
+  puts("");
+#endif
+
+  return macroexpand(pic, v, senv, cxt);
+}
+
 static pic_value
 macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
@@ -445,6 +485,12 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
       else if (tag == pic->sDEFINE_MACRO) {
         return macroexpand_defmacro(pic, expr, senv);
       }
+      else if (tag == pic->sLET_SYNTAX) {
+        return macroexpand_let_syntax(pic, expr, senv, cxt);
+      }
+      /* else if (tag == pic->sLETREC_SYNTAX) { */
+      /*   return macroexpand_letrec_syntax(pic, expr, senv, cxt); */
+      /* } */
       else if (tag == pic->sLAMBDA) {
         return macroexpand_lambda(pic, expr, senv, cxt);
       }
diff --git a/src/state.c b/src/state.c
index 63a25254..9db4986b 100644
--- a/src/state.c
+++ b/src/state.c
@@ -96,6 +96,8 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
   register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
   register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
+  register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
+  register_core_symbol(pic, sLETREC_SYNTAX, "letrec-syntax");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
   register_core_symbol(pic, sEXPORT, "export");

From fda89b16048f82b2768c08df80c22f75ade1b458 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 13 Jul 2014 22:51:22 +0900
Subject: [PATCH 100/216] [bugfix] broken hygiene of cond expression

---
 piclib/built-in.scm | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index e2131ab2..02b447fc 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -84,9 +84,9 @@
                  (if (if (>= (length (car clauses)) 2)
                          (compare (r '=>) (cadar clauses))
                          #f)
-                     (list (r 'let) (list (list 'x (caar clauses)))
-                           (list (r 'if) 'x
-                                 (list (caddar clauses) 'x)
+                     (list (r 'let) (list (list (r 'x) (caar clauses)))
+                           (list (r 'if) (r 'x)
+                                 (list (caddar clauses) (r 'x))
                                  (cons (r 'cond) (cdr clauses))))
                      (list (r 'if) (caar clauses)
                            (cons (r 'begin) (cdar clauses))

From 5faa7cd46d5a9320c4cda221acdadc1088d191e4 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 14 Jul 2014 10:08:11 +0900
Subject: [PATCH 101/216] leave core syntax keywords renamed

---
 include/picrin.h       |  5 +++++
 include/picrin/macro.h |  2 +-
 src/codegen.c          | 16 ++++++++--------
 src/init.c             | 18 +++++++++---------
 src/macro.c            | 38 +++++++++++++++++++-------------------
 src/state.c            | 20 ++++++++++++++++++++
 6 files changed, 62 insertions(+), 37 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index 6b6629a5..2406e48f 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -87,6 +87,11 @@ typedef struct {
   pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
   pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
 
+  pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
+  pic_sym rDEFINE_SYNTAX, rDEFINE_MACRO;
+  pic_sym rLET_SYNTAX, rLETREC_SYNTAX;
+  pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
+
   xhash syms;                   /* name to symbol */
   xhash sym_names;              /* symbol to name */
   int sym_cnt;
diff --git a/include/picrin/macro.h b/include/picrin/macro.h
index 151eb144..b733a5fe 100644
--- a/include/picrin/macro.h
+++ b/include/picrin/macro.h
@@ -42,7 +42,7 @@ pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym);
 bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */);
 void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym);
 
-void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym);
+void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym);
 
 #if defined(__cplusplus)
 }
diff --git a/src/codegen.c b/src/codegen.c
index 8dd84b7a..a4d7e25b 100644
--- a/src/codegen.c
+++ b/src/codegen.c
@@ -366,7 +366,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v
       : pic_false_value();
 
     /* To know what kind of local variables are defined, analyze body at first. */
-    body = analyze(state, pic_cons(pic, pic_sym_value(pic->sBEGIN), body_exprs), true);
+    body = analyze(state, pic_cons(pic, pic_sym_value(pic->rBEGIN), body_exprs), true);
 
     locals = pic_nil_value();
     for (i = scope->locals.size; i > 0; --i) {
@@ -535,7 +535,7 @@ analyze_quote(analyze_state *state, pic_value obj)
   if (pic_length(pic, obj) != 2) {
     pic_error(pic, "syntax error");
   }
-  return obj;
+  return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1));
 }
 
 #define ARGC_ASSERT_GE(n) do {				\
@@ -727,22 +727,22 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
     if (pic_sym_p(proc)) {
       pic_sym sym = pic_sym(proc);
 
-      if (sym == pic->sDEFINE) {
+      if (sym == pic->rDEFINE) {
         return analyze_define(state, obj);
       }
-      else if (sym == pic->sLAMBDA) {
+      else if (sym == pic->rLAMBDA) {
         return analyze_lambda(state, obj);
       }
-      else if (sym == pic->sIF) {
+      else if (sym == pic->rIF) {
         return analyze_if(state, obj, tailpos);
       }
-      else if (sym == pic->sBEGIN) {
+      else if (sym == pic->rBEGIN) {
         return analyze_begin(state, obj, tailpos);
       }
-      else if (sym == pic->sSETBANG) {
+      else if (sym == pic->rSETBANG) {
         return analyze_set(state, obj);
       }
-      else if (sym == pic->sQUOTE) {
+      else if (sym == pic->rQUOTE) {
         return analyze_quote(state, obj);
       }
       else if (sym == state->rCONS) {
diff --git a/src/init.c b/src/init.c
index b6051a3f..4fdba1e0 100644
--- a/src/init.c
+++ b/src/init.c
@@ -68,15 +68,15 @@ pic_init_core(pic_state *pic)
 
     /* load core syntaces */
     pic->lib->senv = pic_null_syntactic_environment(pic);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE, pic->rDEFINE);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG, pic->rSETBANG);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE, pic->rQUOTE);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA, pic->rLAMBDA);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX, pic->rLETREC_SYNTAX);
 
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
diff --git a/src/macro.c b/src/macro.c
index c9da6aee..5ac2e4dc 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -104,7 +104,7 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pi
 static pic_value
 macroexpand_quote(pic_state *pic, pic_value expr)
 {
-  return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr));
+  return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr));
 }
 
 static pic_value
@@ -242,7 +242,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
   formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt);
   body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt);
 
-  return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body));
+  return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body));
 }
 
 static pic_value
@@ -280,7 +280,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
   } else {
     val = macroexpand(pic, pic_car(pic, body), senv, cxt);
   }
-  return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val);
+  return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val);
 }
 
 static pic_value
@@ -406,7 +406,7 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st
     }
     define_macro(pic, rename, pic_proc_ptr(val), senv);
   }
-  return pic_cons(pic, pic_sym_value(pic->sBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt));
+  return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt));
 }
 
 static pic_value
@@ -470,34 +470,34 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
     if (pic_sym_p(car)) {
       pic_sym tag = pic_sym(car);
 
-      if (tag == pic->sDEFINE_LIBRARY) {
+      if (tag == pic->rDEFINE_LIBRARY) {
         return macroexpand_deflibrary(pic, expr);
       }
-      else if (tag == pic->sIMPORT) {
+      else if (tag == pic->rIMPORT) {
         return macroexpand_import(pic, expr);
       }
-      else if (tag == pic->sEXPORT) {
+      else if (tag == pic->rEXPORT) {
         return macroexpand_export(pic, expr);
       }
-      else if (tag == pic->sDEFINE_SYNTAX) {
+      else if (tag == pic->rDEFINE_SYNTAX) {
         return macroexpand_defsyntax(pic, expr, senv, cxt);
       }
-      else if (tag == pic->sDEFINE_MACRO) {
+      else if (tag == pic->rDEFINE_MACRO) {
         return macroexpand_defmacro(pic, expr, senv);
       }
-      else if (tag == pic->sLET_SYNTAX) {
+      else if (tag == pic->rLET_SYNTAX) {
         return macroexpand_let_syntax(pic, expr, senv, cxt);
       }
       /* else if (tag == pic->sLETREC_SYNTAX) { */
       /*   return macroexpand_letrec_syntax(pic, expr, senv, cxt); */
       /* } */
-      else if (tag == pic->sLAMBDA) {
+      else if (tag == pic->rLAMBDA) {
         return macroexpand_lambda(pic, expr, senv, cxt);
       }
-      else if (tag == pic->sDEFINE) {
+      else if (tag == pic->rDEFINE) {
         return macroexpand_define(pic, expr, senv, cxt);
       }
-      else if (tag == pic->sQUOTE) {
+      else if (tag == pic->rQUOTE) {
         return macroexpand_quote(pic, expr);
       }
 
@@ -582,17 +582,17 @@ pic_null_syntactic_environment(pic_state *pic)
   senv->up = NULL;
   xh_init_int(&senv->renames, sizeof(pic_sym));
 
-  pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY);
-  pic_define_syntactic_keyword(pic, senv, pic->sIMPORT);
-  pic_define_syntactic_keyword(pic, senv, pic->sEXPORT);
+  pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY);
+  pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT);
+  pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT);
 
   return senv;
 }
 
 void
-pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym)
+pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym)
 {
-  pic_put_rename(pic, senv, sym, sym);
+  pic_put_rename(pic, senv, sym, rsym);
 
   if (pic->lib && pic->lib->senv == senv) {
     pic_export(pic, sym);
@@ -944,7 +944,7 @@ pic_init_macro(pic_state *pic)
   pic_deflibrary ("(picrin macro)") {
 
     /* export define-macro syntax */
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->rDEFINE_MACRO);
 
     pic_defun(pic, "gensym", pic_macro_gensym);
     pic_defun(pic, "macroexpand", pic_macro_macroexpand);
diff --git a/src/state.c b/src/state.c
index 9db4986b..cb01c754 100644
--- a/src/state.c
+++ b/src/state.c
@@ -118,6 +118,26 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sNOT, "not");
   pic_gc_arena_restore(pic, ai);
 
+#define register_renamed_symbol(pic,slot,name) do {              \
+    pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name));     \
+  } while (0)
+
+  ai = pic_gc_arena_preserve(pic);
+  register_renamed_symbol(pic, rDEFINE, "define");
+  register_renamed_symbol(pic, rLAMBDA, "lambda");
+  register_renamed_symbol(pic, rIF, "if");
+  register_renamed_symbol(pic, rBEGIN, "begin");
+  register_renamed_symbol(pic, rSETBANG, "set!");
+  register_renamed_symbol(pic, rQUOTE, "quote");
+  register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
+  register_renamed_symbol(pic, rDEFINE_MACRO, "define-macro");
+  register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax");
+  register_renamed_symbol(pic, rLETREC_SYNTAX, "letrec-syntax");
+  register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
+  register_renamed_symbol(pic, rIMPORT, "import");
+  register_renamed_symbol(pic, rEXPORT, "export");
+  pic_gc_arena_restore(pic, ai);
+
   pic_init_core(pic);
 
   /* set library */

From 729162b69f43c794ff0347472ed708fac46810c1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 14 Jul 2014 10:09:23 +0900
Subject: [PATCH 102/216] unlock let-synatx test

---
 t/r7rs-tests.scm | 26 +++++++++++++-------------
 1 file changed, 13 insertions(+), 13 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index da0a1cbb..ead83b4a 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -440,20 +440,20 @@
 
 (test-begin "4.3 Macros")
 
-;; (test 'now (let-syntax
-;;                ((when (syntax-rules ()
-;;                         ((when test stmt1 stmt2 ...)
-;;                          (if test
-;;                              (begin stmt1
-;;                                     stmt2 ...))))))
-;;              (let ((if #t))
-;;                (when if (set! if 'now))
-;;                if)))
+(test 'now (let-syntax
+               ((when (syntax-rules ()
+                        ((when test stmt1 stmt2 ...)
+                         (if test
+                             (begin stmt1
+                                    stmt2 ...))))))
+             (let ((if #t))
+               (when if (set! if 'now))
+               if)))
 
-;; (test 'outer (let ((x 'outer))
-;;   (let-syntax ((m (syntax-rules () ((m) x))))
-;;     (let ((x 'inner))
-;;       (m)))))
+(test 'outer (let ((x 'outer))
+  (let-syntax ((m (syntax-rules () ((m) x))))
+    (let ((x 'inner))
+      (m)))))
 
 ;; (test 7 (letrec-syntax
 ;;   ((my-or (syntax-rules ()

From bb427cf27579e58b26cc4bdd433bdc97a155958f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 13:42:19 +0900
Subject: [PATCH 103/216] style fix

---
 src/bool.c | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/src/bool.c b/src/bool.c
index bb4fae82..fc00554d 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -28,11 +28,11 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
     size_t i;
     struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y);
 
-    if(u->len != v->len){
+    if (u->len != v->len) {
       return false;
     }
-    for(i = 0; i < u->len; ++i){
-      if(u->data[i] != v->data[i])
+    for (i = 0; i < u->len; ++i) {
+      if (u->data[i] != v->data[i])
         return false;
     }
     return true;
@@ -41,11 +41,11 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
     size_t i;
     struct pic_vector *u = pic_vec_ptr(x), *v = pic_vec_ptr(y);
 
-    if(u->len != v->len){
+    if (u->len != v->len) {
       return false;
     }
-    for(i = 0; i < u->len; ++i){
-      if(! pic_equal_p(pic, u->data[i], v->data[i]))
+    for (i = 0; i < u->len; ++i) {
+      if (! pic_equal_p(pic, u->data[i], v->data[i]))
         return false;
     }
     return true;

From 1d5fa803aacee4086ab2bcb539a3dc66b23a2317 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 17:51:27 +0900
Subject: [PATCH 104/216] add case-lambda

---
 piclib/built-in.scm | 45 +++++++++++++++++++++++++++++++++++++++++
 t/r7rs-tests.scm    | 49 ++++++++++++++++++++++-----------------------
 2 files changed, 69 insertions(+), 25 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 02b447fc..36e2ab29 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -1397,3 +1397,48 @@
 
 (import (picrin syntax-rules))
 (export syntax-rules)
+
+(define-library (scheme case-lambda)
+  (import (scheme base))
+
+  (define-syntax case-lambda
+    (syntax-rules ()
+      ((case-lambda
+        (?a1 ?e1 ...)
+        ?clause1 ...)
+       (lambda args
+         (let ((l (length args)))
+           (case-lambda "CLAUSE" args l
+                        (?a1 ?e1 ...)
+                        ?clause1 ...))))
+      ((case-lambda "CLAUSE" ?args ?l
+                    ((?a1 ...) ?e1 ...)
+                    ?clause1 ...)
+       (if (= ?l (length '(?a1 ...)))
+           (apply (lambda (?a1 ...) ?e1 ...) ?args)
+           (case-lambda "CLAUSE" ?args ?l
+                        ?clause1 ...)))
+      ((case-lambda "CLAUSE" ?args ?l
+                    ((?a1 . ?ar) ?e1 ...)
+                    ?clause1 ...)
+       (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
+                    ?clause1 ...))
+      ((case-lambda "CLAUSE" ?args ?l
+                    (?a1 ?e1 ...)
+                    ?clause1 ...)
+       (let ((?a1 ?args))
+         ?e1 ...))
+      ((case-lambda "CLAUSE" ?args ?l)
+       (error "Wrong number of arguments to CASE-LAMBDA."))
+      ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
+                    ?clause1 ...)
+       (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...)
+                    ?clause1 ...))
+      ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...)
+                    ?clause1 ...)
+       (if (>= ?l ?k)
+           (apply (lambda ?al ?e1 ...) ?args)
+           (case-lambda "CLAUSE" ?args ?l
+                        ?clause1 ...)))))
+
+  (export case-lambda))
diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index ead83b4a..802d7dcc 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -36,8 +36,7 @@
         (scheme write)
 ;        (scheme eval)
         (scheme process-context)
-;        (scheme case-lambda)
-        )
+        (scheme case-lambda))
 
 ;; R7RS test suite.  Covers all procedures and syntax in the small
 ;; language except `delete-file'.  Currently assumes full-unicode
@@ -409,32 +408,32 @@
 (test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) )
 (test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4)))
 
-;; (define plus
-;;   (case-lambda
-;;    (() 0)
-;;    ((x) x)
-;;    ((x y) (+ x y))
-;;    ((x y z) (+ (+ x y) z))
-;;    (args (apply + args))))
+(define plus
+  (case-lambda
+   (() 0)
+   ((x) x)
+   ((x y) (+ x y))
+   ((x y z) (+ (+ x y) z))
+   (args (apply + args))))
 
-;; (test 0 (plus))
-;; (test 1 (plus 1))
-;; (test 3 (plus 1 2))
-;; (test 6 (plus 1 2 3))
-;; (test 10 (plus 1 2 3 4))
+(test 0 (plus))
+(test 1 (plus 1))
+(test 3 (plus 1 2))
+(test 6 (plus 1 2 3))
+(test 10 (plus 1 2 3 4))
 
-;; (define mult
-;;   (case-lambda
-;;    (() 1)
-;;    ((x) x)
-;;    ((x y) (* x y))
-;;    ((x y . z) (apply mult (* x y) z))))
+(define mult
+  (case-lambda
+   (() 1)
+   ((x) x)
+   ((x y) (* x y))
+   ((x y . z) (apply mult (* x y) z))))
 
-;; (test 1 (mult))
-;; (test 1 (mult 1))
-;; (test 2 (mult 1 2))
-;; (test 6 (mult 1 2 3))
-;; (test 24 (mult 1 2 3 4))
+(test 1 (mult))
+(test 1 (mult 1))
+(test 2 (mult 1 2))
+(test 6 (mult 1 2 3))
+(test 24 (mult 1 2 3 4))
 
 (test-end)
 

From 6c68955dee479a869067eec9509d4adfdf7c6145 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 17:58:26 +0900
Subject: [PATCH 105/216] unlock tests about rational number literals

---
 t/r7rs-tests.scm | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 802d7dcc..8eeac60b 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -637,11 +637,11 @@
 ;; (test #t (real? #e1e10))
 (test #t (real? +inf.0))
 (test #f (rational? -inf.0))
-;; (test #t (rational? 6/10))
-;; (test #t (rational? 6/3))
+(test #t (rational? 6/10))
+(test #t (rational? 6/3))
 ;; (test #t (integer? 3+0i))
 (test #t (integer? 3.0))
-;; (test #t (integer? 8/4))
+(test #t (integer? 8/4))
 
 (test #f (exact? 3.0))
 ;; (test #t (exact? #e3.0))
@@ -649,7 +649,7 @@
 
 (test #t (exact-integer? 32))
 (test #f (exact-integer? 32.0))
-;; (test #f (exact-integer? 32/5))
+(test #f (exact-integer? 32/5))
 
 (test #t (finite? 3))
 (test #f (finite? +inf.0))
@@ -763,8 +763,8 @@
 (test -1 (- 3 4))
 (test -6 (- 3 4 5))
 (test -3 (- 3))
-;; (test 3/20 (/ 3 4 5))
-;; (test 1/3 (/ 3))
+(test 3/20 (/ 3 4 5))
+(test 1/3 (/ 3))
 
 (test 7 (abs -7))
 (test 7 (abs 7))
@@ -817,7 +817,7 @@
 (test 3.0 (truncate 3.5))
 (test 4.0 (round 3.5))
 
-;; (test 4 (round 7/2))
+(test 4 (round 7/2))
 (test 7 (round 7))
 
 ;; (test 1/3 (rationalize (exact .3) 1/10))

From d85801e3968ae23b8e009619ee9ca6d6d4d6b483 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 17:58:46 +0900
Subject: [PATCH 106/216] rational number literal reads exact integer if
 possible

---
 src/read.c | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index 3979755c..b64ad0dc 100644
--- a/src/read.c
+++ b/src/read.c
@@ -208,7 +208,11 @@ read_number(pic_state *pic, struct pic_port *port, char c)
     n = atoi(buf);
     next(port);
     read_uinteger(pic, port, next(port), buf);
-    return pic_float_value(n / (double)atoi(buf));
+    if (n == n / atoi(buf) * atoi(buf)) {
+      return pic_int_value(n / atoi(buf)); /* exact */
+    } else {
+      return pic_float_value(n / (double)atoi(buf));
+    }
 
   default:
     return pic_int_value(atoi(buf));

From 64d757d46aa45c67e211b1b92e50ed86be2520cb Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 18:04:53 +0900
Subject: [PATCH 107/216] r7rs-test: print all failed tests in the end

---
 t/r7rs-tests.scm | 30 ++++++++++++++++++++----------
 1 file changed, 20 insertions(+), 10 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 8eeac60b..0e818ca1 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -47,6 +47,8 @@
 (define counter 0)
 (define failure-counter 0)
 
+(define fails '())
+
 (define (print-statistics)
   (newline)
   (display "Test Result: ")
@@ -58,7 +60,11 @@
   (display "%)")
   (display " [PASS/TOTAL]")
   (display "")
-  (newline))
+  (newline)
+  (for-each
+   (lambda (fail)
+     (display fail))
+   fails))
 
 (define (test-begin . o)
   (set! test-counter (+ test-counter 1)))
@@ -85,15 +91,19 @@
          )
         ((not (equal? res expected))
          (set! failure-counter (+ failure-counter 1))
-         (display " FAIL: ")
-         (write 'expr)
-         (newline)
-         (display "   expected ")
-         (write expected)
-         (display " but got ")
-         (write res)
-         (display "")
-         (newline)))
+         (let ((out (open-output-string)))
+           (display " FAIL: " out)
+           (write 'expr out)
+           (newline out)
+           (display "   expected " out)
+           (write expected out)
+           (display " but got " out)
+           (write res out)
+           (display "" out)
+           (newline out)
+           (let ((str (get-output-string out)))
+             (set! fails (cons str fails))
+             (display str)))))
        (set! counter (+ counter 1))))))
 
 (newline)

From 6dd6b0bc072acfbad603456e53104056508f6cfb Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 18:33:45 +0900
Subject: [PATCH 108/216] update docs

---
 docs/lang.rst | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/docs/lang.rst b/docs/lang.rst
index 9e787548..6a68fed7 100644
--- a/docs/lang.rst
+++ b/docs/lang.rst
@@ -17,6 +17,8 @@ At the REPL start-up time, some usuful built-in libraries listed below will be a
 - ``(scheme cxr)``
 - ``(scheme lazy)``
 - ``(scheme time)``
+- ``(scheme case-lambda)``
+- ``(scheme read)``
 
 Compliance with R7RS
 ---------------------

From f02bac1d8848f6c1905d461cf128a4bba5ae57db Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 20:57:35 +0900
Subject: [PATCH 109/216] register function name to lambdas like (define foo
 (lambda ...))

---
 src/codegen.c | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/src/codegen.c b/src/codegen.c
index a4d7e25b..77e74e26 100644
--- a/src/codegen.c
+++ b/src/codegen.c
@@ -420,14 +420,11 @@ analyze_define(analyze_state *state, pic_value obj)
   pic_value var, val;
   pic_sym sym;
 
-  if (pic_length(pic, obj) < 2) {
+  if (pic_length(pic, obj) != 3) {
     pic_error(pic, "syntax error");
   }
 
   var = pic_list_ref(pic, obj, 1);
-  if (pic_pair_p(var)) {
-    var = pic_list_ref(pic, var, 0);
-  }
   if (! pic_sym_p(var)) {
     pic_error(pic, "syntax error");
   } else {
@@ -435,11 +432,13 @@ analyze_define(analyze_state *state, pic_value obj)
   }
   var = analyze_declare(state, sym);
 
-  if (pic_pair_p(pic_list_ref(pic, obj, 1))) {
+  if (pic_pair_p(pic_list_ref(pic, obj, 2))
+      && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0))
+      && pic_sym(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) {
     pic_value formals, body_exprs;
 
-    formals = pic_list_tail(pic, pic_list_ref(pic, obj, 1), 1);
-    body_exprs = pic_list_tail(pic, obj, 2);
+    formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1);
+    body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2);
 
     val = analyze_procedure(state, pic_sym_value(sym), formals, body_exprs);
   } else {

From 443bd6e830d078acb8c4266bd52bb8e9de18c8e2 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 20:59:29 +0900
Subject: [PATCH 110/216] initial array support

---
 piclib/CMakeLists.txt   |  1 +
 piclib/picrin/array.scm | 55 +++++++++++++++++++++++++++++++++++++++++
 t/array.scm             | 24 ++++++++++++++++++
 3 files changed, 80 insertions(+)
 create mode 100644 piclib/picrin/array.scm
 create mode 100644 t/array.scm

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 49f1c4b3..aaf66fdd 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,5 +1,6 @@
 list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/built-in.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm
diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm
new file mode 100644
index 00000000..04167d6d
--- /dev/null
+++ b/piclib/picrin/array.scm
@@ -0,0 +1,55 @@
+(define-library (picrin array)
+  (import (scheme base))
+
+  (define-record-type array
+    (create-array data size head tail)
+    array?
+    (data array-data set-array-data!)
+    (size array-size set-array-size!)
+    (head array-head set-array-head!)
+    (tail array-tail set-array-tail!))
+
+  (define (translate ary i)
+    (floor-remainder i (array-size ary)))
+
+  (define (make-array)
+    (create-array (vector) 0 0 0))
+
+  (define (array-length ary)
+    (let ((size (- (array-tail ary) (array-head ary))))
+     (translate ary size)))
+
+  (define (array-rotate! ary)
+    (when (< (array-tail ary) (array-head ary))
+      (let ((xs (vector-copy (array-data ary) 0 (array-head ary)))
+            (ys (vector-copy (array-data ary) (array-head ary))))
+        (set-array-data! ary (vector-append ys xs))
+        (set-array-tail! ary (array-length ary))
+        (set-array-head! ary 0))))
+
+  (define (array-reserve! ary size)
+    (set! size (+ size 1))              ; capa == size - 1
+    (when (< (array-size ary) size)
+      (array-rotate! ary)
+      (set-array-data! ary (vector-append (array-data ary) (make-vector (- size (array-size ary)))))
+      (set-array-size! ary size)))
+
+  (define (array-ref ary i)
+    (let ((data (array-data ary)))
+      (vector-ref data (translate ary (+ (array-head ary) i)))))
+
+  (define (array-set! ary i obj)
+    (let ((data (array-data ary)))
+      (vector-set! data (translate ary (+ (array-head ary) i)) obj)))
+
+  (define (array-push! ary obj)
+    (array-reserve! ary (+ (array-length ary) 1))
+    (array-set! ary (array-length ary) obj)
+    (set-array-tail! ary (translate ary (+ (array-tail ary) 1))))
+
+  (export make-array
+          array?
+          array-length
+          array-ref
+          array-set!
+          array-push!))
diff --git a/t/array.scm b/t/array.scm
new file mode 100644
index 00000000..dc41f462
--- /dev/null
+++ b/t/array.scm
@@ -0,0 +1,24 @@
+(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-ref ary 0))
+(newline)
+(write (array-ref ary 1))
+(newline)
+(write (array-ref ary 2))
+(newline)
+

From 2da5d440a8ab26d71d9fe4173368881357d16376 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 21:26:08 +0900
Subject: [PATCH 111/216] more array functions

---
 piclib/picrin/array.scm | 22 ++++++++++++++++++++--
 t/array.scm             | 24 +++++++++++++++++++++---
 2 files changed, 41 insertions(+), 5 deletions(-)

diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm
index 04167d6d..deb9cc21 100644
--- a/piclib/picrin/array.scm
+++ b/piclib/picrin/array.scm
@@ -31,7 +31,9 @@
     (set! size (+ size 1))              ; capa == size - 1
     (when (< (array-size ary) size)
       (array-rotate! ary)
-      (set-array-data! ary (vector-append (array-data ary) (make-vector (- size (array-size ary)))))
+      (set-array-data! ary (vector-append
+                            (array-data ary)
+                            (make-vector (- size (array-size ary)))))
       (set-array-size! ary size)))
 
   (define (array-ref ary i)
@@ -47,9 +49,25 @@
     (array-set! ary (array-length ary) obj)
     (set-array-tail! ary (translate ary (+ (array-tail ary) 1))))
 
+  (define (array-pop! ary)
+    (set-array-tail! ary (translate ary (- (array-tail ary) 1)))
+    (array-ref ary (array-length ary)))
+
+  (define (array-shift! ary)
+    (set-array-head! ary (translate ary (+ (array-head ary) 1)))
+    (array-ref ary -1))
+
+  (define (array-unshift! ary obj)
+    (array-reserve! ary (+ (array-length ary) 1))
+    (array-set! ary -1 obj)
+    (set-array-head! ary (translate ary (- (array-head ary) 1))))
+
   (export make-array
           array?
           array-length
           array-ref
           array-set!
-          array-push!))
+          array-push!
+          array-pop!
+          array-shift!
+          array-unshift!))
diff --git a/t/array.scm b/t/array.scm
index dc41f462..22593546 100644
--- a/t/array.scm
+++ b/t/array.scm
@@ -15,10 +15,28 @@
 (array-push! ary 3)
 (write ary)
 (newline)
-(write (array-ref ary 0))
+(write (array-pop! ary))
 (newline)
-(write (array-ref ary 1))
+(write (array-pop! ary))
 (newline)
-(write (array-ref ary 2))
+(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)
 

From d358c8873da21e17de7182c5c38c7fdb46117d4b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 22:20:32 +0900
Subject: [PATCH 112/216] add array<->list converters

---
 piclib/picrin/array.scm | 25 +++++++++++++++++++++----
 1 file changed, 21 insertions(+), 4 deletions(-)

diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm
index deb9cc21..f2926fac 100644
--- a/piclib/picrin/array.scm
+++ b/piclib/picrin/array.scm
@@ -12,9 +12,6 @@
   (define (translate ary i)
     (floor-remainder i (array-size ary)))
 
-  (define (make-array)
-    (create-array (vector) 0 0 0))
-
   (define (array-length ary)
     (let ((size (- (array-tail ary) (array-head ary))))
      (translate ary size)))
@@ -36,6 +33,9 @@
                             (make-vector (- size (array-size ary)))))
       (set-array-size! ary size)))
 
+  (define (make-array . rest)
+    (create-array (vector) 0 0 0))
+
   (define (array-ref ary i)
     (let ((data (array-data ary)))
       (vector-ref data (translate ary (+ (array-head ary) i)))))
@@ -62,7 +62,22 @@
     (array-set! ary -1 obj)
     (set-array-head! ary (translate ary (- (array-head ary) 1))))
 
+  (define (array->list ary)
+    (do ((i 0 (+ i 1))
+         (x '() (cons (array-ref ary i) x)))
+        ((= i (array-length ary))
+         (reverse x))))
+
+  (define (list->array list)
+    (let ((ary (make-array)))
+      (for-each (lambda (x) (array-push! ary x)) list)
+      ary))
+
+  (define (array . objs)
+    (list->array objs))
+
   (export make-array
+          array
           array?
           array-length
           array-ref
@@ -70,4 +85,6 @@
           array-push!
           array-pop!
           array-shift!
-          array-unshift!))
+          array-unshift!
+          array->list
+          list->array))

From 4f5a92d921581b4b483145d14721a70d7587dcbf Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 22:20:45 +0900
Subject: [PATCH 113/216] rename array type; avoid variable conflict

---
 piclib/picrin/array.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm
index f2926fac..7fc6f050 100644
--- a/piclib/picrin/array.scm
+++ b/piclib/picrin/array.scm
@@ -1,7 +1,7 @@
 (define-library (picrin array)
   (import (scheme base))
 
-  (define-record-type array
+  (define-record-type array-type
     (create-array data size head tail)
     array?
     (data array-data set-array-data!)

From 318475c14b0efe6f7d1635403e6ec54399689721 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 22:27:48 +0900
Subject: [PATCH 114/216] optional argument for make-array

---
 piclib/picrin/array.scm | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm
index 7fc6f050..bc667ac8 100644
--- a/piclib/picrin/array.scm
+++ b/piclib/picrin/array.scm
@@ -34,7 +34,12 @@
       (set-array-size! ary size)))
 
   (define (make-array . rest)
-    (create-array (vector) 0 0 0))
+    (if (null? rest)
+        (make-array 0)
+        (let ((capacity (car rest))
+              (ary (create-array (vector) 0 0 0)))
+          (array-reserve! ary capacity)
+          ary)))
 
   (define (array-ref ary i)
     (let ((data (array-data ary)))

From 632529c9a5071a103e94d60ba3ba44a086c71398 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 22:45:04 +0900
Subject: [PATCH 115/216] add array-map and array-for-each

---
 piclib/picrin/array.scm | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm
index bc667ac8..4f8295d5 100644
--- a/piclib/picrin/array.scm
+++ b/piclib/picrin/array.scm
@@ -81,6 +81,12 @@
   (define (array . objs)
     (list->array objs))
 
+  (define (array-map proc ary)
+    (list->array (map proc (array->list ary))))
+
+  (define (array-for-each proc ary)
+    (for-each proc (array->list ary)))
+
   (export make-array
           array
           array?
@@ -91,5 +97,7 @@
           array-pop!
           array-shift!
           array-unshift!
+          array-map
+          array-for-each
           array->list
           list->array))

From fa0cde8d77112bb269958f9fc13003ff2c0051bf Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 23:09:20 +0900
Subject: [PATCH 116/216] publish call-with-{in,out}put-file

---
 piclib/built-in.scm | 15 ++++++++++++---
 1 file changed, 12 insertions(+), 3 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 36e2ab29..8221653e 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -1005,14 +1005,23 @@
 
 (export call-with-port)
 
+(define-library (scheme file)
+  (import (scheme base))
+
+  (define (call-with-input-file filename callback)
+    (call-with-port (open-input-file filename) callback))
+
+  (define (call-with-output-file filename callback)
+    (call-with-port (open-output-file filename) callback))
+
+  (export call-with-input-file
+          call-with-output-file))
+
 ;;; include syntax
 
 (import (scheme read)
         (scheme file))
 
-(define (call-with-input-file filename callback)
-  (call-with-port (open-input-file filename) callback))
-
 (define (read-many filename)
   (call-with-input-file filename
     (lambda (port)

From 033b26d1e8671e685ff70a6052f9323c02191aca Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 23:54:50 +0900
Subject: [PATCH 117/216] update docs

---
 docs/libs.rst | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 64 insertions(+)

diff --git a/docs/libs.rst b/docs/libs.rst
index 102a1b54..98686ec1 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -137,6 +137,70 @@ This expression is equivalent to ``(filter even? (iota 10))`` but it is more pro
   Returns ``()`` whatever value is given. The identity element of list composition. This operator corresponds to Haskell's fail method of Monad class.
 
 
+(picrin array)
+--------------
+
+Resizable random-access list.
+
+Technically, picrin's array is implemented as a ring-buffer, effective double-ended queue data structure (deque) that can operate pushing and poping from both of front and back in constant time. In addition to the deque interface, array provides standard sequence interface similar to functions specified by R7RS.
+
+- **(make-array [capacity])**
+
+  Returns a newly allocated array object. If capacity is given, internal data chunk of the array object will be initialized by capacity size.
+
+- **(array . objs)**
+
+  Returns an array initialized with objs.
+
+- **(array? . obj)**
+
+  Returns #t if obj is an array.
+
+- **(array-length ary)**
+
+  Returns the length of ary.
+
+- **(array-ref ary i)**
+
+  Like ``list-ref``, return the object pointed by the index i.
+
+- **(array-set! ary i obj)**
+
+  Like ``list-set!``, substitutes the object pointed by the index i with given obj.
+
+- **(array-push! ary obj)**
+
+  Adds obj to the end of ary.
+
+- **(array-pop! ary)**
+
+  Removes the last element of ary, and returns it.
+
+- **(array-unshift! ary obj)**
+
+  Adds obj to the front of ary.
+
+- **(array-shift! ary)**
+
+  Removes the first element of ary, and returns it.
+
+- **(array-map proc ary)**
+
+  Performs mapping operation on ary.
+
+- **(array-for-each proc ary)**
+
+  Performs mapping operation on ary, but discards the result.
+
+- **(array->list ary)**
+
+  Converts ary into list.
+
+- **(list->array list)**
+
+  Converts list into array.
+
+
 (picrin dictionary)
 -------------------
 

From b86d010b76ca276ae2e595c1d962084a744c3af3 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 14:30:45 +0900
Subject: [PATCH 118/216] add letrec-syntax

---
 docs/lang.rst       |  2 +-
 piclib/built-in.scm | 13 +++++++++++++
 2 files changed, 14 insertions(+), 1 deletion(-)

diff --git a/docs/lang.rst b/docs/lang.rst
index 6a68fed7..9c4152ff 100644
--- a/docs/lang.rst
+++ b/docs/lang.rst
@@ -58,7 +58,7 @@ section                                          status     comments
 5.3.1 Top level definitions                      yes
 5.3.2 Internal definitions                       yes        TODO: interreferential definitions
 5.3.3 Multiple-value definitions                 yes
-5.4 Syntax definitions                           yes        TODO: internal macro definition is not supported.
+5.4 Syntax definitions                           yes
 5.5 Recored-type definitions                     yes
 5.6.1 Library Syntax                             incomplete In picrin, libraries can be reopend and can be nested.
 5.6.2 Library example                            N/A
diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 8221653e..c3c09059 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -292,6 +292,17 @@
                           `(,(r 'begin) ,@(cdar clauses)))
                         ,(loop (cdr clauses))))))))))
 
+  (define-syntax letrec-syntax
+    (er-macro-transformer
+     (lambda (form r c)
+       (let ((formal (car (cdr form)))
+             (body   (cdr (cdr form))))
+         `(let ()
+            ,@(map (lambda (x)
+                     `(,(r 'define-syntax) ,(car x) ,(cadr x)))
+                   formal)
+            ,@body)))))
+
   (define-syntax syntax-error
     (er-macro-transformer
      (lambda (expr rename compare)
@@ -317,6 +328,7 @@
           and or
           cond case else =>
           do when unless
+          letrec-syntax
           _ ... syntax-error))
 
 
@@ -629,6 +641,7 @@
         and or
         cond case else =>
         do when unless
+        letrec-syntax
         _ ... syntax-error)
 
 (export let-values

From 8e114fae6b24b78c95c0d75e38695050f7d27b3c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 14:32:04 +0900
Subject: [PATCH 119/216] unlock letrec-syntax test

---
 t/r7rs-tests.scm | 36 ++++++++++++++++++------------------
 1 file changed, 18 insertions(+), 18 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 0e818ca1..eeac935e 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -464,24 +464,24 @@
     (let ((x 'inner))
       (m)))))
 
-;; (test 7 (letrec-syntax
-;;   ((my-or (syntax-rules ()
-;;             ((my-or) #f)
-;;             ((my-or e) e)
-;;             ((my-or e1 e2 ...)
-;;              (let ((temp e1))
-;;                (if temp
-;;                    temp
-;;                    (my-or e2 ...)))))))
-;;   (let ((x #f)
-;;         (y 7)
-;;         (temp 8)
-;;         (let odd?)
-;;         (if even?))
-;;     (my-or x
-;;            (let temp)
-;;            (if y)
-;;            y))))
+(test 7 (letrec-syntax
+  ((my-or (syntax-rules ()
+            ((my-or) #f)
+            ((my-or e) e)
+            ((my-or e1 e2 ...)
+             (let ((temp e1))
+               (if temp
+                   temp
+                   (my-or e2 ...)))))))
+  (let ((x #f)
+        (y 7)
+        (temp 8)
+        (let odd?)
+        (if even?))
+    (my-or x
+           (let temp)
+           (if y)
+           y))))
 
 (define-syntax be-like-begin
   (syntax-rules ()

From 6ee4d49a96853e352c449dadf36bf332fc730fd6 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 14:46:30 +0900
Subject: [PATCH 120/216] Macro-generating macro may rename symbol that will be
 used as a newly introduced identifier

---
 src/macro.c | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 5ac2e4dc..1ad56a78 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -34,7 +34,12 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren
 {
   xh_entry *e;
 
-  UNUSED(pic);
+  if (! pic_interned_p(pic, sym)) {
+    if (rename != NULL) {
+      *rename = sym;
+    }
+    return true;
+  }
 
   if ((e = xh_get_int(&senv->renames, sym)) == NULL) {
     return false;
@@ -73,9 +78,6 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c
 {
   pic_sym rename;
 
-  if (! pic_interned_p(pic, sym)) {
-    return sym;
-  }
   while (true) {
     if (pic_find_rename(pic, senv, sym, &rename)) {
       return rename;

From bdcb83296eff967a930738735b8841de1b7cdea9 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 14:47:25 +0900
Subject: [PATCH 121/216] update case-lambda impl

---
 piclib/built-in.scm | 57 +++++++++++++++++----------------------------
 1 file changed, 21 insertions(+), 36 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index c3c09059..0b94d488 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -1425,42 +1425,27 @@
 
   (define-syntax case-lambda
     (syntax-rules ()
-      ((case-lambda
-        (?a1 ?e1 ...)
-        ?clause1 ...)
+      ((case-lambda (params body0 ...) ...)
        (lambda args
-         (let ((l (length args)))
-           (case-lambda "CLAUSE" args l
-                        (?a1 ?e1 ...)
-                        ?clause1 ...))))
-      ((case-lambda "CLAUSE" ?args ?l
-                    ((?a1 ...) ?e1 ...)
-                    ?clause1 ...)
-       (if (= ?l (length '(?a1 ...)))
-           (apply (lambda (?a1 ...) ?e1 ...) ?args)
-           (case-lambda "CLAUSE" ?args ?l
-                        ?clause1 ...)))
-      ((case-lambda "CLAUSE" ?args ?l
-                    ((?a1 . ?ar) ?e1 ...)
-                    ?clause1 ...)
-       (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
-                    ?clause1 ...))
-      ((case-lambda "CLAUSE" ?args ?l
-                    (?a1 ?e1 ...)
-                    ?clause1 ...)
-       (let ((?a1 ?args))
-         ?e1 ...))
-      ((case-lambda "CLAUSE" ?args ?l)
-       (error "Wrong number of arguments to CASE-LAMBDA."))
-      ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
-                    ?clause1 ...)
-       (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...)
-                    ?clause1 ...))
-      ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...)
-                    ?clause1 ...)
-       (if (>= ?l ?k)
-           (apply (lambda ?al ?e1 ...) ?args)
-           (case-lambda "CLAUSE" ?args ?l
-                        ?clause1 ...)))))
+         (let ((len (length args)))
+           (letrec-syntax
+               ((cl (syntax-rules ::: ()
+                      ((cl)
+                       (error "no matching clause"))
+                      ((cl ((p :::) . body) . rest)
+                       (if (= len (length '(p :::)))
+                           (apply (lambda (p :::)
+                                    . body)
+                                  args)
+                           (cl . rest)))
+                      ((cl ((p ::: . tail) . body)
+                           . rest)
+                       (if (>= len (length '(p :::)))
+                           (apply
+                            (lambda (p ::: . tail)
+                              . body)
+                            args)
+                           (cl . rest))))))
+             (cl (params body0 ...) ...)))))))
 
   (export case-lambda))

From 40897e6351759be1a5a20d9d424f03518eb46b85 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 16:12:25 +0900
Subject: [PATCH 122/216] support character literal

---
 src/read.c | 19 +++++++++++++++----
 1 file changed, 15 insertions(+), 4 deletions(-)

diff --git a/src/read.c b/src/read.c
index b64ad0dc..f8836e44 100644
--- a/src/read.c
+++ b/src/read.c
@@ -300,12 +300,23 @@ read_boolean(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_char(pic_state *pic, struct pic_port *port, char c)
 {
-  UNUSED(pic);
-  UNUSED(c);
+  c = next(port);
 
-  /* TODO: #\alart, #\space, so on and so on */
+  if (! isdelim(peek(port))) {
+    switch (c) {
+    default: read_error(pic, "unexpected character after char literal");
+    case 'a': c = '\a'; expect(port, "lerm"); break;
+    case 'b': c = '\b'; expect(port, "ackspace"); break;
+    case 'd': c = 0x7F; expect(port, "elete"); break;
+    case 'e': c = 0x1B; expect(port, "scape"); break;
+    case 'n': c = peek(port) == 'e' ? (expect(port, "ewline"), '\n') : (expect(port, "ull"), '\0'); break;
+    case 'r': c = '\r'; expect(port, "eturn"); break;
+    case 's': c = ' '; expect(port, "pace"); break;
+    case 't': c = '\t'; expect(port, "ab"); break;
+    }
+  }
 
-  return pic_char_value(next(port));
+  return pic_char_value(c);
 }
 
 static pic_value

From ed01546f8e012be22c3643ee372cb6298b7a2192 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 20:42:12 +0900
Subject: [PATCH 123/216] add (picrin pretty-print)

---
 contrib/10.pretty-print/CMakeLists.txt   |   1 +
 contrib/10.pretty-print/pretty-print.scm | 312 +++++++++++++++++++++++
 2 files changed, 313 insertions(+)
 create mode 100644 contrib/10.pretty-print/CMakeLists.txt
 create mode 100644 contrib/10.pretty-print/pretty-print.scm

diff --git a/contrib/10.pretty-print/CMakeLists.txt b/contrib/10.pretty-print/CMakeLists.txt
new file mode 100644
index 00000000..cf0327da
--- /dev/null
+++ b/contrib/10.pretty-print/CMakeLists.txt
@@ -0,0 +1 @@
+list(APPEND PICLIB_CONTRIB_LIBS ${PROJECT_SOURCE_DIR}/contrib/10.pretty-print/pretty-print.scm)
diff --git a/contrib/10.pretty-print/pretty-print.scm b/contrib/10.pretty-print/pretty-print.scm
new file mode 100644
index 00000000..0c25882c
--- /dev/null
+++ b/contrib/10.pretty-print/pretty-print.scm
@@ -0,0 +1,312 @@
+(define-library (picrin pretty-print)
+  (import (scheme base)
+          (scheme write))
+
+  ; (reverse-string-append l) = (apply string-append (reverse l))
+
+  (define (reverse-string-append l)
+
+    (define (rev-string-append l i)
+      (if (pair? l)
+          (let* ((str (car l))
+                 (len (string-length str))
+                 (result (rev-string-append (cdr l) (+ i len))))
+            (let loop ((j 0) (k (- (- (string-length result) i) len)))
+              (if (< j len)
+                  (begin
+                    (string-set! result k (string-ref str j))
+                    (loop (+ j 1) (+ k 1)))
+                  result)))
+          (make-string i)))
+
+    (rev-string-append l 0))
+
+  ;; We define a pretty printer for Scheme S-expressions (sexp). While
+  ;; Petite Scheme supports that by its own, mzscheme does not. If you
+  ;; get a sexp (like from proof-to-expr) prefix it with a call to spp and
+  ;; the output is nicely formated to fit into pp-width many columns:
+  ;;
+  ;;  (spp (proof-to-expr (current-proof)))
+  ;;
+
+  (define pp-width 80)
+
+  ;;"genwrite.scm" generic write used by pretty-print and truncated-print.
+  ;; Copyright (c) 1991, Marc Feeley
+  ;; Author: Marc Feeley (feeley@iro.umontreal.ca)
+  ;; Distribution restrictions: none
+  ;;
+  ;; Modified for Minlog by Stefan Schimanski <schimans@math.lmu.de>
+  ;; Taken from slib 2d6, genwrite.scm and pp.scm
+
+  (define genwrite:newline-str (make-string 1 #\newline))
+
+  (define (generic-write obj display? width output)
+
+    (define (read-macro? l)
+      (define (length1? l) (and (pair? l) (null? (cdr l))))
+      (let ((head (car l)) (tail (cdr l)))
+        (case head
+          ((quote quasiquote unquote unquote-splicing) (length1? tail))
+          (else                                        #f))))
+
+    (define (read-macro-body l)
+      (cadr l))
+
+    (define (read-macro-prefix l)
+      (let ((head (car l)) (tail (cdr l)))
+        (case head
+          ((quote)            "'")
+          ((quasiquote)       "`")
+          ((unquote)          ",")
+          ((unquote-splicing) ",@"))))
+
+    (define (out str col)
+      (and col (output str) (+ col (string-length str))))
+
+    (define (wr obj col)
+
+      (define (wr-lst l col)
+        (if (pair? l)
+            (let loop ((l (cdr l))
+                       (col (and col (wr (car l) (out "(" col)))))
+              (cond ((not col) col)
+                    ((pair? l)
+                     (loop (cdr l) (wr (car l) (out " " col))))
+                    ((null? l) (out ")" col))
+                    (else      (out ")" (wr l (out " . " col))))))
+            (out "()" col)))
+
+      (define (wr-expr expr col)
+        (if (read-macro? expr)
+            (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
+            (wr-lst expr col)))
+
+      (cond ((pair? obj)        (wr-expr obj col))
+            ((null? obj)        (wr-lst obj col))
+            ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
+            ((boolean? obj)     (out (if obj "#t" "#f") col))
+            ((number? obj)      (out (number->string obj) col))
+            ((symbol? obj)      (out (symbol->string obj) col))
+            ((procedure? obj)   (out "#[procedure]" col))
+            ((string? obj)      (if display?
+                                    (out obj col)
+                                    (let loop ((i 0) (j 0) (col (out "\"" col)))
+                                      (if (and col (< j (string-length obj)))
+                                          (let ((c (string-ref obj j)))
+                                            (if (or (char=? c #\\)
+                                                    (char=? c #\"))
+                                                (loop j
+                                                      (+ j 1)
+                                                      (out "\\"
+                                                           (out (substring obj i j)
+                                                                col)))
+                                                (loop i (+ j 1) col)))
+                                          (out "\""
+                                               (out (substring obj i j) col))))))
+            ((char? obj)        (if display?
+                                    (out (make-string 1 obj) col)
+                                    (out (case obj
+                                           ((#\space)   "space")
+                                           ((#\newline) "newline")
+                                           (else        (make-string 1 obj)))
+                                         (out "#\\" col))))
+            ((input-port? obj)  (out "#[input-port]" col))
+            ((output-port? obj) (out "#[output-port]" col))
+            ((eof-object? obj)  (out "#[eof-object]" col))
+            (else               (out "#[unknown]" col))))
+
+    (define (pp obj col)
+
+      (define (spaces n col)
+        (if (> n 0)
+            (if (> n 7)
+                (spaces (- n 8) (out "        " col))
+                (out (substring "        " 0 n) col))
+            col))
+
+      (define (indent to col)
+        (and col
+             (if (< to col)
+                 (and (out genwrite:newline-str col) (spaces to 0))
+                 (spaces (- to col) col))))
+
+      (define pp-list #f)
+      (define pp-expr #f)
+      (define pp-call #f)
+      (define pp-down #f)
+      (define pp-general #f)
+      (define pp-width #f)
+      (define pp-expr-list #f)
+
+      (define indent-general #f)
+      (define max-expr-width #f)
+      (define max-call-head-width #f)
+      (define style #f)
+
+      (define pr
+        (lambda (obj col extra pp-pair)
+          (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
+              (let ((result '())
+                    (left (min (+ (- (- width col) extra) 1) max-expr-width)))
+                (generic-write obj display? #f
+                               (lambda (str)
+                                 (set! result (cons str result))
+                                 (set! left (- left (string-length str)))
+                                 (> left 0)))
+                (if (> left 0)        ; all can be printed on one line
+                    (out (reverse-string-append result) col)
+                    (if (pair? obj)
+                        (pp-pair obj col extra)
+                        (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
+              (wr obj col))))
+
+      (set! pp-expr
+        (lambda (expr col extra)
+          (if (read-macro? expr)
+              (pr (read-macro-body expr)
+                  (out (read-macro-prefix expr) col)
+                  extra
+                  pp-expr)
+              (let ((head (car expr)))
+                (if (symbol? head)
+                    (let ((proc (style head)))
+                      (if proc
+                          (proc expr col extra)
+                          (if (> (string-length (symbol->string head))
+                                 max-call-head-width)
+                              (pp-general expr col extra #f #f #f pp-expr)
+                              (pp-call expr col extra pp-expr))))
+                    (pp-list expr col extra pp-expr))))))
+
+                                        ; (head item1
+                                        ;       item2
+                                        ;       item3)
+      (set! pp-call
+        (lambda (expr col extra pp-item)
+          (let ((col* (wr (car expr) (out "(" col))))
+            (and col
+                 (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))))
+
+                                        ; (item1
+                                        ;  item2
+                                        ;  item3)
+      (set! pp-list
+        (lambda (l col extra pp-item)
+          (let ((col (out "(" col)))
+            (pp-down l col col extra pp-item))))
+
+      (set! pp-down
+        (lambda (l col1 col2 extra pp-item)
+          (let loop ((l l) (col col1))
+            (and col
+                 (cond ((pair? l)
+                        (let ((rest (cdr l)))
+                          (let ((extra (if (null? rest) (+ extra 1) 0)))
+                            (loop rest
+                                  (pr (car l) (indent col2 col) extra pp-item)))))
+                       ((null? l)
+                        (out ")" col))
+                       (else
+                        (out ")"
+                             (pr l
+                                 (indent col2 (out "." (indent col2 col)))
+                                 (+ extra 1)
+                                 pp-item))))))))
+
+      (set! pp-general
+        (lambda (expr col extra named? pp-1 pp-2 pp-3)
+
+          (define (tail3 rest col1 col2)
+            (pp-down rest col2 col1 extra pp-3))
+
+          (define (tail2 rest col1 col2 col3)
+            (if (and pp-2 (pair? rest))
+                (let* ((val1 (car rest))
+                       (rest (cdr rest))
+                       (extra (if (null? rest) (+ extra 1) 0)))
+                  (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
+                (tail3 rest col1 col2)))
+
+          (define (tail1 rest col1 col2 col3)
+            (if (and pp-1 (pair? rest))
+                (let* ((val1 (car rest))
+                       (rest (cdr rest))
+                       (extra (if (null? rest) (+ extra 1) 0)))
+                  (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
+                (tail2 rest col1 col2 col3)))
+
+          (let* ((head (car expr))
+                 (rest (cdr expr))
+                 (col* (wr head (out "(" col))))
+            (if (and named? (pair? rest))
+                (let* ((name (car rest))
+                       (rest (cdr rest))
+                       (col** (wr name (out " " col*))))
+                  (tail1 rest (+ col indent-general) col** (+ col** 1)))
+                (tail1 rest (+ col indent-general) col* (+ col* 1))))))
+
+      (set! pp-expr-list
+        (lambda (l col extra)
+          (pp-list l col extra pp-expr)))
+
+      (define (pp-LAMBDA expr col extra)
+        (pp-general expr col extra #f pp-expr-list #f pp-expr))
+
+      (define (pp-IF expr col extra)
+        (pp-general expr col extra #f pp-expr #f pp-expr))
+
+      (define (pp-COND expr col extra)
+        (pp-call expr col extra pp-expr-list))
+
+      (define (pp-CASE expr col extra)
+        (pp-general expr col extra #f pp-expr #f pp-expr-list))
+
+      (define (pp-AND expr col extra)
+        (pp-call expr col extra pp-expr))
+
+      (define (pp-LET expr col extra)
+        (let* ((rest (cdr expr))
+               (named? (and (pair? rest) (symbol? (car rest)))))
+          (pp-general expr col extra named? pp-expr-list #f pp-expr)))
+
+      (define (pp-BEGIN expr col extra)
+        (pp-general expr col extra #f #f #f pp-expr))
+
+      (define (pp-DO expr col extra)
+        (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
+
+                                        ; define formatting style (change these to suit your style)
+
+      (set! indent-general 2)
+
+      (set! max-call-head-width 5)
+
+      (set! max-expr-width 50)
+
+      (set! style
+        (lambda (head)
+          (case head
+            ((lambda let* letrec define) pp-LAMBDA)
+            ((if set!)                   pp-IF)
+            ((cond)                      pp-COND)
+            ((case)                      pp-CASE)
+            ((and or)                    pp-AND)
+            ((let)                       pp-LET)
+            ((begin)                     pp-BEGIN)
+            ((do)                        pp-DO)
+            (else                        #f))))
+
+      (pr obj col 0 pp-expr))
+
+    (if width
+        (out genwrite:newline-str (pp obj 0))
+        (wr obj 0)))
+
+  (define (pretty-print obj . opt)
+    (let ((port (if (pair? opt) (car opt) (current-output-port))))
+      (generic-write obj #f pp-width
+                     (lambda (s) (display s port) #t))
+      (display "")))
+
+  (export pretty-print))

From a727c913a3af2ccf9f540595fa237505c9c9aab6 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 20:46:00 +0900
Subject: [PATCH 124/216] update docs

---
 docs/libs.rst | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/docs/libs.rst b/docs/libs.rst
index 98686ec1..33928196 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -248,6 +248,16 @@ Note that dictionary is not a weak map; if you are going to make a highly memory
   Conversion between dictionary and alist/plist.
 
 
+(picrin pretty-print)
+---------------------
+
+Pretty-printer.
+
+- **(pretty-print obj)**
+
+  Prints obj with human-readable indention to current-output-port.
+
+
 (picrin user)
 -------------
 

From a8751ab3bab9efec32565edeb8ec6b7f95d5f90f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 20:52:42 +0900
Subject: [PATCH 125/216] fix docs

---
 docs/libs.rst | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/docs/libs.rst b/docs/libs.rst
index 33928196..f85938eb 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -49,7 +49,7 @@ Utility functions and syntaces for macro definition.
 
 - define-macro
 - gensym
-- macroexpand expr
+- macroexpand
 
 Old-fashioned macro.
 

From 2b16aaded2008727e6c9fa93fe97e6bf696c1499 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 10:16:17 +0900
Subject: [PATCH 126/216] s/translate/make_identifier/g

---
 src/macro.c | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 1ad56a78..4624cccc 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -74,7 +74,7 @@ find_macro(pic_state *pic, pic_sym rename)
 }
 
 static pic_sym
-translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
+make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_sym rename;
 
@@ -100,7 +100,7 @@ static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct p
 static pic_value
 macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
-  return pic_sym_value(translate(pic, sym, senv, cxt));
+  return pic_sym_value(make_identifier(pic, sym, senv, cxt));
 }
 
 static pic_value
@@ -736,7 +736,7 @@ er_macro_rename(pic_state *pic)
   mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
   cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  return pic_sym_value(translate(pic, sym, mac_env, cxt));
+  return pic_sym_value(make_identifier(pic, sym, mac_env, cxt));
 }
 
 static pic_value
@@ -755,8 +755,8 @@ er_macro_compare(pic_state *pic)
   use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
   cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  m = translate(pic, pic_sym(a), use_env, cxt);
-  n = translate(pic, pic_sym(b), use_env, cxt);
+  m = make_identifier(pic, pic_sym(a), use_env, cxt);
+  n = make_identifier(pic, pic_sym(b), use_env, cxt);
 
   return pic_bool_value(m == n);
 }
@@ -822,7 +822,7 @@ ir_macro_inject(pic_state *pic)
   use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
   cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  return pic_sym_value(translate(pic, sym, use_env, cxt));
+  return pic_sym_value(make_identifier(pic, sym, use_env, cxt));
 }
 
 static pic_value
@@ -841,8 +841,8 @@ ir_macro_compare(pic_state *pic)
   mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
   cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  m = translate(pic, pic_sym(a), mac_env, cxt);
-  n = translate(pic, pic_sym(b), mac_env, cxt);
+  m = make_identifier(pic, pic_sym(a), mac_env, cxt);
+  n = make_identifier(pic, pic_sym(b), mac_env, cxt);
 
   return pic_bool_value(m == n);
 }
@@ -852,7 +852,7 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct p
 {
   if (pic_sym_p(expr)) {
     pic_value r;
-    r = pic_sym_value(translate(pic, pic_sym(expr), use_env, cxt));
+    r = pic_sym_value(make_identifier(pic, pic_sym(expr), use_env, cxt));
     *ir = pic_acons(pic, r, expr, *ir);
     return r;
   }
@@ -874,7 +874,7 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct
     if (pic_test(r = pic_assq(pic, expr, *ir))) {
       return pic_cdr(pic, r);
     }
-    return pic_sym_value(translate(pic, pic_sym(expr), mac_env, cxt));
+    return pic_sym_value(make_identifier(pic, pic_sym(expr), mac_env, cxt));
   }
   else if (pic_pair_p(expr)) {
     return pic_cons(pic,

From 9e7b4da56c207dbbf2f6df1c385c68edb80b6f32 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 10:21:00 +0900
Subject: [PATCH 127/216] add make-identifier function

---
 src/macro.c | 14 ++++++++++++++
 1 file changed, 14 insertions(+)

diff --git a/src/macro.c b/src/macro.c
index 4624cccc..16c7816c 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -940,6 +940,19 @@ pic_macro_ir_macro_transformer(pic_state *pic)
   return pic_obj_value(proc);
 }
 
+static pic_value
+pic_macro_make_identifier(pic_state *pic)
+{
+  pic_value obj;
+  pic_sym sym;
+
+  pic_get_args(pic, "mo", &sym, &obj);
+
+  pic_assert_type(pic, obj, senv);
+
+  return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj), pic_dict_new(pic)));
+}
+
 void
 pic_init_macro(pic_state *pic)
 {
@@ -955,5 +968,6 @@ pic_init_macro(pic_state *pic)
     pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
     pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer);
     pic_defun(pic, "ir-macro-transformer", pic_macro_ir_macro_transformer);
+    pic_defun(pic, "make-identifier", pic_macro_make_identifier);
   }
 }

From b68813823f1487d11f6eaba371ea2b7a5266a462 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 11:30:44 +0900
Subject: [PATCH 128/216] improve pic_get_args error message

---
 src/vm.c | 34 +++++++++++++++++-----------------
 1 file changed, 17 insertions(+), 17 deletions(-)

diff --git a/src/vm.c b/src/vm.c
index 0063cb92..8a2430a0 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -115,7 +115,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *f = pic_int(v);
           break;
         default:
-          pic_error(pic, "pic_get_args: expected float or int");
+          pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
         }
         i++;
       }
@@ -141,7 +141,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *e = true;
           break;
         default:
-          pic_error(pic, "pic_get_args: expected float or int");
+          pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
         }
         i++;
       }
@@ -167,7 +167,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *e = true;
           break;
         default:
-          pic_error(pic, "pic_get_args: expected float or int");
+          pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
         }
         i++;
       }
@@ -189,7 +189,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *k = pic_int(v);
           break;
         default:
-          pic_error(pic, "pic_get_args: expected int");
+          pic_errorf(pic, "pic_get_args: expected int, but got ~s", v);
         }
         i++;
       }
@@ -206,23 +206,23 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *str = pic_str_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected string");
+          pic_errorf(pic, "pic_get_args: expected string, but got ~s", v);
         }
         i++;
       }
       break;
     }
     case 'z': {
-      pic_value str;
       const char **cstr;
+      pic_value v;
 
       cstr = va_arg(ap, const char **);
       if (i < argc) {
-        str = GET_OPERAND(pic,i);
-        if (! pic_str_p(str)) {
-          pic_error(pic, "pic_get_args: expected string");
+        v = GET_OPERAND(pic,i);
+        if (! pic_str_p(v)) {
+          pic_errorf(pic, "pic_get_args: expected string, but got ~s", v);
         }
-        *cstr = pic_str_cstr(pic_str_ptr(str));
+        *cstr = pic_str_cstr(pic_str_ptr(v));
         i++;
       }
       break;
@@ -238,7 +238,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *m = pic_sym(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected symbol");
+          pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v);
         }
         i++;
       }
@@ -255,7 +255,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *vec = pic_vec_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected vector");
+          pic_errorf(pic, "pic_get_args: expected vector, but got ~s", v);
         }
         i++;
       }
@@ -272,7 +272,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *b = pic_blob_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected bytevector");
+          pic_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v);
         }
         i++;
       }
@@ -289,7 +289,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *c = pic_char(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected char");
+          pic_errorf(pic, "pic_get_args: expected char, but got ~s", v);
         }
         i++;
       }
@@ -306,7 +306,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *l = pic_proc_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args, expected procedure");
+          pic_errorf(pic, "pic_get_args, expected procedure, but got ~s", v);
         }
         i++;
       }
@@ -323,7 +323,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *p = pic_port_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args, expected port");
+          pic_errorf(pic, "pic_get_args, expected port, but got ~s", v);
         }
         i++;
       }
@@ -340,7 +340,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *d = pic_dict_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args, expected dictionary");
+          pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v);
         }
         i++;
       }

From 378b5bb6a8205951c785dd362a4f4f18aa5cc355 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 11:30:58 +0900
Subject: [PATCH 129/216] dictionary-has? was missing

---
 src/dict.c | 12 ++++++++++++
 1 file changed, 12 insertions(+)

diff --git a/src/dict.c b/src/dict.c
index d3eb895b..1ba9d565 100644
--- a/src/dict.c
+++ b/src/dict.c
@@ -109,6 +109,17 @@ pic_dict_dict_set(pic_state *pic)
   return pic_none_value();
 }
 
+static pic_value
+pic_dict_dict_has_p(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_sym key;
+
+  pic_get_args(pic, "dm", &dict, &key);
+
+  return pic_bool_value(pic_dict_has(pic, dict, key));
+}
+
 static pic_value
 pic_dict_dict_del(pic_state *pic)
 {
@@ -155,6 +166,7 @@ pic_init_dict(pic_state *pic)
   pic_deflibrary ("(picrin dictionary)") {
     pic_defun(pic, "make-dictionary", pic_dict_dict);
     pic_defun(pic, "dictionary?", pic_dict_dict_p);
+    pic_defun(pic, "dictionary-has?", pic_dict_dict_has_p);
     pic_defun(pic, "dictionary-ref", pic_dict_dict_ref);
     pic_defun(pic, "dictionary-set!", pic_dict_dict_set);
     pic_defun(pic, "dictionary-delete", pic_dict_dict_del);

From 5d9242f5b52059d696fc230d8aadbc5bce94edc4 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 11:32:30 +0900
Subject: [PATCH 130/216] rewrite make-syntactic-closure in scheme

---
 piclib/built-in.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 55 insertions(+), 1 deletion(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 0b94d488..5b220ca9 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -36,7 +36,61 @@
 
 ;;; hygienic macros
 (define-library (picrin macro)
-  (import (scheme base))
+  (import (scheme base)
+          (picrin dictionary))
+
+  (define (memq obj list)
+    (if (null? list)
+        #f
+        (if (eq? obj (car list))
+            list
+            (memq obj (cdr list)))))
+
+  (define (list->vector proc list)
+    (define vector (make-vector (length list)))
+    (define (go list i)
+      (if (null? list)
+          vector
+          (begin
+            (vector-set! vector i (car list))
+            (go (cdr list) (+ i 1)))))
+    (go list 0))
+
+  (define (vector->list proc vector)
+    (define (go i)
+      (if (= i (vector-length vector))
+          '()
+          (cons (vector-ref vector i)
+                (go (+ i 1)))))
+    (go 0))
+
+  (define (vector-map proc expr)
+    (list->vector (map proc (vector->list expr))))
+
+  (define (walk proc expr)
+    (if (null? expr)
+        '()
+        (if (pair? expr)
+            (cons (proc (car expr))
+                  (walk proc (cdr expr)))
+            (if (vector? expr)
+                (vector-map proc expr)
+                (proc expr)))))
+
+  (define (make-syntactic-closure form free env)
+    (define cache (make-dictionary))
+    (walk
+     (lambda (atom)
+       (if (not (symbol? atom))
+           atom
+           (if (memq atom free)
+               atom
+               (if (dictionary-has? cache atom)
+                   (dictionary-ref cache atom)
+                   (begin
+                     (define id (make-identifier atom env))
+                     (dictionary-set! cache atom id)
+                     id)))))))
 
   (define (sc-macro-transformer f)
     (lambda (expr use-env mac-env)

From 73a6eaf9da5c54f8fd3af3d973f90ef67c660c30 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 11:32:41 +0900
Subject: [PATCH 131/216] rewrite er-macro-transformer in scheme

---
 piclib/built-in.scm | 22 ++++++++++++++++++++++
 1 file changed, 22 insertions(+)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 5b220ca9..764b282c 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -92,6 +92,28 @@
                      (dictionary-set! cache atom id)
                      id)))))))
 
+  (define (er-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define cache (make-dictionary))
+
+      (define (rename sym)
+        (if (dictionary-has? cache sym)
+            (dictionary-ref cache sym)
+            (begin
+              (define id (make-identifier sym mac-env))
+              (dictionary-set! cache sym id)
+              id)))
+
+      (define (compare sym1 sym2)
+        (if (symbol? sym1)
+            (if (symbol? sym2)
+                (identifier=? use-env sym1 use-env sym2)
+                #f)
+            #f))
+
+      (f expr rename compare)))
+
   (define (sc-macro-transformer f)
     (lambda (expr use-env mac-env)
       (make-syntactic-closure mac-env '() (f expr use-env))))

From cf509a4922bb906c99038a3f7c735d7b9de3cc71 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 11:32:52 +0900
Subject: [PATCH 132/216] [bugfix] move define-auxiliary-syntax to the
 beginning. This made mac-env and use-env of cond expression different

---
 piclib/built-in.scm | 29 ++++++++++++++---------------
 1 file changed, 14 insertions(+), 15 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 764b282c..8269cbf0 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -131,6 +131,20 @@
           (scheme cxr)
           (picrin macro))
 
+  (define-syntax define-auxiliary-syntax
+    (er-macro-transformer
+     (lambda (expr r c)
+       (list (r 'define-syntax) (cadr expr)
+             (list (r 'lambda) '_
+                   (list (r 'error) "invalid use of auxiliary syntax"))))))
+
+  (define-auxiliary-syntax else)
+  (define-auxiliary-syntax =>)
+  (define-auxiliary-syntax _)
+  (define-auxiliary-syntax ...)
+  (define-auxiliary-syntax unquote)
+  (define-auxiliary-syntax unquote-splicing)
+
   (define-syntax let
     (er-macro-transformer
      (lambda (expr r compare)
@@ -384,21 +398,6 @@
      (lambda (expr rename compare)
        (apply error (cdr expr)))))
 
-  (define-syntax define-auxiliary-syntax
-    (er-macro-transformer
-     (lambda (expr r c)
-       `(,(r 'define-syntax) ,(cadr expr)
-           (,(r 'sc-macro-transformer)
-                (,(r 'lambda) (expr env)
-                  (,(r 'error) "invalid use of auxiliary syntax")))))))
-
-  (define-auxiliary-syntax else)
-  (define-auxiliary-syntax =>)
-  (define-auxiliary-syntax _)
-  (define-auxiliary-syntax ...)
-  (define-auxiliary-syntax unquote)
-  (define-auxiliary-syntax unquote-splicing)
-
   (export let let* letrec letrec*
           quasiquote unquote unquote-splicing
           and or

From 5e8c4af84b6ae8d86fea4b2d852b40d7d8fc21a7 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 13:39:28 +0900
Subject: [PATCH 133/216] fix bugs introduced in prev commit

---
 piclib/built-in.scm | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 8269cbf0..ed3fcde2 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -46,7 +46,7 @@
             list
             (memq obj (cdr list)))))
 
-  (define (list->vector proc list)
+  (define (list->vector list)
     (define vector (make-vector (length list)))
     (define (go list i)
       (if (null? list)
@@ -56,7 +56,7 @@
             (go (cdr list) (+ i 1)))))
     (go list 0))
 
-  (define (vector->list proc vector)
+  (define (vector->list vector)
     (define (go i)
       (if (= i (vector-length vector))
           '()
@@ -71,7 +71,7 @@
     (if (null? expr)
         '()
         (if (pair? expr)
-            (cons (proc (car expr))
+            (cons (walk proc (car expr))
                   (walk proc (cdr expr)))
             (if (vector? expr)
                 (vector-map proc expr)

From 2e35f03f351f7909c5ff70ae2b0550f9a88a95f0 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 13:40:18 +0900
Subject: [PATCH 134/216] remove type check guards in compare function

---
 piclib/built-in.scm | 6 +-----
 1 file changed, 1 insertion(+), 5 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index ed3fcde2..9ab0dd83 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -106,11 +106,7 @@
               id)))
 
       (define (compare sym1 sym2)
-        (if (symbol? sym1)
-            (if (symbol? sym2)
-                (identifier=? use-env sym1 use-env sym2)
-                #f)
-            #f))
+        (identifier=? use-env sym1 use-env sym2))
 
       (f expr rename compare)))
 

From c0b83759a84fc42bdf0481421fbcc5426e03a62d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 13:40:45 +0900
Subject: [PATCH 135/216] re-implement ir-macro-transformer in scheme

---
 piclib/built-in.scm | 48 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 48 insertions(+)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 9ab0dd83..e3093dcb 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -110,6 +110,54 @@
 
       (f expr rename compare)))
 
+  (define (ir-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define protects (make-dictionary))
+
+      (define (wrap expr)
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (begin
+                 (define id (make-identifier atom use-env))
+                 (dictionary-set! protects id atom) ; lookup *atom* from id
+                 id)))
+         expr))
+
+      (define (unwrap expr)
+        (define cache (make-dictionary))
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (if (dictionary-has? protects atom)
+                   (dictionary-ref protects atom)
+                   (if (dictionary-has? cache atom)
+                       (dictionary-ref cache atom)
+                       (begin
+                         ;; implicit renaming
+                         (define id (make-identifier atom mac-env))
+                         (dictionary-set! cache atom id)
+                         id)))))
+         expr))
+
+      (define cache (make-dictionary))
+
+      (define (inject sym)
+        (if (dictionary-has? cache sym)
+            (dictionary-ref cache sym)
+            (begin
+              (define id (make-identifier sym use-env))
+              (dictionary-set! cache sym id)
+              id)))
+
+      (define (compare sym1 sym2)
+        (identifier=? mac-env sym1 mac-env sym2))
+
+      (unwrap (f (wrap expr) inject compare))))
+
   (define (sc-macro-transformer f)
     (lambda (expr use-env mac-env)
       (make-syntactic-closure mac-env '() (f expr use-env))))

From f4d68d691bfb08354895bf6f6d54455c6075e0e0 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 13:43:17 +0900
Subject: [PATCH 136/216] remove c impls of ir/er macros

---
 piclib/built-in.scm |  20 ++--
 src/macro.c         | 218 --------------------------------------------
 2 files changed, 11 insertions(+), 227 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index e3093dcb..51cfa5f5 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -92,6 +92,14 @@
                      (dictionary-set! cache atom id)
                      id)))))))
 
+  (define (sc-macro-transformer f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure mac-env '() (f expr use-env))))
+
+  (define (rsc-macro-transformer f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure use-env '() (f expr mac-env))))
+
   (define (er-macro-transformer f)
     (lambda (expr use-env mac-env)
 
@@ -158,16 +166,10 @@
 
       (unwrap (f (wrap expr) inject compare))))
 
-  (define (sc-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure mac-env '() (f expr use-env))))
-
-  (define (rsc-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure use-env '() (f expr mac-env))))
-
   (export sc-macro-transformer
-          rsc-macro-transformer))
+          rsc-macro-transformer
+          er-macro-transformer
+          ir-macro-transformer))
 
 ;;; core syntaces
 (define-library (picrin core-syntax)
diff --git a/src/macro.c b/src/macro.c
index 16c7816c..8be145f6 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -724,222 +724,6 @@ pic_macro_identifier_eq_p(pic_state *pic)
   return pic_bool_value(sc_identifier_eq_p(pic, e1, x, e2, y));
 }
 
-static pic_value
-er_macro_rename(pic_state *pic)
-{
-  pic_sym sym;
-  struct pic_senv *mac_env;
-  struct pic_dict *cxt;
-
-  pic_get_args(pic, "m", &sym);
-
-  mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
-  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
-
-  return pic_sym_value(make_identifier(pic, sym, mac_env, cxt));
-}
-
-static pic_value
-er_macro_compare(pic_state *pic)
-{
-  pic_value a, b;
-  struct pic_senv *use_env;
-  pic_sym m, n;
-  struct pic_dict *cxt;
-
-  pic_get_args(pic, "oo", &a, &b);
-
-  if (! pic_sym_p(a) || ! pic_sym_p(b))
-    return pic_false_value();   /* should be an error? */
-
-  use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
-
-  m = make_identifier(pic, pic_sym(a), use_env, cxt);
-  n = make_identifier(pic, pic_sym(b), use_env, cxt);
-
-  return pic_bool_value(m == n);
-}
-
-static pic_value
-er_macro_call(pic_state *pic)
-{
-  pic_value expr, use_env, mac_env;
-  struct pic_proc *rename, *compare, *cb;
-  struct pic_dict *cxt;
-
-  pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
-
-  if (! pic_senv_p(use_env)) {
-    pic_error(pic, "unexpected type of argument 1");
-  }
-  if (! pic_senv_p(mac_env)) {
-    pic_error(pic, "unexpected type of argument 3");
-  }
-
-  cxt = pic_dict_new(pic);
-
-  rename = pic_proc_new(pic, er_macro_rename, "<er-macro-renamer>");
-  pic_proc_cv_init(pic, rename, 3);
-  pic_proc_cv_set(pic, rename, 0, use_env);
-  pic_proc_cv_set(pic, rename, 1, mac_env);
-  pic_proc_cv_set(pic, rename, 2, pic_obj_value(cxt));
-
-  compare = pic_proc_new(pic, er_macro_compare, "<er-macro-comparator>");
-  pic_proc_cv_init(pic, compare, 3);
-  pic_proc_cv_set(pic, compare, 0, use_env);
-  pic_proc_cv_set(pic, compare, 1, mac_env);
-  pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
-
-  cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-
-  return pic_apply3(pic, cb, expr, pic_obj_value(rename), pic_obj_value(compare));
-}
-
-static pic_value
-pic_macro_er_macro_transformer(pic_state *pic)
-{
-  struct pic_proc *cb, *proc;
-
-  pic_get_args(pic, "l", &cb);
-
-  proc = pic_proc_new(pic, er_macro_call, "<er-macro-procedure>");
-  pic_proc_cv_init(pic, proc, 1);
-  pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
-
-  return pic_obj_value(proc);
-}
-
-static pic_value
-ir_macro_inject(pic_state *pic)
-{
-  pic_sym sym;
-  struct pic_senv *use_env;
-  struct pic_dict *cxt;
-
-  pic_get_args(pic, "m", &sym);
-
-  use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
-
-  return pic_sym_value(make_identifier(pic, sym, use_env, cxt));
-}
-
-static pic_value
-ir_macro_compare(pic_state *pic)
-{
-  pic_value a, b;
-  struct pic_senv *mac_env;
-  pic_sym m, n;
-  struct pic_dict *cxt;
-
-  pic_get_args(pic, "oo", &a, &b);
-
-  if (! pic_sym_p(a) || ! pic_sym_p(b))
-    return pic_false_value();   /* should be an error? */
-
-  mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
-  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
-
-  m = make_identifier(pic, pic_sym(a), mac_env, cxt);
-  n = make_identifier(pic, pic_sym(b), mac_env, cxt);
-
-  return pic_bool_value(m == n);
-}
-
-static pic_value
-ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct pic_dict *cxt, pic_value *ir)
-{
-  if (pic_sym_p(expr)) {
-    pic_value r;
-    r = pic_sym_value(make_identifier(pic, pic_sym(expr), use_env, cxt));
-    *ir = pic_acons(pic, r, expr, *ir);
-    return r;
-  }
-  else if (pic_pair_p(expr)) {
-    return pic_cons(pic,
-                    ir_macro_wrap(pic, pic_car(pic, expr), use_env, cxt, ir),
-                    ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, cxt, ir));
-  }
-  else {
-    return expr;
-  }
-}
-
-static pic_value
-ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct pic_dict *cxt, pic_value *ir)
-{
-  if (pic_sym_p(expr)) {
-    pic_value r;
-    if (pic_test(r = pic_assq(pic, expr, *ir))) {
-      return pic_cdr(pic, r);
-    }
-    return pic_sym_value(make_identifier(pic, pic_sym(expr), mac_env, cxt));
-  }
-  else if (pic_pair_p(expr)) {
-    return pic_cons(pic,
-                    ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, cxt, ir),
-                    ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, cxt, ir));
-  }
-  else {
-    return expr;
-  }
-}
-
-static pic_value
-ir_macro_call(pic_state *pic)
-{
-  pic_value expr, use_env, mac_env;
-  struct pic_proc *inject, *compare, *cb;
-  struct pic_dict *cxt;
-  pic_value ir = pic_nil_value();
-
-  pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
-
-  if (! pic_senv_p(use_env)) {
-    pic_error(pic, "unexpected type of argument 1");
-  }
-  if (! pic_senv_p(mac_env)) {
-    pic_error(pic, "unexpected type of argument 3");
-  }
-
-  cxt = pic_dict_new(pic);
-
-  inject = pic_proc_new(pic, ir_macro_inject, "<ir-macro-injecter>");
-  pic_proc_cv_init(pic, inject, 3);
-  pic_proc_cv_set(pic, inject, 0, use_env);
-  pic_proc_cv_set(pic, inject, 1, mac_env);
-  pic_proc_cv_set(pic, inject, 2, pic_obj_value(cxt));
-
-  compare = pic_proc_new(pic, ir_macro_compare, "<ir-macro-comparator>");
-  pic_proc_cv_init(pic, compare, 3);
-  pic_proc_cv_set(pic, compare, 0, use_env);
-  pic_proc_cv_set(pic, compare, 1, mac_env);
-  pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
-
-  cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-
-  expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), cxt, &ir);
-  expr = pic_apply3(pic, cb, expr, pic_obj_value(inject), pic_obj_value(compare));
-  expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), cxt, &ir);
-
-  return expr;
-}
-
-static pic_value
-pic_macro_ir_macro_transformer(pic_state *pic)
-{
-  struct pic_proc *cb, *proc;
-
-  pic_get_args(pic, "l", &cb);
-
-  proc = pic_proc_new(pic, ir_macro_call, "<ir-macro-procedure>");
-  pic_proc_cv_init(pic, proc, 1);
-  pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
-
-  return pic_obj_value(proc);
-}
-
 static pic_value
 pic_macro_make_identifier(pic_state *pic)
 {
@@ -966,8 +750,6 @@ pic_init_macro(pic_state *pic)
     pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc);
     pic_defun(pic, "identifier?", pic_macro_identifier_p);
     pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
-    pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer);
-    pic_defun(pic, "ir-macro-transformer", pic_macro_ir_macro_transformer);
     pic_defun(pic, "make-identifier", pic_macro_make_identifier);
   }
 }

From bb9be2c628233dbad2c8f295a716509f2f868f76 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 13:45:09 +0900
Subject: [PATCH 137/216] remove c impl of make-syntactic-closure

---
 src/macro.c | 29 -----------------------------
 1 file changed, 29 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 8be145f6..c6a5c286 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -637,17 +637,6 @@ pic_macro_macroexpand(pic_state *pic)
   return pic_macroexpand(pic, expr);
 }
 
-static struct pic_sc *
-sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  struct pic_sc *sc;
-
-  sc = (struct pic_sc *)pic_obj_alloc(pic, sizeof(struct pic_sc), PIC_TT_SC);
-  sc->expr = expr;
-  sc->senv = senv;
-  return sc;
-}
-
 static bool
 sc_identifier_p(pic_value obj)
 {
@@ -677,23 +666,6 @@ sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_
   return pic_eq_p(x, y);
 }
 
-static pic_value
-pic_macro_make_sc(pic_state *pic)
-{
-  pic_value senv, free_vars, expr;
-  struct pic_sc *sc;
-
-  pic_get_args(pic, "ooo", &senv, &free_vars, &expr);
-
-  if (! pic_senv_p(senv))
-    pic_error(pic, "make-syntactic-closure: senv required");
-
-  /* just ignore free_vars for now */
-  sc = sc_new(pic, expr, pic_senv_ptr(senv));
-
-  return pic_obj_value(sc);
-}
-
 static pic_value
 pic_macro_identifier_p(pic_state *pic)
 {
@@ -747,7 +719,6 @@ pic_init_macro(pic_state *pic)
 
     pic_defun(pic, "gensym", pic_macro_gensym);
     pic_defun(pic, "macroexpand", pic_macro_macroexpand);
-    pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc);
     pic_defun(pic, "identifier?", pic_macro_identifier_p);
     pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
     pic_defun(pic, "make-identifier", pic_macro_make_identifier);

From e5511027e8eae660f81f144200cab86ca1871101 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 13:58:08 +0900
Subject: [PATCH 138/216] add type check guards to comparators

---
 piclib/built-in.scm | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index 51cfa5f5..c3323516 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -113,8 +113,12 @@
               (dictionary-set! cache sym id)
               id)))
 
-      (define (compare sym1 sym2)
-        (identifier=? use-env sym1 use-env sym2))
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? use-env x use-env y))))
 
       (f expr rename compare)))
 
@@ -161,8 +165,12 @@
               (dictionary-set! cache sym id)
               id)))
 
-      (define (compare sym1 sym2)
-        (identifier=? mac-env sym1 mac-env sym2))
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? mac-env x mac-env y))))
 
       (unwrap (f (wrap expr) inject compare))))
 

From 8781b9a6aaa7ecc50d15b8f9418b315723d1005c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 13:58:45 +0900
Subject: [PATCH 139/216] publish pic_identifier_p and pic_identifier_eq_p

---
 include/picrin/macro.h |  3 +++
 src/macro.c            | 57 ++++++++++++++++++------------------------
 2 files changed, 27 insertions(+), 33 deletions(-)

diff --git a/include/picrin/macro.h b/include/picrin/macro.h
index b733a5fe..31fe5983 100644
--- a/include/picrin/macro.h
+++ b/include/picrin/macro.h
@@ -38,6 +38,9 @@ struct pic_sc {
 
 struct pic_senv *pic_null_syntactic_environment(pic_state *);
 
+bool pic_identifier_p(pic_state *pic, pic_value obj);
+bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym);
+
 pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym);
 bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */);
 void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym);
diff --git a/src/macro.c b/src/macro.c
index c6a5c286..859bdeb5 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -615,6 +615,25 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
   pic_export(pic, sym);
 }
 
+bool
+pic_identifier_p(pic_state *pic, pic_value obj)
+{
+  return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj));
+}
+
+bool
+pic_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_sym x, struct pic_senv *e2, pic_sym y)
+{
+  struct pic_dict *cxt;
+
+  cxt = pic_dict_new(pic);
+
+  x = make_identifier(pic, x, e1, cxt);
+  y = make_identifier(pic, y, e2, cxt);
+
+  return x == y;
+}
+
 static pic_value
 pic_macro_gensym(pic_state *pic)
 {
@@ -637,35 +656,6 @@ pic_macro_macroexpand(pic_state *pic)
   return pic_macroexpand(pic, expr);
 }
 
-static bool
-sc_identifier_p(pic_value obj)
-{
-  if (pic_sym_p(obj)) {
-    return true;
-  }
-  if (pic_sc_p(obj)) {
-    return sc_identifier_p(pic_sc_ptr(obj)->expr);
-  }
-  return false;
-}
-
-static bool
-sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y)
-{
-  struct pic_dict *cxt;
-
-  if (! (sc_identifier_p(x) && sc_identifier_p(y))) {
-    return false;
-  }
-
-  cxt = pic_dict_new(pic);
-
-  x = macroexpand(pic, x, e1, cxt);
-  y = macroexpand(pic, y, e2, cxt);
-
-  return pic_eq_p(x, y);
-}
-
 static pic_value
 pic_macro_identifier_p(pic_state *pic)
 {
@@ -673,16 +663,17 @@ pic_macro_identifier_p(pic_state *pic)
 
   pic_get_args(pic, "o", &obj);
 
-  return pic_bool_value(sc_identifier_p(obj));
+  return pic_bool_value(pic_identifier_p(pic, obj));
 }
 
 static pic_value
 pic_macro_identifier_eq_p(pic_state *pic)
 {
-  pic_value e, x, f, y;
+  pic_sym x, y;
+  pic_value e, f;
   struct pic_senv *e1, *e2;
 
-  pic_get_args(pic, "oooo", &e, &x, &f, &y);
+  pic_get_args(pic, "omom", &e, &x, &f, &y);
 
   if (! pic_senv_p(e)) {
     pic_error(pic, "unexpected type of argument 1");
@@ -693,7 +684,7 @@ pic_macro_identifier_eq_p(pic_state *pic)
   }
   e2 = pic_senv_ptr(f);
 
-  return pic_bool_value(sc_identifier_eq_p(pic, e1, x, e2, y));
+  return pic_bool_value(pic_identifier_eq_p(pic, e1, x, e2, y));
 }
 
 static pic_value

From 6cc37281d63e9bd0b73adb9c85240c5b88d0c666 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 13:59:21 +0900
Subject: [PATCH 140/216] remove pic_tt_sc type

---
 include/picrin/macro.h | 9 ---------
 include/picrin/value.h | 3 ---
 src/codegen.c          | 1 -
 src/gc.c               | 9 ---------
 src/macro.c            | 3 ---
 src/write.c            | 5 -----
 6 files changed, 30 deletions(-)

diff --git a/include/picrin/macro.h b/include/picrin/macro.h
index 31fe5983..023c2785 100644
--- a/include/picrin/macro.h
+++ b/include/picrin/macro.h
@@ -21,15 +21,6 @@ struct pic_macro {
   struct pic_senv *senv;
 };
 
-struct pic_sc {
-  PIC_OBJECT_HEADER
-  pic_value expr;
-  struct pic_senv *senv;
-};
-
-#define pic_sc_p(v) (pic_type(v) == PIC_TT_SC)
-#define pic_sc_ptr(v) ((struct pic_sc *)pic_ptr(v))
-
 #define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO)
 #define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v))
 
diff --git a/include/picrin/value.h b/include/picrin/value.h
index d6a07e20..e8eb7342 100644
--- a/include/picrin/value.h
+++ b/include/picrin/value.h
@@ -111,7 +111,6 @@ enum pic_tt {
   PIC_TT_CONT,
   PIC_TT_SENV,
   PIC_TT_MACRO,
-  PIC_TT_SC,
   PIC_TT_LIB,
   PIC_TT_VAR,
   PIC_TT_IREP,
@@ -256,8 +255,6 @@ pic_type_repr(enum pic_tt tt)
     return "cont";
   case PIC_TT_PROC:
     return "proc";
-  case PIC_TT_SC:
-    return "sc";
   case PIC_TT_SENV:
     return "senv";
   case PIC_TT_MACRO:
diff --git a/src/codegen.c b/src/codegen.c
index 77e74e26..d098842e 100644
--- a/src/codegen.c
+++ b/src/codegen.c
@@ -826,7 +826,6 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
   case PIC_TT_ERROR:
   case PIC_TT_SENV:
   case PIC_TT_MACRO:
-  case PIC_TT_SC:
   case PIC_TT_LIB:
   case PIC_TT_VAR:
   case PIC_TT_IREP:
diff --git a/src/gc.c b/src/gc.c
index 97532671..21aebb9e 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -461,12 +461,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     }
     break;
   }
-  case PIC_TT_SC: {
-    struct pic_sc *sc = (struct pic_sc *)obj;
-    gc_mark(pic, sc->expr);
-    gc_mark_object(pic, (struct pic_object *)sc->senv);
-    break;
-  }
   case PIC_TT_LIB: {
     struct pic_lib *lib = (struct pic_lib *)obj;
     gc_mark(pic, lib->name);
@@ -641,9 +635,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
   case PIC_TT_MACRO: {
     break;
   }
-  case PIC_TT_SC: {
-    break;
-  }
   case PIC_TT_LIB: {
     struct pic_lib *lib = (struct pic_lib *)obj;
     xh_destroy(&lib->exports);
diff --git a/src/macro.c b/src/macro.c
index 859bdeb5..d8398523 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -454,9 +454,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
 #endif
 
   switch (pic_type(expr)) {
-  case PIC_TT_SC: {
-    return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, cxt);
-  }
   case PIC_TT_SYMBOL: {
     return macroexpand_symbol(pic, pic_sym(expr), senv, cxt);
   }
diff --git a/src/write.c b/src/write.c
index 4aae7e44..9ced3904 100644
--- a/src/write.c
+++ b/src/write.c
@@ -318,11 +318,6 @@ write_core(struct writer_control *p, pic_value obj)
   case PIC_TT_MACRO:
     xfprintf(file, "#<macro %p>", pic_ptr(obj));
     break;
-  case PIC_TT_SC:
-    xfprintf(file, "#<sc %p: ", pic_ptr(obj));
-    write_core(p, pic_sc_ptr(obj)->expr);
-    xfprintf(file, ">");
-    break;
   case PIC_TT_LIB:
     xfprintf(file, "#<lib %p>", pic_ptr(obj));
     break;

From 6104a69e2b4114a646a6e064728b466892379477 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:10:38 +0900
Subject: [PATCH 141/216] generate identifier for unbound symbol in
 context-free

---
 src/macro.c | 8 +-------
 1 file changed, 1 insertion(+), 7 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index d8398523..ae41f951 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -86,13 +86,7 @@ make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_d
       break;
     senv = senv->up;
   }
-  if (pic_dict_has(pic, cxt, sym)) {
-    return pic_sym(pic_dict_ref(pic, cxt, sym));
-  } else {
-    rename = pic_gensym(pic, sym);
-    pic_dict_set(pic, cxt, sym, pic_sym_value(rename));
-    return rename;
-  }
+  return pic_gensym(pic, sym);
 }
 
 static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);

From 5b41b979d9ca258f3582afac190f1f56f32bac92 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:11:33 +0900
Subject: [PATCH 142/216] [bugfix] abuse compare of er-macro

---
 piclib/built-in.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index c3323516..379208a7 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -1418,7 +1418,7 @@
        (define (compile-expand ellipsis reserved template)
 	 (letrec ((compile-expand-base
 		   (lambda (template ellipsis-valid)
-		     (cond ((member template reserved compare)
+		     (cond ((member template reserved eq?)
 			    (values (var->sym template) (list template)))
 			   ((symbol? template)
 			    (values `(rename ',template) '()))

From 0fb9e18735031e0e1dcc569c9c741a978a3ba858 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:14:14 +0900
Subject: [PATCH 143/216] cxt objects are no longer used

---
 src/macro.c | 86 +++++++++++++++++++++++++----------------------------
 1 file changed, 41 insertions(+), 45 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index ae41f951..49fbe345 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -74,7 +74,7 @@ find_macro(pic_state *pic, pic_sym rename)
 }
 
 static pic_sym
-make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
+make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv)
 {
   pic_sym rename;
 
@@ -89,12 +89,12 @@ make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_d
   return pic_gensym(pic, sym);
 }
 
-static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);
+static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);
 
 static pic_value
-macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv)
 {
-  return pic_sym_value(make_identifier(pic, sym, senv, cxt));
+  return pic_sym_value(make_identifier(pic, sym, senv));
 }
 
 static pic_value
@@ -181,17 +181,17 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr)
 }
 
 static pic_value
-macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv)
 {
   size_t ai = pic_gc_arena_preserve(pic);
   pic_value x, head, tail;
 
   if (pic_pair_p(obj)) {
-    head = macroexpand(pic, pic_car(pic, obj), senv, cxt);
-    tail = macroexpand_list(pic, pic_cdr(pic, obj), senv, cxt);
+    head = macroexpand(pic, pic_car(pic, obj), senv);
+    tail = macroexpand_list(pic, pic_cdr(pic, obj), senv);
     x = pic_cons(pic, head, tail);
   } else {
-    x = macroexpand(pic, obj, senv, cxt);
+    x = macroexpand(pic, obj, senv);
   }
 
   pic_gc_arena_restore(pic, ai);
@@ -200,7 +200,7 @@ macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pi
 }
 
 static pic_value
-macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
   pic_value formal, body;
   struct pic_senv *in;
@@ -218,7 +218,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
     pic_value v = pic_car(pic, a);
 
     if (! pic_sym_p(v)) {
-      v = macroexpand(pic, v, senv, cxt);
+      v = macroexpand(pic, v, senv);
     }
     if (! pic_sym_p(v)) {
       pic_error(pic, "syntax error");
@@ -226,7 +226,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
     pic_add_rename(pic, in, pic_sym(v));
   }
   if (! pic_sym_p(a)) {
-    a = macroexpand(pic, a, senv, cxt);
+    a = macroexpand(pic, a, senv);
   }
   if (pic_sym_p(a)) {
     pic_add_rename(pic, in, pic_sym(a));
@@ -235,14 +235,14 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
     pic_error(pic, "syntax error");
   }
 
-  formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt);
-  body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt);
+  formal = macroexpand_list(pic, pic_cadr(pic, expr), in);
+  body = macroexpand_list(pic, pic_cddr(pic, expr), in);
 
   return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body));
 }
 
 static pic_value
-macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
   pic_sym sym;
   pic_value formal, body, var, val;
@@ -261,7 +261,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
     var = formal;
   }
   if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv, cxt);
+    var = macroexpand(pic, var, senv);
   }
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
@@ -272,15 +272,15 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
   }
   body = pic_cddr(pic, expr);
   if (pic_pair_p(formal)) {
-    val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv, cxt);
+    val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv);
   } else {
-    val = macroexpand(pic, pic_car(pic, body), senv, cxt);
+    val = macroexpand(pic, pic_car(pic, body), senv);
   }
-  return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val);
+  return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv), val);
 }
 
 static pic_value
-macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
   pic_value var, val;
   pic_sym sym, rename;
@@ -291,7 +291,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, str
 
   var = pic_cadr(pic, expr);
   if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv, cxt);
+    var = macroexpand(pic, var, senv);
   }
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
@@ -366,7 +366,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
 }
 
 static pic_value
-macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
   struct pic_senv *in;
   pic_value formal, v, var, val;
@@ -387,7 +387,7 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st
   pic_for_each (v, formal) {
     var = pic_car(pic, v);
     if (! pic_sym_p(var)) {
-      var = macroexpand(pic, var, senv, cxt);
+      var = macroexpand(pic, var, senv);
     }
     if (! pic_sym_p(var)) {
       pic_error(pic, "binding to non-symbol object");
@@ -402,11 +402,11 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st
     }
     define_macro(pic, rename, pic_proc_ptr(val), senv);
   }
-  return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt));
+  return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in));
 }
 
 static pic_value
-macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
 {
   pic_value v, args;
 
@@ -435,11 +435,11 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
   puts("");
 #endif
 
-  return macroexpand(pic, v, senv, cxt);
+  return macroexpand(pic, v, senv);
 }
 
 static pic_value
-macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
 #if DEBUG
   printf("[macroexpand] expanding... ");
@@ -449,7 +449,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
 
   switch (pic_type(expr)) {
   case PIC_TT_SYMBOL: {
-    return macroexpand_symbol(pic, pic_sym(expr), senv, cxt);
+    return macroexpand_symbol(pic, pic_sym(expr), senv);
   }
   case PIC_TT_PAIR: {
     pic_value car;
@@ -459,7 +459,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
       pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
     }
 
-    car = macroexpand(pic, pic_car(pic, expr), senv, cxt);
+    car = macroexpand(pic, pic_car(pic, expr), senv);
     if (pic_sym_p(car)) {
       pic_sym tag = pic_sym(car);
 
@@ -473,33 +473,33 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
         return macroexpand_export(pic, expr);
       }
       else if (tag == pic->rDEFINE_SYNTAX) {
-        return macroexpand_defsyntax(pic, expr, senv, cxt);
+        return macroexpand_defsyntax(pic, expr, senv);
       }
       else if (tag == pic->rDEFINE_MACRO) {
         return macroexpand_defmacro(pic, expr, senv);
       }
       else if (tag == pic->rLET_SYNTAX) {
-        return macroexpand_let_syntax(pic, expr, senv, cxt);
+        return macroexpand_let_syntax(pic, expr, senv);
       }
       /* else if (tag == pic->sLETREC_SYNTAX) { */
-      /*   return macroexpand_letrec_syntax(pic, expr, senv, cxt); */
+      /*   return macroexpand_letrec_syntax(pic, expr, senv); */
       /* } */
       else if (tag == pic->rLAMBDA) {
-        return macroexpand_lambda(pic, expr, senv, cxt);
+        return macroexpand_lambda(pic, expr, senv);
       }
       else if (tag == pic->rDEFINE) {
-        return macroexpand_define(pic, expr, senv, cxt);
+        return macroexpand_define(pic, expr, senv);
       }
       else if (tag == pic->rQUOTE) {
         return macroexpand_quote(pic, expr);
       }
 
       if ((mac = find_macro(pic, tag)) != NULL) {
-        return macroexpand_macro(pic, mac, expr, senv, cxt);
+        return macroexpand_macro(pic, mac, expr, senv);
       }
     }
 
-    return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt));
+    return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
   }
   case PIC_TT_EOF:
   case PIC_TT_NIL:
@@ -532,12 +532,12 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
 }
 
 static pic_value
-macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
   size_t ai = pic_gc_arena_preserve(pic);
   pic_value v;
 
-  v = macroexpand_node(pic, expr, senv, cxt);
+  v = macroexpand_node(pic, expr, senv);
 
   pic_gc_arena_restore(pic, ai);
   pic_gc_protect(pic, v);
@@ -555,7 +555,7 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   puts("");
 #endif
 
-  v = macroexpand(pic, expr, pic->lib->senv, pic_dict_new(pic));
+  v = macroexpand(pic, expr, pic->lib->senv);
 
 #if DEBUG
   puts("after expand:");
@@ -615,12 +615,8 @@ pic_identifier_p(pic_state *pic, pic_value obj)
 bool
 pic_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_sym x, struct pic_senv *e2, pic_sym y)
 {
-  struct pic_dict *cxt;
-
-  cxt = pic_dict_new(pic);
-
-  x = make_identifier(pic, x, e1, cxt);
-  y = make_identifier(pic, y, e2, cxt);
+  x = make_identifier(pic, x, e1);
+  y = make_identifier(pic, y, e2);
 
   return x == y;
 }
@@ -688,7 +684,7 @@ pic_macro_make_identifier(pic_state *pic)
 
   pic_assert_type(pic, obj, senv);
 
-  return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj), pic_dict_new(pic)));
+  return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj)));
 }
 
 void

From e9c84536bd85ff8d663f51b95182daaefeacffed Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:17:47 +0900
Subject: [PATCH 144/216] fix #160

---
 contrib/20.for/piclib/for.scm | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/contrib/20.for/piclib/for.scm b/contrib/20.for/piclib/for.scm
index d37afd9f..3befa0ba 100644
--- a/contrib/20.for/piclib/for.scm
+++ b/contrib/20.for/piclib/for.scm
@@ -1,7 +1,6 @@
 (define-library (picrin control list)
   (import (scheme base)
-          (picrin control)
-          (scheme write))
+          (picrin control))
 
   (define-syntax for
     (syntax-rules ()

From b99bddcad03ec0d8a2d216b84bb06a53f9810957 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:22:53 +0900
Subject: [PATCH 145/216] rename built-in.scm to prelude.scm

---
 piclib/CMakeLists.txt                | 2 +-
 piclib/{built-in.scm => prelude.scm} | 0
 2 files changed, 1 insertion(+), 1 deletion(-)
 rename piclib/{built-in.scm => prelude.scm} (100%)

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index aaf66fdd..b32b3690 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,5 +1,5 @@
 list(APPEND PICLIB_SCHEME_LIBS
-  ${PROJECT_SOURCE_DIR}/piclib/built-in.scm
+  ${PROJECT_SOURCE_DIR}/piclib/prelude.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
diff --git a/piclib/built-in.scm b/piclib/prelude.scm
similarity index 100%
rename from piclib/built-in.scm
rename to piclib/prelude.scm

From 98bb47dfb685149690b964f7aed7c18e0bace754 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 10:04:06 +0900
Subject: [PATCH 146/216] remove pic_papply

---
 include/picrin/proc.h |  2 --
 src/proc.c            | 30 ------------------------------
 2 files changed, 32 deletions(-)

diff --git a/include/picrin/proc.h b/include/picrin/proc.h
index 039a4384..e6d9fdbc 100644
--- a/include/picrin/proc.h
+++ b/include/picrin/proc.h
@@ -59,8 +59,6 @@ int pic_proc_cv_size(pic_state *, struct pic_proc *);
 pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t);
 void pic_proc_cv_set(pic_state *, struct pic_proc *, size_t, pic_value);
 
-struct pic_proc *pic_papply(pic_state *, struct pic_proc *, pic_value);
-
 #if defined(__cplusplus)
 }
 #endif
diff --git a/src/proc.c b/src/proc.c
index cfb9bcbb..c96f0e62 100644
--- a/src/proc.c
+++ b/src/proc.c
@@ -99,36 +99,6 @@ pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v)
   proc->env->regs[i] = v;
 }
 
-static pic_value
-papply_call(pic_state *pic)
-{
-  size_t argc;
-  pic_value *argv, arg, arg_list;
-  struct pic_proc *proc;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  proc = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-  arg = pic_proc_cv_ref(pic, pic_get_proc(pic), 1);
-
-  arg_list = pic_list_by_array(pic, argc, argv);
-  arg_list = pic_cons(pic, arg, arg_list);
-  return pic_apply(pic, proc, arg_list);
-}
-
-struct pic_proc *
-pic_papply(pic_state *pic, struct pic_proc *proc, pic_value arg)
-{
-  struct pic_proc *pa_proc;
-
-  pa_proc = pic_proc_new(pic, papply_call, "<partial-applied-procedure>");
-  pic_proc_cv_init(pic, pa_proc, 2);
-  pic_proc_cv_set(pic, pa_proc, 0, pic_obj_value(proc));
-  pic_proc_cv_set(pic, pa_proc, 1, arg);
-
-  return pa_proc;
-}
-
 static pic_value
 pic_proc_proc_p(pic_state *pic)
 {

From f46114ca034cee7e5088cb5b36628d8f09878792 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 10:08:58 +0900
Subject: [PATCH 147/216] [experimental] use attributes for cv implementation

---
 src/proc.c | 24 +++---------------------
 1 file changed, 3 insertions(+), 21 deletions(-)

diff --git a/src/proc.c b/src/proc.c
index c96f0e62..d7f391b0 100644
--- a/src/proc.c
+++ b/src/proc.c
@@ -61,42 +61,24 @@ pic_proc_attr(pic_state *pic, struct pic_proc *proc)
 void
 pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size)
 {
-  struct pic_env *env;
-
-  if (proc->env != NULL) {
-    pic_error(pic, "env slot already in use");
-  }
-  env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
-  env->regc = cv_size;
-  env->regs = (pic_value *)pic_calloc(pic, cv_size, sizeof(pic_value));
-  env->up = NULL;
-
-  proc->env = env;
 }
 
 int
 pic_proc_cv_size(pic_state *pic, struct pic_proc *proc)
 {
-  UNUSED(pic);
-  return proc->env ? proc->env->regc : 0;
+  return 0;
 }
 
 pic_value
 pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i)
 {
-  if (proc->env == NULL) {
-    pic_error(pic, "no closed env");
-  }
-  return proc->env->regs[i];
+  return pic_dict_ref(pic, pic_proc_attr(pic, proc), i); /* FIXME */
 }
 
 void
 pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v)
 {
-  if (proc->env == NULL) {
-    pic_error(pic, "no closed env");
-  }
-  proc->env->regs[i] = v;
+  pic_dict_set(pic, pic_proc_attr(pic, proc), i, v); /* FIXME */
 }
 
 static pic_value

From cb3c4e8e22bad715552662993cf8ced11b2da478 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 10:13:18 +0900
Subject: [PATCH 148/216] remove use of pic_proc_cv_init

---
 include/picrin/proc.h |  2 --
 src/cont.c            |  2 --
 src/proc.c            | 11 -----------
 3 files changed, 15 deletions(-)

diff --git a/include/picrin/proc.h b/include/picrin/proc.h
index e6d9fdbc..d72ddc04 100644
--- a/include/picrin/proc.h
+++ b/include/picrin/proc.h
@@ -54,8 +54,6 @@ pic_sym pic_proc_name(struct pic_proc *);
 struct pic_dict *pic_proc_attr(pic_state *, struct pic_proc *);
 
 /* closed variables accessor */
-void pic_proc_cv_init(pic_state *, struct pic_proc *, size_t);
-int pic_proc_cv_size(pic_state *, struct pic_proc *);
 pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t);
 void pic_proc_cv_set(pic_state *, struct pic_proc *, size_t, pic_value);
 
diff --git a/src/cont.c b/src/cont.c
index f84e55c7..f76a6695 100644
--- a/src/cont.c
+++ b/src/cont.c
@@ -245,7 +245,6 @@ pic_callcc(pic_state *pic, struct pic_proc *proc)
     c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
 
     /* save the continuation object in proc */
-    pic_proc_cv_init(pic, c, 1);
     pic_proc_cv_set(pic, c, 0, pic_obj_value(cont));
 
     return pic_apply1(pic, proc, pic_obj_value(c));
@@ -267,7 +266,6 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
     c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
 
     /* save the continuation object in proc */
-    pic_proc_cv_init(pic, c, 1);
     pic_proc_cv_set(pic, c, 0, pic_obj_value(cont));
 
     return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c)));
diff --git a/src/proc.c b/src/proc.c
index d7f391b0..bd11bcf4 100644
--- a/src/proc.c
+++ b/src/proc.c
@@ -58,17 +58,6 @@ pic_proc_attr(pic_state *pic, struct pic_proc *proc)
   return proc->attr;
 }
 
-void
-pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size)
-{
-}
-
-int
-pic_proc_cv_size(pic_state *pic, struct pic_proc *proc)
-{
-  return 0;
-}
-
 pic_value
 pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i)
 {

From 4714df48f0712c251aedd1b9099f1eaf76d73b3f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:28:36 +0900
Subject: [PATCH 149/216] s/pic_proc_attr/pic_attr/g

---
 include/picrin/proc.h | 2 +-
 src/proc.c            | 8 ++++----
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/include/picrin/proc.h b/include/picrin/proc.h
index d72ddc04..40dfc46c 100644
--- a/include/picrin/proc.h
+++ b/include/picrin/proc.h
@@ -51,7 +51,7 @@ struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_en
 
 pic_sym pic_proc_name(struct pic_proc *);
 
-struct pic_dict *pic_proc_attr(pic_state *, struct pic_proc *);
+struct pic_dict *pic_attr(pic_state *, struct pic_proc *);
 
 /* closed variables accessor */
 pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t);
diff --git a/src/proc.c b/src/proc.c
index bd11bcf4..e3694a25 100644
--- a/src/proc.c
+++ b/src/proc.c
@@ -50,7 +50,7 @@ pic_proc_name(struct pic_proc *proc)
 }
 
 struct pic_dict *
-pic_proc_attr(pic_state *pic, struct pic_proc *proc)
+pic_attr(pic_state *pic, struct pic_proc *proc)
 {
   if (proc->attr == NULL) {
     proc->attr = pic_dict_new(pic);
@@ -61,13 +61,13 @@ pic_proc_attr(pic_state *pic, struct pic_proc *proc)
 pic_value
 pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i)
 {
-  return pic_dict_ref(pic, pic_proc_attr(pic, proc), i); /* FIXME */
+  return pic_dict_ref(pic, pic_attr(pic, proc), i); /* FIXME */
 }
 
 void
 pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v)
 {
-  pic_dict_set(pic, pic_proc_attr(pic, proc), i, v); /* FIXME */
+  pic_dict_set(pic, pic_attr(pic, proc), i, v); /* FIXME */
 }
 
 static pic_value
@@ -166,7 +166,7 @@ pic_proc_attribute(pic_state *pic)
 
   pic_get_args(pic, "l", &proc);
 
-  return pic_obj_value(pic_proc_attr(pic, proc));
+  return pic_obj_value(pic_attr(pic, proc));
 }
 
 void

From c601dbf27e50514a5ec51ef95e1cfb3781e08575 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:31:26 +0900
Subject: [PATCH 150/216] rename pic_proc_cv_ref to pic_attr_ref

---
 include/picrin/proc.h | 6 ++----
 src/cont.c            | 6 +++---
 src/proc.c            | 8 ++++----
 3 files changed, 9 insertions(+), 11 deletions(-)

diff --git a/include/picrin/proc.h b/include/picrin/proc.h
index 40dfc46c..b91960de 100644
--- a/include/picrin/proc.h
+++ b/include/picrin/proc.h
@@ -52,10 +52,8 @@ struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_en
 pic_sym pic_proc_name(struct pic_proc *);
 
 struct pic_dict *pic_attr(pic_state *, struct pic_proc *);
-
-/* closed variables accessor */
-pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t);
-void pic_proc_cv_set(pic_state *, struct pic_proc *, size_t, pic_value);
+pic_value pic_attr_ref(pic_state *, struct pic_proc *, const char *);
+void pic_attr_set(pic_state *, struct pic_proc *, const char *, pic_value);
 
 #if defined(__cplusplus)
 }
diff --git a/src/cont.c b/src/cont.c
index f76a6695..de076874 100644
--- a/src/cont.c
+++ b/src/cont.c
@@ -221,7 +221,7 @@ cont_call(pic_state *pic)
   proc = pic_get_proc(pic);
   pic_get_args(pic, "*", &argc, &argv);
 
-  cont = (struct pic_cont *)pic_ptr(pic_proc_cv_ref(pic, proc, 0));
+  cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont"));
   cont->results = pic_list_by_array(pic, argc, argv);
 
   /* execute guard handlers */
@@ -245,7 +245,7 @@ pic_callcc(pic_state *pic, struct pic_proc *proc)
     c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
 
     /* save the continuation object in proc */
-    pic_proc_cv_set(pic, c, 0, pic_obj_value(cont));
+    pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
 
     return pic_apply1(pic, proc, pic_obj_value(c));
   }
@@ -266,7 +266,7 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
     c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
 
     /* save the continuation object in proc */
-    pic_proc_cv_set(pic, c, 0, pic_obj_value(cont));
+    pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
 
     return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c)));
   }
diff --git a/src/proc.c b/src/proc.c
index e3694a25..84967224 100644
--- a/src/proc.c
+++ b/src/proc.c
@@ -59,15 +59,15 @@ pic_attr(pic_state *pic, struct pic_proc *proc)
 }
 
 pic_value
-pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i)
+pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key)
 {
-  return pic_dict_ref(pic, pic_attr(pic, proc), i); /* FIXME */
+  return pic_dict_ref(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key));
 }
 
 void
-pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v)
+pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v)
 {
-  pic_dict_set(pic, pic_attr(pic, proc), i, v); /* FIXME */
+  pic_dict_set(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key), v);
 }
 
 static pic_value

From 32174d7855e70660e28964944b1d192225483ace Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:38:18 +0900
Subject: [PATCH 151/216] remove box

---
 include/picrin/box.h   | 28 ----------------------------
 include/picrin/value.h |  3 ---
 src/box.c              | 30 ------------------------------
 src/codegen.c          |  1 -
 src/gc.c               |  8 --------
 src/macro.c            |  1 -
 src/write.c            |  3 ---
 7 files changed, 74 deletions(-)
 delete mode 100644 include/picrin/box.h
 delete mode 100644 src/box.c

diff --git a/include/picrin/box.h b/include/picrin/box.h
deleted file mode 100644
index f9826eed..00000000
--- a/include/picrin/box.h
+++ /dev/null
@@ -1,28 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_BOX_H__
-#define PICRIN_BOX_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_box {
-  PIC_OBJECT_HEADER
-  pic_value value;
-};
-
-#define pic_box_p(v) (pic_type(v) == PIC_TT_BOX)
-#define pic_box_ptr(v) ((struct pic_box *)pic_ptr(v))
-
-pic_value pic_box(pic_state *, pic_value);
-pic_value pic_unbox(pic_state *, pic_value);
-void pic_set_box(pic_state *, pic_value, pic_value);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif
diff --git a/include/picrin/value.h b/include/picrin/value.h
index e8eb7342..283bac28 100644
--- a/include/picrin/value.h
+++ b/include/picrin/value.h
@@ -115,7 +115,6 @@ enum pic_tt {
   PIC_TT_VAR,
   PIC_TT_IREP,
   PIC_TT_DATA,
-  PIC_TT_BOX,
   PIC_TT_DICT
 };
 
@@ -267,8 +266,6 @@ pic_type_repr(enum pic_tt tt)
     return "irep";
   case PIC_TT_DATA:
     return "data";
-  case PIC_TT_BOX:
-    return "box";
   case PIC_TT_DICT:
     return "dict";
   }
diff --git a/src/box.c b/src/box.c
deleted file mode 100644
index b9948fc7..00000000
--- a/src/box.c
+++ /dev/null
@@ -1,30 +0,0 @@
-#include "picrin.h"
-#include "picrin/box.h"
-
-pic_value
-pic_box(pic_state *pic, pic_value value)
-{
-  struct pic_box *box;
-
-  box = (struct pic_box *)pic_obj_alloc(pic, sizeof(struct pic_box), PIC_TT_BOX);
-  box->value = value;
-  return pic_obj_value(box);
-}
-
-pic_value
-pic_unbox(pic_state *pic, pic_value box)
-{
-  if (! pic_box_p(box)) {
-    pic_errorf(pic, "expected box, but got ~s", box);
-  }
-  return pic_box_ptr(box)->value;
-}
-
-void
-pic_set_box(pic_state *pic, pic_value box, pic_value value)
-{
-  if (! pic_box_p(box)) {
-    pic_errorf(pic, "expected box, but got ~s", box);
-  }
-  pic_box_ptr(box)->value = value;
-}
diff --git a/src/codegen.c b/src/codegen.c
index d098842e..df4c0239 100644
--- a/src/codegen.c
+++ b/src/codegen.c
@@ -830,7 +830,6 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
   case PIC_TT_VAR:
   case PIC_TT_IREP:
   case PIC_TT_DATA:
-  case PIC_TT_BOX:
   case PIC_TT_DICT:
     pic_errorf(pic, "invalid expression given: ~s", obj);
   }
diff --git a/src/gc.c b/src/gc.c
index 21aebb9e..aa2d383d 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -494,11 +494,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     }
     break;
   }
-  case PIC_TT_BOX: {
-    struct pic_box *box = (struct pic_box *)obj;
-    gc_mark(pic, box->value);
-    break;
-  }
   case PIC_TT_DICT: {
     struct pic_dict *dict = (struct pic_dict *)obj;
     xh_iter it;
@@ -656,9 +651,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     xh_destroy(&data->storage);
     break;
   }
-  case PIC_TT_BOX: {
-    break;
-  }
   case PIC_TT_DICT: {
     struct pic_dict *dict = (struct pic_dict *)obj;
     xh_destroy(&dict->hash);
diff --git a/src/macro.c b/src/macro.c
index 49fbe345..636a968e 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -524,7 +524,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
   case PIC_TT_VAR:
   case PIC_TT_IREP:
   case PIC_TT_DATA:
-  case PIC_TT_BOX:
   case PIC_TT_DICT:
     pic_errorf(pic, "unexpected value type: ~s", expr);
   }
diff --git a/src/write.c b/src/write.c
index 9ced3904..61551b1a 100644
--- a/src/write.c
+++ b/src/write.c
@@ -330,9 +330,6 @@ write_core(struct writer_control *p, pic_value obj)
   case PIC_TT_DATA:
     xfprintf(file, "#<data %p>", pic_ptr(obj));
     break;
-  case PIC_TT_BOX:
-    xfprintf(file, "#<box %p>", pic_ptr(obj));
-    break;
   case PIC_TT_DICT:
     xfprintf(file, "#<dict %p>", pic_ptr(obj));
     break;

From 2758c55e3ea515092cea07a929a2e3010bd4f4c5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:41:00 +0900
Subject: [PATCH 152/216] remove box.h include

---
 src/gc.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/gc.c b/src/gc.c
index aa2d383d..d77393c8 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -19,7 +19,6 @@
 #include "picrin/lib.h"
 #include "picrin/var.h"
 #include "picrin/data.h"
-#include "picrin/box.h"
 #include "picrin/dict.h"
 
 #if GC_DEBUG

From 690bdcb83dbced37237dab15413ae5e52354bef1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:43:25 +0900
Subject: [PATCH 153/216] add srfi 111

---
 piclib/CMakeLists.txt | 1 +
 piclib/srfi/111.scm   | 8 ++++++++
 2 files changed, 9 insertions(+)
 create mode 100644 piclib/srfi/111.scm

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index b32b3690..6898de1b 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -8,4 +8,5 @@ list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/srfi/43.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/60.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/95.scm
+  ${PROJECT_SOURCE_DIR}/piclib/srfi/111.scm
   )
diff --git a/piclib/srfi/111.scm b/piclib/srfi/111.scm
new file mode 100644
index 00000000..aafb4c8b
--- /dev/null
+++ b/piclib/srfi/111.scm
@@ -0,0 +1,8 @@
+(define-library (srfi 111)
+  (import (scheme base))
+
+  (define-record-type box-type (box value) box?
+                      (value unbox set-box!))
+
+  (export box box?
+          unbox set-box!))

From f66bea4e97e37045fa4a593584521feb3867859b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:47:50 +0900
Subject: [PATCH 154/216] add close-syntax

---
 piclib/prelude.scm | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 379208a7..3b84c974 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -92,6 +92,9 @@
                      (dictionary-set! cache atom id)
                      id)))))))
 
+  (define (close-syntax form env)
+    (make-syntactic-closure form '() env))
+
   (define (sc-macro-transformer f)
     (lambda (expr use-env mac-env)
       (make-syntactic-closure mac-env '() (f expr use-env))))
@@ -174,7 +177,9 @@
 
       (unwrap (f (wrap expr) inject compare))))
 
-  (export sc-macro-transformer
+  (export make-syntactic-closure
+          close-syntax
+          sc-macro-transformer
           rsc-macro-transformer
           er-macro-transformer
           ir-macro-transformer))

From 124ad994b288aba3d3e32b8d66b54814f5e37e81 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 17 Jul 2014 16:49:28 +0900
Subject: [PATCH 155/216] update docs

---
 docs/libs.rst | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/docs/libs.rst b/docs/libs.rst
index f85938eb..ced52fd2 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -53,10 +53,15 @@ Utility functions and syntaces for macro definition.
 
 Old-fashioned macro.
 
-- make-syntactic-closure
 - identifier?
 - identifier=?
 
+- make-syntactic-closure
+- close-syntax
+
+- sc-macro-transformer
+- rsc-macro-transformer
+
 Syntactic closures.
 
 - er-macro-transformer

From 01b086fb61fbbb52cbfb4d9f7db848441210e9c9 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Thu, 17 Jul 2014 20:47:13 +0900
Subject: [PATCH 156/216] fix a bug of `string-copy!` with same dist and src

---
 src/string.c | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/src/string.c b/src/string.c
index 6015688c..73dba061 100644
--- a/src/string.c
+++ b/src/string.c
@@ -350,6 +350,9 @@ pic_str_string_copy_ip(pic_state *pic)
   case 4:
     end = pic_strlen(from);
   }
+  if (to == from) {
+    from = pic_substr(pic, from, 0, end);
+  }
 
   while (start < end) {
     pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++));

From 295d7fde311f02172a73d24e510c433d5ac5aa39 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Thu, 17 Jul 2014 21:48:19 +0900
Subject: [PATCH 157/216] allow pipe syntax

---
 src/read.c | 44 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 44 insertions(+)

diff --git a/src/read.c b/src/read.c
index f8836e44..734973d8 100644
--- a/src/read.c
+++ b/src/read.c
@@ -4,6 +4,7 @@
 
 #include <ctype.h>
 #include <math.h>
+#include <stdlib.h>
 #include "picrin.h"
 #include "picrin/error.h"
 #include "picrin/pair.h"
@@ -354,6 +355,47 @@ read_string(pic_state *pic, struct pic_port *port, char c)
   return pic_obj_value(str);
 }
 
+static pic_value
+read_pipe(pic_state *pic, struct pic_port *port, char c)
+{
+  char *buf;
+  size_t size, cnt;
+  pic_sym sym;
+
+  size = 256;
+  buf = pic_alloc(pic, size);
+  cnt = 0;
+  while ((c = next(port)) != '|') {
+    if (c == '\\') {
+      switch (c = next(port)) {
+      case 'a': c = '\a'; break;
+      case 'b': c = '\b'; break;
+      case 't': c = '\t'; break;
+      case 'n': c = '\n'; break;
+      case 'r': c = '\r'; break;
+      case 'x':{
+        char hex[2];            /* Currently supports only ascii chars */
+        size_t i = 0;
+        while((c = (next(port))) != ';' && i < 6)
+          hex[i++] = c;
+        c = (char)strtol(hex, NULL, 16);
+        break;
+      }
+      }
+    }
+    buf[cnt++] = c;
+    if (cnt >= size) {
+      buf = pic_realloc(pic, buf, size *= 2);
+    }
+  }
+  buf[cnt] = '\0';
+
+  sym = pic_intern_cstr(pic, buf);
+  pic_free(pic, buf);
+
+  return pic_sym_value(sym);
+}
+
 static pic_value
 read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
 {
@@ -584,6 +626,8 @@ read_nullable(pic_state *pic, struct pic_port *port, char c)
     return read_comma(pic, port, c);
   case '"':
     return read_string(pic, port, c);
+  case '|':
+    return read_pipe(pic, port, c);
   case '0': case '1': case '2': case '3': case '4':
   case '5': case '6': case '7': case '8': case '9':
     return read_number(pic, port, c);

From fe30beadf1cb9ac0c613b950a4f7e8f00ac6a615 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Thu, 17 Jul 2014 21:30:54 +0900
Subject: [PATCH 158/216] Ignore shebang only when it's at the first line and
 allow reader directives at other places whlile ignores them for now

---
 src/read.c | 38 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 37 insertions(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index f8836e44..87ffe127 100644
--- a/src/read.c
+++ b/src/read.c
@@ -114,6 +114,35 @@ read_datum_comment(pic_state *pic, struct pic_port *port, char c)
   return pic_undef_value();
 }
 
+static pic_value
+read_directive(pic_state *pic, struct pic_port *port, char c)
+{
+  c = next(port);
+
+  if (c == 'n') {
+    if(expect(port, "o-fold-case")){
+      /* :FIXME: set no-fold-case flag */
+    }
+    else{
+      goto abort;
+    }
+  }
+  else if (c == 'f') {
+    if(expect(port, "old-case")){
+      /* :FIXME: set fold-case flag */      
+    }
+    else{
+      goto abort;
+    }
+  }
+  else{
+  abort:
+    pic_error(pic, "unknown directive");
+  }
+
+  return pic_undef_value();
+}
+
 static pic_value
 read_quote(pic_state *pic, struct pic_port *port, char c)
 {
@@ -541,7 +570,7 @@ read_dispatch(pic_state *pic, struct pic_port *port, char c)
 
   switch (c) {
   case '!':
-    return read_comment(pic, port, c);
+    return read_directive(pic, port, c);
   case '|':
     return read_block_comment(pic, port, c);
   case ';':
@@ -675,6 +704,13 @@ pic_parse_file(pic_state *pic, FILE *file)
   port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
   port->status = PIC_PORT_OPEN;
 
+  if(xfgetc(port->file) == '#' && xfgetc(port->file) == '!'){
+    while(xfgetc(port->file) != '\n');
+  }
+  else{
+    xfseek(port->file, 0, SEEK_SET);
+  }
+
   return pic_parse(pic, port);
 }
 

From b373ec433b579c2e9cd250801999493239c412c1 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Thu, 17 Jul 2014 22:23:06 +0900
Subject: [PATCH 159/216] ensure to correctly terminate hex string with non-hex
 char(';')

---
 src/read.c | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/src/read.c b/src/read.c
index 734973d8..7b059a30 100644
--- a/src/read.c
+++ b/src/read.c
@@ -374,10 +374,11 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
       case 'n': c = '\n'; break;
       case 'r': c = '\r'; break;
       case 'x':{
-        char hex[2];            /* Currently supports only ascii chars */
+        /* Currently supports only ascii chars */
+        size_t s = 3;        /* 2 bytes of hex + 1 byte of terminator(';')*/
+        char hex[s];
         size_t i = 0;
-        while((c = (next(port))) != ';' && i < 6)
-          hex[i++] = c;
+        while((hex[i++] = (next(port))) != ';' && i < s);
         c = (char)strtol(hex, NULL, 16);
         break;
       }

From c4862cb291a78c26b0ed387e3c919076bf2d7df6 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Fri, 18 Jul 2014 00:55:46 +0900
Subject: [PATCH 160/216] add test of circular list equivalence

---
 t/r7rs-tests.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 47 insertions(+)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index eeac935e..39e5a90d 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -635,6 +635,53 @@
 (test #t (equal? (make-vector 5 'a)
                  (make-vector 5 'a)))
 
+;; circular objects
+(let ((l '(1 . 2))
+      (m '(1 . 2)))
+  (set-cdr! l l)
+  (set-cdr! m m)
+  (test #t (equal? l m)))
+
+(let ((l '(1 . 2))
+      (m '(2 . 1)))
+  (set-cdr! l l)
+  (set-cdr! m m)
+  (test #f (equal? l m)))
+
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 1)))
+  (vector-set! v 1 v)
+  (vector-set! w 1 w)
+  (test #t (equal? v w)))
+
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 2)))
+  (vector-set! v 1 v)
+  (vector-set! w 1 w)
+  (test #f (equal? v w)))
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 1))
+      (l '(1 . 2))
+      (m '(1 . 2)))
+  (vector-set! v 1 l)
+  (vector-set! w 1 m)
+  (set-cdr! l v)
+  (set-cdr! m w)
+  (test #t  (equal? v w)))
+
+(let ((v (make-vector 2 2))
+      (w (make-vector 2 1))
+      (l '(1 . 2))
+      (m '(1 . 2)))
+  (vector-set! v 1 l)
+  (vector-set! w 1 m)
+  (set-cdr! l v)
+  (set-cdr! m w)
+  (test #f (equal? v w)))
+
 (test-end)
 
 (test-begin "6.2 Numbers")

From b50f5fc54fdd037859aa9eb5aa44128ec1b0dbf4 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 18 Jul 2014 11:50:08 +0900
Subject: [PATCH 161/216] remove sLETREC_SYNTAX

---
 include/picrin.h | 3 +--
 src/init.c       | 1 -
 src/macro.c      | 3 ---
 src/state.c      | 1 -
 4 files changed, 1 insertion(+), 7 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index 2406e48f..6756a648 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -80,8 +80,7 @@ typedef struct {
 
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
-  pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
-  pic_sym sLET_SYNTAX, sLETREC_SYNTAX;
+  pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO, sLET_SYNTAX;
   pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
   pic_sym sCONS, sCAR, sCDR, sNILP;
   pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
diff --git a/src/init.c b/src/init.c
index 4fdba1e0..c6667a3b 100644
--- a/src/init.c
+++ b/src/init.c
@@ -76,7 +76,6 @@ pic_init_core(pic_state *pic)
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX, pic->rLETREC_SYNTAX);
 
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
diff --git a/src/macro.c b/src/macro.c
index 636a968e..964a9589 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -481,9 +481,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
       else if (tag == pic->rLET_SYNTAX) {
         return macroexpand_let_syntax(pic, expr, senv);
       }
-      /* else if (tag == pic->sLETREC_SYNTAX) { */
-      /*   return macroexpand_letrec_syntax(pic, expr, senv); */
-      /* } */
       else if (tag == pic->rLAMBDA) {
         return macroexpand_lambda(pic, expr, senv);
       }
diff --git a/src/state.c b/src/state.c
index cb01c754..6be7da78 100644
--- a/src/state.c
+++ b/src/state.c
@@ -97,7 +97,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
   register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
   register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
-  register_core_symbol(pic, sLETREC_SYNTAX, "letrec-syntax");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
   register_core_symbol(pic, sEXPORT, "export");

From a867991b7e55beb1be6f5aeeacfad74bcc867e00 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 18 Jul 2014 11:51:13 +0900
Subject: [PATCH 162/216] remove rLETREC_SYNTAX

---
 include/picrin.h | 3 +--
 src/state.c      | 1 -
 2 files changed, 1 insertion(+), 3 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index 6756a648..2d14dc68 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -87,8 +87,7 @@ typedef struct {
   pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
 
   pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
-  pic_sym rDEFINE_SYNTAX, rDEFINE_MACRO;
-  pic_sym rLET_SYNTAX, rLETREC_SYNTAX;
+  pic_sym rDEFINE_SYNTAX, rDEFINE_MACRO, rLET_SYNTAX;
   pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
 
   xhash syms;                   /* name to symbol */
diff --git a/src/state.c b/src/state.c
index 6be7da78..9da1852c 100644
--- a/src/state.c
+++ b/src/state.c
@@ -131,7 +131,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
   register_renamed_symbol(pic, rDEFINE_MACRO, "define-macro");
   register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax");
-  register_renamed_symbol(pic, rLETREC_SYNTAX, "letrec-syntax");
   register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
   register_renamed_symbol(pic, rIMPORT, "import");
   register_renamed_symbol(pic, rEXPORT, "export");

From 10462f2b7f668502da950a2f5925d681d46bb48b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 18 Jul 2014 11:52:35 +0900
Subject: [PATCH 163/216] remove custom target `no-act'

---
 CMakeLists.txt | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

diff --git a/CMakeLists.txt b/CMakeLists.txt
index c9311e1b..b2929567 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -40,10 +40,7 @@ include(tools/CMakeLists.txt)
 add_custom_target(run bin/picrin DEPENDS repl)
 
 # $ make test
-add_custom_target(test DEPENDS no-act test-r7rs)
-
-# $ make no-act
-add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl)
+add_custom_target(test DEPENDS test-r7rs)
 
 # $ make test-r7rs
 add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl)

From 5c6e7f16c04b6b577d98ddfd52435ab5596fb9f6 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 18 Jul 2014 11:55:43 +0900
Subject: [PATCH 164/216] fix r7rs-tests. rational literal is not required to
 generate an exact value

---
 t/r7rs-tests.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index eeac935e..45db84d1 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -827,7 +827,7 @@
 (test 3.0 (truncate 3.5))
 (test 4.0 (round 3.5))
 
-(test 4 (round 7/2))
+(test 4 (exact (round 7/2)))
 (test 7 (round 7))
 
 ;; (test 1/3 (rationalize (exact .3) 1/10))

From 4fad8f6f3e147cbc4e93dbe6076da1a25a0a1a3d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 18 Jul 2014 11:56:22 +0900
Subject: [PATCH 165/216] all float numbers can be considered inexact rational
 numbers

---
 src/number.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/number.c b/src/number.c
index c0a1e7ec..be3eabce 100644
--- a/src/number.c
+++ b/src/number.c
@@ -744,7 +744,7 @@ pic_init_number(pic_state *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_integer_p);
+  pic_defun(pic, "rational?", pic_number_real_p);
   pic_defun(pic, "integer?", pic_number_integer_p);
   pic_gc_arena_restore(pic, ai);
 

From 56c8ebe6619107cd42addf49700e3df094ffe809 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 18 Jul 2014 15:07:41 +0900
Subject: [PATCH 166/216] update travis config

---
 .travis.yml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/.travis.yml b/.travis.yml
index 2d33fec2..61058537 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -7,4 +7,4 @@ before_script:
 script:
   - perl --version
   - cmake .. && make test
-  - cmake -DCMAKE_BUILD_TYPE=Debug .. && make no-act
+  - cmake -DCMAKE_BUILD_TYPE=Debug .. && make test > /dev/null

From 2c1209ba63b377c83c9478e41557a904c2d50b83 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Fri, 18 Jul 2014 15:44:29 +0900
Subject: [PATCH 167/216] remove redundant brace following review

---
 src/read.c | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

diff --git a/src/read.c b/src/read.c
index 7b059a30..142db83c 100644
--- a/src/read.c
+++ b/src/read.c
@@ -361,6 +361,8 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
   char *buf;
   size_t size, cnt;
   pic_sym sym;
+  /* Currently supports only ascii chars */
+  char HEX_BUF[3];
 
   size = 256;
   buf = pic_alloc(pic, size);
@@ -373,16 +375,11 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
       case 't': c = '\t'; break;
       case 'n': c = '\n'; break;
       case 'r': c = '\r'; break;
-      case 'x':{
-        /* Currently supports only ascii chars */
-        size_t s = 3;        /* 2 bytes of hex + 1 byte of terminator(';')*/
-        char hex[s];
-        size_t i = 0;
-        while((hex[i++] = (next(port))) != ';' && i < s);
-        c = (char)strtol(hex, NULL, 16);
+      case 'x':
+        for(size_t i = 0; (HEX_BUF[i++] = (next(port))) != ';' && i < sizeof HEX_BUF;);
+        c = (char)strtol(HEX_BUF, NULL, 16);
         break;
       }
-      }
     }
     buf[cnt++] = c;
     if (cnt >= size) {

From c440629dbf6fe3532f4b1d696f82e9d151a5aecf Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Fri, 18 Jul 2014 15:47:36 +0900
Subject: [PATCH 168/216] add error check

---
 src/read.c | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index 142db83c..239c20e9 100644
--- a/src/read.c
+++ b/src/read.c
@@ -376,7 +376,10 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
       case 'n': c = '\n'; break;
       case 'r': c = '\r'; break;
       case 'x':
-        for(size_t i = 0; (HEX_BUF[i++] = (next(port))) != ';' && i < sizeof HEX_BUF;);
+        for(size_t i = 0; (HEX_BUF[i] = next(port)) != ';'; i++) {
+          if (i >= sizeof HEX_BUF)
+            read_error(pic, "expected ';'");
+        }
         c = (char)strtol(HEX_BUF, NULL, 16);
         break;
       }

From bbeee8f10e8d93f97a9f4cf62e49356fe8a2814e Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Fri, 18 Jul 2014 16:00:08 +0900
Subject: [PATCH 169/216] change directive reader to ignore shebang

---
 src/read.c | 19 ++++++++-----------
 1 file changed, 8 insertions(+), 11 deletions(-)

diff --git a/src/read.c b/src/read.c
index 87ffe127..cd330165 100644
--- a/src/read.c
+++ b/src/read.c
@@ -117,6 +117,8 @@ read_datum_comment(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_directive(pic_state *pic, struct pic_port *port, char c)
 {
+  UNUSED(pic);
+
   c = next(port);
 
   if (c == 'n') {
@@ -124,7 +126,8 @@ read_directive(pic_state *pic, struct pic_port *port, char c)
       /* :FIXME: set no-fold-case flag */
     }
     else{
-      goto abort;
+      xfseek(port->file, -1, SEEK_CUR);
+      goto shebang;
     }
   }
   else if (c == 'f') {
@@ -132,12 +135,13 @@ read_directive(pic_state *pic, struct pic_port *port, char c)
       /* :FIXME: set fold-case flag */      
     }
     else{
-      goto abort;
+      xfseek(port->file, -1, SEEK_CUR);
+      goto shebang;
     }
   }
   else{
-  abort:
-    pic_error(pic, "unknown directive");
+  shebang:
+    while(xfgetc(port->file) != '\n');
   }
 
   return pic_undef_value();
@@ -704,13 +708,6 @@ pic_parse_file(pic_state *pic, FILE *file)
   port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
   port->status = PIC_PORT_OPEN;
 
-  if(xfgetc(port->file) == '#' && xfgetc(port->file) == '!'){
-    while(xfgetc(port->file) != '\n');
-  }
-  else{
-    xfseek(port->file, 0, SEEK_SET);
-  }
-
   return pic_parse(pic, port);
 }
 

From a50d3da569cae27bfe4671752ca0b150b47d0556 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Fri, 18 Jul 2014 16:02:09 +0900
Subject: [PATCH 170/216] follow completely @wasabiz's code

---
 src/read.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index 239c20e9..dfcc63d4 100644
--- a/src/read.c
+++ b/src/read.c
@@ -363,6 +363,7 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
   pic_sym sym;
   /* Currently supports only ascii chars */
   char HEX_BUF[3];
+  size_t i = 0;
 
   size = 256;
   buf = pic_alloc(pic, size);
@@ -376,7 +377,8 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
       case 'n': c = '\n'; break;
       case 'r': c = '\r'; break;
       case 'x':
-        for(size_t i = 0; (HEX_BUF[i] = next(port)) != ';'; i++) {
+        i = 0;
+        while ((HEX_BUF[i++] = next(port)) != ';') {
           if (i >= sizeof HEX_BUF)
             read_error(pic, "expected ';'");
         }

From baeb5f6174515c0e35bc9d9af9665a3dc9bf0536 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 01:37:57 +0900
Subject: [PATCH 171/216] s/senv->renames/senv->map/g

---
 include/picrin/macro.h |  2 +-
 src/gc.c               |  2 +-
 src/macro.c            | 10 +++++-----
 3 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/include/picrin/macro.h b/include/picrin/macro.h
index 023c2785..758c6298 100644
--- a/include/picrin/macro.h
+++ b/include/picrin/macro.h
@@ -11,7 +11,7 @@ extern "C" {
 
 struct pic_senv {
   PIC_OBJECT_HEADER
-  xhash renames;
+  xhash map;
   struct pic_senv *up;
 };
 
diff --git a/src/gc.c b/src/gc.c
index d77393c8..7d285b32 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -623,7 +623,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
   }
   case PIC_TT_SENV: {
     struct pic_senv *senv = (struct pic_senv *)obj;
-    xh_destroy(&senv->renames);
+    xh_destroy(&senv->map);
     break;
   }
   case PIC_TT_MACRO: {
diff --git a/src/macro.c b/src/macro.c
index 964a9589..91da8b00 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -26,7 +26,7 @@ pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym renam
 {
   UNUSED(pic);
 
-  xh_put_int(&senv->renames, sym, &rename);
+  xh_put_int(&senv->map, sym, &rename);
 }
 
 bool
@@ -41,7 +41,7 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren
     return true;
   }
 
-  if ((e = xh_get_int(&senv->renames, sym)) == NULL) {
+  if ((e = xh_get_int(&senv->map, sym)) == NULL) {
     return false;
   }
   if (rename != NULL) {
@@ -212,7 +212,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
 
   in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
   in->up = senv;
-  xh_init_int(&in->renames, sizeof(pic_sym));
+  xh_init_int(&in->map, sizeof(pic_sym));
 
   for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
     pic_value v = pic_car(pic, a);
@@ -374,7 +374,7 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
 
   in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
   in->up = senv;
-  xh_init_int(&in->renames, sizeof(pic_sym));
+  xh_init_int(&in->map, sizeof(pic_sym));
 
   if (pic_length(pic, expr) < 2) {
     pic_error(pic, "syntax error");
@@ -569,7 +569,7 @@ pic_null_syntactic_environment(pic_state *pic)
 
   senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
   senv->up = NULL;
-  xh_init_int(&senv->renames, sizeof(pic_sym));
+  xh_init_int(&senv->map, sizeof(pic_sym));
 
   pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY);
   pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT);

From d6b6376408a8fe0cb84723b5cc24fb42757c015d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 01:40:55 +0900
Subject: [PATCH 172/216] add pic_senv_new

---
 include/picrin/macro.h |  2 ++
 src/macro.c            | 22 ++++++++++++++--------
 2 files changed, 16 insertions(+), 8 deletions(-)

diff --git a/include/picrin/macro.h b/include/picrin/macro.h
index 758c6298..d655a735 100644
--- a/include/picrin/macro.h
+++ b/include/picrin/macro.h
@@ -32,6 +32,8 @@ struct pic_senv *pic_null_syntactic_environment(pic_state *);
 bool pic_identifier_p(pic_state *pic, pic_value obj);
 bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym);
 
+struct pic_senv *pic_senv_new(pic_state *, struct pic_senv *);
+
 pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym);
 bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */);
 void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym);
diff --git a/src/macro.c b/src/macro.c
index 91da8b00..f0b079b7 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -210,9 +210,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
     pic_error(pic, "syntax error");
   }
 
-  in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
-  in->up = senv;
-  xh_init_int(&in->map, sizeof(pic_sym));
+  in = pic_senv_new(pic, senv);
 
   for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
     pic_value v = pic_car(pic, a);
@@ -372,9 +370,7 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   pic_value formal, v, var, val;
   pic_sym sym, rename;
 
-  in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
-  in->up = senv;
-  xh_init_int(&in->map, sizeof(pic_sym));
+  in = pic_senv_new(pic, senv);
 
   if (pic_length(pic, expr) < 2) {
     pic_error(pic, "syntax error");
@@ -563,14 +559,24 @@ pic_macroexpand(pic_state *pic, pic_value expr)
 }
 
 struct pic_senv *
-pic_null_syntactic_environment(pic_state *pic)
+pic_senv_new(pic_state *pic, struct pic_senv *up)
 {
   struct pic_senv *senv;
 
   senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
-  senv->up = NULL;
+  senv->up = up;
   xh_init_int(&senv->map, sizeof(pic_sym));
 
+  return senv;
+}
+
+struct pic_senv *
+pic_null_syntactic_environment(pic_state *pic)
+{
+  struct pic_senv *senv;
+
+  senv = pic_senv_new(pic, NULL);
+
   pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY);
   pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT);
   pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT);

From 8a1d0685190a93fc182a4fcb21ad835faba7ea3c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 11:20:54 +0900
Subject: [PATCH 173/216] fix many bugs around sc

---
 piclib/prelude.scm | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 3b84c974..abc54dc2 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -77,7 +77,7 @@
                 (vector-map proc expr)
                 (proc expr)))))
 
-  (define (make-syntactic-closure form free env)
+  (define (make-syntactic-closure env free form)
     (define cache (make-dictionary))
     (walk
      (lambda (atom)
@@ -90,10 +90,11 @@
                    (begin
                      (define id (make-identifier atom env))
                      (dictionary-set! cache atom id)
-                     id)))))))
+                     id)))))
+     form))
 
   (define (close-syntax form env)
-    (make-syntactic-closure form '() env))
+    (make-syntactic-closure env '() form))
 
   (define (sc-macro-transformer f)
     (lambda (expr use-env mac-env)

From ccd457544d04d74bf7357e8a1042a37d25056593 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 11:21:13 +0900
Subject: [PATCH 174/216] detail error message on macroexpand error

---
 src/macro.c | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index f0b079b7..13eea311 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -304,7 +304,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   pic_try {
     val = pic_eval(pic, val);
   } pic_catch {
-    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
+    pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
   }
 
   if (! pic_proc_p(val)) {
@@ -351,7 +351,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
   pic_try {
     val = pic_eval(pic, val);
   } pic_catch {
-    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
+    pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
   }
 
   if (! pic_proc_p(val)) {
@@ -422,7 +422,7 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
   pic_try {
     v = pic_apply(pic, mac->proc, args);
   } pic_catch {
-    pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
+    pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
   }
 
 #if DEBUG

From e715ca10ea99b631c51733b81bc46bc2880e5fa1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 11:23:14 +0900
Subject: [PATCH 175/216] add capture-syntactic-environment. close #96

---
 piclib/prelude.scm | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index abc54dc2..6aede272 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -96,6 +96,10 @@
   (define (close-syntax form env)
     (make-syntactic-closure env '() form))
 
+  (define-syntax capture-syntactic-environment
+    (lambda (form use-env mac-env)
+      (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))
+
   (define (sc-macro-transformer f)
     (lambda (expr use-env mac-env)
       (make-syntactic-closure mac-env '() (f expr use-env))))
@@ -180,6 +184,7 @@
 
   (export make-syntactic-closure
           close-syntax
+          capture-syntactic-environment
           sc-macro-transformer
           rsc-macro-transformer
           er-macro-transformer

From b72487104ec8052830614bfc3d905c9103f63ee3 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 11:24:12 +0900
Subject: [PATCH 176/216] update docs

---
 docs/libs.rst | 1 +
 1 file changed, 1 insertion(+)

diff --git a/docs/libs.rst b/docs/libs.rst
index ced52fd2..91593c89 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -58,6 +58,7 @@ Old-fashioned macro.
 
 - make-syntactic-closure
 - close-syntax
+- capture-syntactic-environment
 
 - sc-macro-transformer
 - rsc-macro-transformer

From 8d623da1631da9f7dce598d24242e3135af61c6f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 11:34:37 +0900
Subject: [PATCH 177/216] refactor read_directive

---
 src/read.c | 34 +++++++++++-----------------------
 1 file changed, 11 insertions(+), 23 deletions(-)

diff --git a/src/read.c b/src/read.c
index d42b5d32..e9414819 100644
--- a/src/read.c
+++ b/src/read.c
@@ -118,34 +118,22 @@ read_datum_comment(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_directive(pic_state *pic, struct pic_port *port, char c)
 {
-  UNUSED(pic);
-
-  c = next(port);
-
-  if (c == 'n') {
-    if(expect(port, "o-fold-case")){
+  switch (peek(port)) {
+  case 'n':
+    if (expect(port, "no-fold-case")) {
       /* :FIXME: set no-fold-case flag */
+      return pic_undef_value();
     }
-    else{
-      xfseek(port->file, -1, SEEK_CUR);
-      goto shebang;
+    break;
+  case 'f':
+    if (expect(port, "fold-case")) {
+      /* :FIXME: set fold-case flag */
+      return pic_undef_value();
     }
-  }
-  else if (c == 'f') {
-    if(expect(port, "old-case")){
-      /* :FIXME: set fold-case flag */      
-    }
-    else{
-      xfseek(port->file, -1, SEEK_CUR);
-      goto shebang;
-    }
-  }
-  else{
-  shebang:
-    while(xfgetc(port->file) != '\n');
+    break;
   }
 
-  return pic_undef_value();
+  return read_comment(pic, port, c);
 }
 
 static pic_value

From 3f8592772f037cacf49f43b2d5ff0fe7c5d85064 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 11:50:28 +0900
Subject: [PATCH 178/216] error handling on error while reading char literal

---
 src/read.c | 29 +++++++++++++++++++++--------
 1 file changed, 21 insertions(+), 8 deletions(-)

diff --git a/src/read.c b/src/read.c
index e9414819..c71e0606 100644
--- a/src/read.c
+++ b/src/read.c
@@ -327,18 +327,31 @@ read_char(pic_state *pic, struct pic_port *port, char c)
   if (! isdelim(peek(port))) {
     switch (c) {
     default: read_error(pic, "unexpected character after char literal");
-    case 'a': c = '\a'; expect(port, "lerm"); break;
-    case 'b': c = '\b'; expect(port, "ackspace"); break;
-    case 'd': c = 0x7F; expect(port, "elete"); break;
-    case 'e': c = 0x1B; expect(port, "scape"); break;
-    case 'n': c = peek(port) == 'e' ? (expect(port, "ewline"), '\n') : (expect(port, "ull"), '\0'); break;
-    case 'r': c = '\r'; expect(port, "eturn"); break;
-    case 's': c = ' '; expect(port, "pace"); break;
-    case 't': c = '\t'; expect(port, "ab"); break;
+    case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break;
+    case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break;
+    case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break;
+    case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break;
+    case 'n':
+      if ((c = peek(port)) == 'e') {
+        c = '\n';
+        if (! expect(port, "ewline"))
+          goto fail;
+      } else {
+        c = '\0';
+        if (! expect(port, "ull"))
+          goto fail;
+      }
+      break;
+    case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break;
+    case 's': c = ' '; if (! expect(port, "pace")) goto fail; break;
+    case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break;
     }
   }
 
   return pic_char_value(c);
+
+ fail:
+  read_error(pic, "unexpected character while reading character literal");
 }
 
 static pic_value

From 9cefeeb423fdf300f9c95a067e866f1255628486 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 11:51:37 +0900
Subject: [PATCH 179/216] expect returns as early as possible. read_directive
 might have missed a newline in unmatched character that has consumed by
 expect

---
 src/read.c | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index c71e0606..2b5c53be 100644
--- a/src/read.c
+++ b/src/read.c
@@ -55,8 +55,9 @@ expect(struct pic_port *port, const char *str)
   char c;
 
   while ((c = *str++) != 0) {
-    if (c != next(port))
+    if (c != peek(port))
       return false;
+    next(port);
   }
 
   return true;

From a2f628d2405b04661dc12cd83a9bc445212ff1e2 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 12:02:00 +0900
Subject: [PATCH 180/216] style fixes

---
 src/bool.c | 84 ++++++++++++++++++++++++++++--------------------------
 1 file changed, 44 insertions(+), 40 deletions(-)

diff --git a/src/bool.c b/src/bool.c
index 319355dc..91fb0952 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -10,76 +10,80 @@
 #include "picrin/blob.h"
 #include "picrin/string.h"
 
-bool pic_string_equal_p(struct pic_string *str1, struct pic_string *str2)
+bool
+pic_string_equal_p(struct pic_string *str1, struct pic_string *str2)
 {
   return pic_strcmp(str1, str2) == 0;
 }
 
-bool pic_blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
+bool
+pic_blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
 {
-  if(blob1->len != blob2->len){
+  size_t i;
+
+  if (blob1->len != blob2->len) {
     return false;
   }
-  size_t i;
-  for(i = 0; i < blob1->len; ++i){
-    if(blob1->data[i] != blob2->data[i])
+  for (i = 0; i < blob1->len; ++i) {
+    if (blob1->data[i] != blob2->data[i])
       return false;
   }
-  return true;  
+  return true;
 }
 
-bool
+static bool
 pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
 {
-
-  if (depth > 10){
-    if(depth > 200){
-      pic_errorf(pic, "Stack overflow in equal\n");
-    }
-    if (NULL == ht){
-      xh_init_ptr(ht, sizeof(void *));
-    }
-    switch(pic_type(x)){
-    case PIC_TT_PAIR:
-    case PIC_TT_VECTOR:{
-      xh_entry *e = xh_get(ht, pic_obj_ptr(x));
-      if(e){
-        /* `x' was seen already.  */
-        return true;
-      }else{
-        xh_put(ht, pic_obj_ptr(x), NULL);
-      }
-    }
-    default:;
-    }
-  }
-
+  xh_entry *e;
   enum pic_tt type;
   pic_value local = pic_nil_value();
   size_t rapid_count = 0;
 
+  if (depth > 10) {
+    if (depth > 200) {
+      pic_errorf(pic, "Stack overflow in equal\n");
+    }
+    if (NULL == ht) {
+      xh_init_ptr(ht, sizeof(void *));
+    }
+    switch (pic_type(x)) {
+    case PIC_TT_PAIR:
+    case PIC_TT_VECTOR: {
+      e = xh_get(ht, pic_obj_ptr(x));
+      if (e) {
+        /* `x' was seen already.  */
+        return true;
+      } else {
+        xh_put(ht, pic_obj_ptr(x), NULL);
+      }
+    }
+    default:
+      break;
+    }
+  }
+
  LOOP:
 
   if (pic_eqv_p(x, y))
     return true;
-  
+
   type = pic_type(x);
-  
-  if (type != pic_type(y)){
-    return false;    
+
+  if (type != pic_type(y)) {
+    return false;
   }
-  
+
   switch (type) {
   case PIC_TT_PAIR:
-    if(pic_nil_p(local)){
+    if (pic_nil_p(local)) {
       local = x;
     }
-    if(pic_internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)){
+    if (pic_internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) {
       x = pic_cdr(pic, x);
       y = pic_cdr(pic, y);
       ++rapid_count;
-      
-      if(rapid_count == 2){
+
+      if (rapid_count == 2) {
         rapid_count = 0;
         local = pic_cdr(pic, local);
         if (pic_eq_p(local, x)) {

From d295653d2036e45e57cac0bb41936df4fc391bb6 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 12:11:49 +0900
Subject: [PATCH 181/216] more style fixes

---
 src/bool.c | 27 ++++++++++++---------------
 1 file changed, 12 insertions(+), 15 deletions(-)

diff --git a/src/bool.c b/src/bool.c
index 91fb0952..84e639c3 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -34,8 +34,6 @@ pic_blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
 static bool
 pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
 {
-  xh_entry *e;
-  enum pic_tt type;
   pic_value local = pic_nil_value();
   size_t rapid_count = 0;
 
@@ -48,15 +46,12 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
     }
     switch (pic_type(x)) {
     case PIC_TT_PAIR:
-    case PIC_TT_VECTOR: {
-      e = xh_get(ht, pic_obj_ptr(x));
-      if (e) {
-        /* `x' was seen already.  */
-        return true;
+    case PIC_TT_VECTOR:
+      if (xh_get(ht, pic_obj_ptr(x)) != NULL) {
+        return true;            /* `x' was seen already.  */
       } else {
         xh_put(ht, pic_obj_ptr(x), NULL);
       }
-    }
     default:
       break;
     }
@@ -67,13 +62,10 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
   if (pic_eqv_p(x, y))
     return true;
 
-  type = pic_type(x);
-
-  if (type != pic_type(y)) {
+  if (pic_type(x) != pic_type(y))
     return false;
-  }
 
-  switch (type) {
+  switch (pic_type(x)) {
   case PIC_TT_PAIR:
     if (pic_nil_p(local)) {
       local = x;
@@ -81,6 +73,7 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
     if (pic_internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) {
       x = pic_cdr(pic, x);
       y = pic_cdr(pic, y);
+
       ++rapid_count;
 
       if (rapid_count == 2) {
@@ -91,7 +84,7 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
         }
       }
       goto LOOP;
-    }else{
+    } else {
       return false;
     }
   case PIC_TT_BLOB: {
@@ -109,7 +102,10 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
   }
   case PIC_TT_VECTOR: {
     size_t i;
-    struct pic_vector *u = pic_vec_ptr(x), *v = pic_vec_ptr(y);
+    struct pic_vector *u, *v;
+
+    u = pic_vec_ptr(x);
+    v = pic_vec_ptr(y);
 
     if (u->len != v->len) {
       return false;
@@ -130,6 +126,7 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
 bool
 pic_equal_p(pic_state *pic, pic_value x, pic_value y){
   xhash ht;
+
   xh_init_ptr(&ht, 0);
   return pic_internal_equal_p(pic, x, y, 0, &ht);
 }

From 619fe8e15ee25dbbc1b8bca1819dd4798776848b Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 12:14:32 +0900
Subject: [PATCH 182/216] use str_equal_p and blob_equal_p

---
 src/bool.c | 38 +++++++++++++++-----------------------
 1 file changed, 15 insertions(+), 23 deletions(-)

diff --git a/src/bool.c b/src/bool.c
index 84e639c3..45e6cd15 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -10,14 +10,14 @@
 #include "picrin/blob.h"
 #include "picrin/string.h"
 
-bool
-pic_string_equal_p(struct pic_string *str1, struct pic_string *str2)
+static bool
+str_equal_p(struct pic_string *str1, struct pic_string *str2)
 {
   return pic_strcmp(str1, str2) == 0;
 }
 
-bool
-pic_blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
+static bool
+blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
 {
   size_t i;
 
@@ -32,7 +32,7 @@ pic_blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
 }
 
 static bool
-pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
+internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
 {
   pic_value local = pic_nil_value();
   size_t rapid_count = 0;
@@ -66,11 +66,17 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
     return false;
 
   switch (pic_type(x)) {
+  case PIC_TT_STRING:
+    return str_equal_p(pic_str_ptr(x), pic_str_ptr(y));
+
+  case PIC_TT_BLOB:
+    return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
+
   case PIC_TT_PAIR:
     if (pic_nil_p(local)) {
       local = x;
     }
-    if (pic_internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) {
+    if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) {
       x = pic_cdr(pic, x);
       y = pic_cdr(pic, y);
 
@@ -87,19 +93,6 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
     } else {
       return false;
     }
-  case PIC_TT_BLOB: {
-    size_t i;
-    struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y);
-
-    if (u->len != v->len) {
-      return false;
-    }
-    for (i = 0; i < u->len; ++i) {
-      if (u->data[i] != v->data[i])
-        return false;
-    }
-    return true;
-  }
   case PIC_TT_VECTOR: {
     size_t i;
     struct pic_vector *u, *v;
@@ -111,13 +104,11 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
       return false;
     }
     for (i = 0; i < u->len; ++i) {
-      if (! pic_internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht))
+      if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht))
         return false;
     }
     return true;
   }
-  case PIC_TT_STRING:
-    return pic_strcmp(pic_str_ptr(x), pic_str_ptr(y)) == 0;
   default:
     return false;
   }
@@ -128,7 +119,8 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y){
   xhash ht;
 
   xh_init_ptr(&ht, 0);
-  return pic_internal_equal_p(pic, x, y, 0, &ht);
+
+  return internal_equal_p(pic, x, y, 0, &ht);
 }
 
 static pic_value

From e41cbc6f331e35bcc9a4bee7b2e0c9e081e92776 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 12:18:23 +0900
Subject: [PATCH 183/216] remove unused guard clause

---
 src/bool.c | 12 +++---------
 1 file changed, 3 insertions(+), 9 deletions(-)

diff --git a/src/bool.c b/src/bool.c
index 45e6cd15..270bb019 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -41,19 +41,12 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
     if (depth > 200) {
       pic_errorf(pic, "Stack overflow in equal\n");
     }
-    if (NULL == ht) {
-      xh_init_ptr(ht, sizeof(void *));
-    }
-    switch (pic_type(x)) {
-    case PIC_TT_PAIR:
-    case PIC_TT_VECTOR:
+    if (pic_pair_p(x) || pic_vec_p(x)) {
       if (xh_get(ht, pic_obj_ptr(x)) != NULL) {
         return true;            /* `x' was seen already.  */
       } else {
         xh_put(ht, pic_obj_ptr(x), NULL);
       }
-    default:
-      break;
     }
   }
 
@@ -72,7 +65,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
   case PIC_TT_BLOB:
     return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
 
-  case PIC_TT_PAIR:
+  case PIC_TT_PAIR: {
     if (pic_nil_p(local)) {
       local = x;
     }
@@ -93,6 +86,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
     } else {
       return false;
     }
+  }
   case PIC_TT_VECTOR: {
     size_t i;
     struct pic_vector *u, *v;

From 9d05ab26298e98e7e95721a2b208402df02a0c98 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 12:24:38 +0900
Subject: [PATCH 184/216] s/rapid_count/c/g

---
 src/bool.c | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

diff --git a/src/bool.c b/src/bool.c
index 270bb019..a985c625 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -35,7 +35,7 @@ static bool
 internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
 {
   pic_value local = pic_nil_value();
-  size_t rapid_count = 0;
+  size_t c;
 
   if (depth > 10) {
     if (depth > 200) {
@@ -50,6 +50,8 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
     }
   }
 
+  c = 0;
+
  LOOP:
 
   if (pic_eqv_p(x, y))
@@ -73,10 +75,10 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
       x = pic_cdr(pic, x);
       y = pic_cdr(pic, y);
 
-      ++rapid_count;
+      c++;
 
-      if (rapid_count == 2) {
-        rapid_count = 0;
+      if (c == 2) {
+        c = 0;
         local = pic_cdr(pic, local);
         if (pic_eq_p(local, x)) {
           return true;

From fb31793808e71a3c8bd10df60b6351af32906808 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 12:27:31 +0900
Subject: [PATCH 185/216] update docs

---
 docs/lang.rst | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/docs/lang.rst b/docs/lang.rst
index 9c4152ff..3c3f463b 100644
--- a/docs/lang.rst
+++ b/docs/lang.rst
@@ -63,7 +63,7 @@ section                                          status     comments
 5.6.1 Library Syntax                             incomplete In picrin, libraries can be reopend and can be nested.
 5.6.2 Library example                            N/A
 5.7 The REPL                                     yes
-6.1 Equivalence predicates                       yes        TODO: equal? must terminate if circular structure is given
+6.1 Equivalence predicates                       yes
 6.2.1 Numerical types                            yes        picrin has only two types of internal representation of numbers: fixnum and double float. It still comforms the R7RS spec.
 6.2.2 Exactness                                  yes
 6.2.3 Implementation restrictions                yes

From a2c00017ea339c7846c131e6bfb65101af584ba9 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 12:48:27 +0900
Subject: [PATCH 186/216] implement memq and assq with c

---
 include/picrin/pair.h |  2 ++
 piclib/prelude.scm    | 25 ++-----------------------
 src/pair.c            | 37 +++++++++++++++++++++++++++++++++++++
 3 files changed, 41 insertions(+), 23 deletions(-)

diff --git a/include/picrin/pair.h b/include/picrin/pair.h
index 1f7fccfa..f8c921e7 100644
--- a/include/picrin/pair.h
+++ b/include/picrin/pair.h
@@ -49,6 +49,8 @@ int pic_length(pic_state *, pic_value);
 pic_value pic_reverse(pic_state *, pic_value);
 pic_value pic_append(pic_state *, pic_value, pic_value);
 
+pic_value pic_memq(pic_state *, pic_value key, pic_value list);
+
 pic_value pic_assq(pic_state *, pic_value key, pic_value assoc);
 pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc);
 pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc);
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 3b84c974..482818af 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -39,13 +39,6 @@
   (import (scheme base)
           (picrin dictionary))
 
-  (define (memq obj list)
-    (if (null? list)
-        #f
-        (if (eq? obj (car list))
-            list
-            (memq obj (cdr list)))))
-
   (define (list->vector list)
     (define vector (make-vector (length list)))
     (define (go list i)
@@ -830,13 +823,6 @@
 
 ;;; 6.4 Pairs and lists
 
-(define (memq obj list)
-  (if (null? list)
-      #f
-      (if (eq? obj (car list))
-	  list
-	  (memq obj (cdr list)))))
-
 (define (memv obj list)
   (if (null? list)
       #f
@@ -844,13 +830,6 @@
 	  list
 	  (memq obj (cdr list)))))
 
-(define (assq obj list)
-  (if (null? list)
-      #f
-      (if (eq? obj (caar list))
-	  (car list)
-	  (assq obj (cdr list)))))
-
 (define (assv obj list)
   (if (null? list)
       #f
@@ -874,8 +853,8 @@
 	    (car list)
 	    (assoc obj (cdr list) compare)))))
 
-(export memq memv member
-        assq assv assoc)
+(export memv member
+        assv assoc)
 
 ;;; 6.5. Symbols
 
diff --git a/src/pair.c b/src/pair.c
index 499b7bb5..068fab47 100644
--- a/src/pair.c
+++ b/src/pair.c
@@ -261,6 +261,21 @@ pic_append(pic_state *pic, pic_value xs, pic_value ys)
   return ys;
 }
 
+pic_value
+pic_memq(pic_state *pic, pic_value key, pic_value list)
+{
+ enter:
+
+  if (pic_nil_p(list))
+    return pic_false_value();
+
+  if (pic_eq_p(key, pic_car(pic, list)))
+    return list;
+
+  list = pic_cdr(pic, list);
+  goto enter;
+}
+
 pic_value
 pic_assq(pic_state *pic, pic_value key, pic_value assoc)
 {
@@ -594,6 +609,26 @@ pic_pair_list_copy(pic_state *pic)
   return pic_list_copy(pic, obj);
 }
 
+static pic_value
+pic_pair_memq(pic_state *pic)
+{
+  pic_value key, list;
+
+  pic_get_args(pic, "oo", &key, &list);
+
+  return pic_memq(pic, key, list);
+}
+
+static pic_value
+pic_pair_assq(pic_state *pic)
+{
+  pic_value key, list;
+
+  pic_get_args(pic, "oo", &key, &list);
+
+  return pic_assq(pic, key, list);
+}
+
 void
 pic_init_pair(pic_state *pic)
 {
@@ -618,4 +653,6 @@ pic_init_pair(pic_state *pic)
   pic_defun(pic, "list-ref", pic_pair_list_ref);
   pic_defun(pic, "list-set!", pic_pair_list_set);
   pic_defun(pic, "list-copy", pic_pair_list_copy);
+  pic_defun(pic, "memq", pic_pair_memq);
+  pic_defun(pic, "assq", pic_pair_assq);
 }

From ad2434cde7cf501a9a1d785188a801e91a34a0ea Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 12:51:19 +0900
Subject: [PATCH 187/216] implement memv and assv with C

---
 include/picrin/pair.h |  3 +++
 piclib/prelude.scm    | 17 +------------
 src/pair.c            | 55 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 59 insertions(+), 16 deletions(-)

diff --git a/include/picrin/pair.h b/include/picrin/pair.h
index f8c921e7..c7319e25 100644
--- a/include/picrin/pair.h
+++ b/include/picrin/pair.h
@@ -50,9 +50,12 @@ pic_value pic_reverse(pic_state *, pic_value);
 pic_value pic_append(pic_state *, pic_value, pic_value);
 
 pic_value pic_memq(pic_state *, pic_value key, pic_value list);
+pic_value pic_memv(pic_state *, pic_value key, pic_value list);
 
 pic_value pic_assq(pic_state *, pic_value key, pic_value assoc);
+pic_value pic_assv(pic_state *, pic_value key, pic_value assoc);
 pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc);
+
 pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc);
 
 pic_value pic_caar(pic_state *, pic_value);
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 482818af..2db0ed58 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -823,20 +823,6 @@
 
 ;;; 6.4 Pairs and lists
 
-(define (memv obj list)
-  (if (null? list)
-      #f
-      (if (eqv? obj (car list))
-	  list
-	  (memq obj (cdr list)))))
-
-(define (assv obj list)
-  (if (null? list)
-      #f
-      (if (eqv? obj (caar list))
-	  (car list)
-	  (assq obj (cdr list)))))
-
 (define (member obj list . opts)
   (let ((compare (if (null? opts) equal? (car opts))))
     (if (null? list)
@@ -853,8 +839,7 @@
 	    (car list)
 	    (assoc obj (cdr list) compare)))))
 
-(export memv member
-        assv assoc)
+(export member assoc)
 
 ;;; 6.5. Symbols
 
diff --git a/src/pair.c b/src/pair.c
index 068fab47..2c80f363 100644
--- a/src/pair.c
+++ b/src/pair.c
@@ -276,6 +276,21 @@ pic_memq(pic_state *pic, pic_value key, pic_value list)
   goto enter;
 }
 
+pic_value
+pic_memv(pic_state *pic, pic_value key, pic_value list)
+{
+ enter:
+
+  if (pic_nil_p(list))
+    return pic_false_value();
+
+  if (pic_eqv_p(key, pic_car(pic, list)))
+    return list;
+
+  list = pic_cdr(pic, list);
+  goto enter;
+}
+
 pic_value
 pic_assq(pic_state *pic, pic_value key, pic_value assoc)
 {
@@ -294,6 +309,24 @@ pic_assq(pic_state *pic, pic_value key, pic_value assoc)
   goto enter;
 }
 
+pic_value
+pic_assv(pic_state *pic, pic_value key, pic_value assoc)
+{
+  pic_value cell;
+
+ enter:
+
+  if (pic_nil_p(assoc))
+    return pic_false_value();
+
+  cell = pic_car(pic, assoc);
+  if (pic_eqv_p(key, pic_car(pic, cell)))
+    return cell;
+
+  assoc = pic_cdr(pic, assoc);
+  goto enter;
+}
+
 pic_value
 pic_assoc(pic_state *pic, pic_value key, pic_value assoc)
 {
@@ -619,6 +652,16 @@ pic_pair_memq(pic_state *pic)
   return pic_memq(pic, key, list);
 }
 
+static pic_value
+pic_pair_memv(pic_state *pic)
+{
+  pic_value key, list;
+
+  pic_get_args(pic, "oo", &key, &list);
+
+  return pic_memv(pic, key, list);
+}
+
 static pic_value
 pic_pair_assq(pic_state *pic)
 {
@@ -629,6 +672,16 @@ pic_pair_assq(pic_state *pic)
   return pic_assq(pic, key, list);
 }
 
+static pic_value
+pic_pair_assv(pic_state *pic)
+{
+  pic_value key, list;
+
+  pic_get_args(pic, "oo", &key, &list);
+
+  return pic_assv(pic, key, list);
+}
+
 void
 pic_init_pair(pic_state *pic)
 {
@@ -654,5 +707,7 @@ pic_init_pair(pic_state *pic)
   pic_defun(pic, "list-set!", pic_pair_list_set);
   pic_defun(pic, "list-copy", pic_pair_list_copy);
   pic_defun(pic, "memq", pic_pair_memq);
+  pic_defun(pic, "memv", pic_pair_memv);
   pic_defun(pic, "assq", pic_pair_assq);
+  pic_defun(pic, "assv", pic_pair_assv);
 }

From 02ebced87b191eb183221b7c8a9304871ebf184c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 13:22:24 +0900
Subject: [PATCH 188/216] prelude cosmetic changes

---
 piclib/prelude.scm | 47 ++++++++++++++++++++++------------------------
 1 file changed, 22 insertions(+), 25 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 6aede272..9207735b 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -196,6 +196,11 @@
           (scheme cxr)
           (picrin macro))
 
+  (define-syntax syntax-error
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (apply error (cdr expr)))))
+
   (define-syntax define-auxiliary-syntax
     (er-macro-transformer
      (lambda (expr r c)
@@ -247,11 +252,6 @@
                            (cons (r 'begin) (cdar clauses))
                            (cons (r 'cond) (cdr clauses))))))))))
 
-  (define (single? list)
-    (if (pair? list)
-        (null? (cdr list))
-        #f))
-
   (define-syntax and
     (er-macro-transformer
      (lambda (expr r compare)
@@ -259,7 +259,7 @@
          (cond
           ((null? exprs)
            #t)
-          ((single? exprs)
+          ((= (length exprs) 1)
            (car exprs))
           (else
            (list (r 'let) (list (list (r 'it) (car exprs)))
@@ -274,7 +274,7 @@
          (cond
           ((null? exprs)
            #t)
-          ((single? exprs)
+          ((= (length exprs) 1)
            (car exprs))
           (else
            (list (r 'let) (list (list (r 'it) (car exprs)))
@@ -282,15 +282,6 @@
                        (r 'it)
                        (cons (r 'or) (cdr exprs))))))))))
 
-  (define (quasiquote? form compare?)
-    (and (pair? form) (compare? (car form) 'quasiquote)))
-
-  (define (unquote? form compare?)
-    (and (pair? form) (compare? (car form) 'unquote)))
-
-  (define (unquote-splicing? form compare?)
-    (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing)))
-
   (define (list->vector list)
     (let ((vector (make-vector (length list))))
       (let loop ((list list) (i 0))
@@ -311,17 +302,27 @@
     (ir-macro-transformer
      (lambda (form inject compare)
 
+       (define (quasiquote? form)
+         (and (pair? form) (compare (car form) 'quasiquote)))
+
+       (define (unquote? form)
+         (and (pair? form) (compare (car form) 'unquote)))
+
+       (define (unquote-splicing? form)
+         (and (pair? form) (pair? (car form))
+              (compare (car (car form)) 'unquote-splicing)))
+
        (define (qq depth expr)
          (cond
           ;; unquote
-          ((unquote? expr compare)
+          ((unquote? expr)
            (if (= depth 1)
                (car (cdr expr))
                (list 'list
                      (list 'quote (inject 'unquote))
                      (qq (- depth 1) (car (cdr expr))))))
           ;; unquote-splicing
-          ((unquote-splicing? expr compare)
+          ((unquote-splicing? expr)
            (if (= depth 1)
                (list 'append
                      (car (cdr (car expr)))
@@ -332,7 +333,7 @@
                            (qq (- depth 1) (car (cdr (car expr)))))
                      (qq depth (cdr expr)))))
           ;; quasiquote
-          ((quasiquote? expr compare)
+          ((quasiquote? expr)
            (list 'list
                  (list 'quote (inject 'quasiquote))
                  (qq (+ depth 1) (car (cdr expr)))))
@@ -440,7 +441,8 @@
                    `(,(r 'if) ,(if (compare (r 'else) (caar clauses))
                                    '#t
                                    `(,(r 'or)
-                                     ,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
+                                     ,@(map (lambda (x)
+                                              `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
                                             (caar clauses))))
                      ,(if (compare (r '=>) (cadar clauses))
                           `(,(caddar clauses) ,(r 'key))
@@ -458,11 +460,6 @@
                    formal)
             ,@body)))))
 
-  (define-syntax syntax-error
-    (er-macro-transformer
-     (lambda (expr rename compare)
-       (apply error (cdr expr)))))
-
   (export let let* letrec letrec*
           quasiquote unquote unquote-splicing
           and or

From 301c97245c72bd0a30aef93a01e73c41820946fc Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 14:15:53 +0900
Subject: [PATCH 189/216] split prelude into files

---
 piclib/CMakeLists.txt         |   5 +
 piclib/prelude.scm            | 278 +---------------------------------
 piclib/scheme/case-lambda.scm |  29 ++++
 piclib/scheme/cxr.scm         |  36 +++++
 piclib/scheme/file.scm        |  11 ++
 piclib/scheme/lazy.scm        |  42 +++++
 6 files changed, 124 insertions(+), 277 deletions(-)
 create mode 100644 piclib/scheme/case-lambda.scm
 create mode 100644 piclib/scheme/cxr.scm
 create mode 100644 piclib/scheme/file.scm
 create mode 100644 piclib/scheme/lazy.scm

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 6898de1b..6d7a37ac 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,7 +1,12 @@
 list(APPEND PICLIB_SCHEME_LIBS
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
   ${PROJECT_SOURCE_DIR}/piclib/prelude.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 9207735b..9889c107 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -1,199 +1,6 @@
-;;; Appendix A. Standard Libraries CxR
-(define-library (scheme cxr)
-  (import (scheme base))
-
-  (define (caaar p) (car (caar p)))
-  (define (caadr p) (car (cadr p)))
-  (define (cadar p) (car (cdar p)))
-  (define (caddr p) (car (cddr p)))
-  (define (cdaar p) (cdr (caar p)))
-  (define (cdadr p) (cdr (cadr p)))
-  (define (cddar p) (cdr (cdar p)))
-  (define (cdddr p) (cdr (cddr p)))
-  (define (caaaar p) (caar (caar p)))
-  (define (caaadr p) (caar (cadr p)))
-  (define (caadar p) (caar (cdar p)))
-  (define (caaddr p) (caar (cddr p)))
-  (define (cadaar p) (cadr (caar p)))
-  (define (cadadr p) (cadr (cadr p)))
-  (define (caddar p) (cadr (cdar p)))
-  (define (cadddr p) (cadr (cddr p)))
-  (define (cdaaar p) (cdar (caar p)))
-  (define (cdaadr p) (cdar (cadr p)))
-  (define (cdadar p) (cdar (cdar p)))
-  (define (cdaddr p) (cdar (cddr p)))
-  (define (cddaar p) (cddr (caar p)))
-  (define (cddadr p) (cddr (cadr p)))
-  (define (cdddar p) (cddr (cdar p)))
-  (define (cddddr p) (cddr (cddr p)))
-
-  (export caaar caadr cadar caddr
-          cdaar cdadr cddar cdddr
-          caaaar caaadr caadar caaddr
-          cadaar cadadr caddar cadddr
-          cdaaar cdaadr cdadar cdaddr
-          cddaar cddadr cdddar cddddr))
-
-;;; hygienic macros
-(define-library (picrin macro)
-  (import (scheme base)
-          (picrin dictionary))
-
-  (define (memq obj list)
-    (if (null? list)
-        #f
-        (if (eq? obj (car list))
-            list
-            (memq obj (cdr list)))))
-
-  (define (list->vector list)
-    (define vector (make-vector (length list)))
-    (define (go list i)
-      (if (null? list)
-          vector
-          (begin
-            (vector-set! vector i (car list))
-            (go (cdr list) (+ i 1)))))
-    (go list 0))
-
-  (define (vector->list vector)
-    (define (go i)
-      (if (= i (vector-length vector))
-          '()
-          (cons (vector-ref vector i)
-                (go (+ i 1)))))
-    (go 0))
-
-  (define (vector-map proc expr)
-    (list->vector (map proc (vector->list expr))))
-
-  (define (walk proc expr)
-    (if (null? expr)
-        '()
-        (if (pair? expr)
-            (cons (walk proc (car expr))
-                  (walk proc (cdr expr)))
-            (if (vector? expr)
-                (vector-map proc expr)
-                (proc expr)))))
-
-  (define (make-syntactic-closure env free form)
-    (define cache (make-dictionary))
-    (walk
-     (lambda (atom)
-       (if (not (symbol? atom))
-           atom
-           (if (memq atom free)
-               atom
-               (if (dictionary-has? cache atom)
-                   (dictionary-ref cache atom)
-                   (begin
-                     (define id (make-identifier atom env))
-                     (dictionary-set! cache atom id)
-                     id)))))
-     form))
-
-  (define (close-syntax form env)
-    (make-syntactic-closure env '() form))
-
-  (define-syntax capture-syntactic-environment
-    (lambda (form use-env mac-env)
-      (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))
-
-  (define (sc-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure mac-env '() (f expr use-env))))
-
-  (define (rsc-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure use-env '() (f expr mac-env))))
-
-  (define (er-macro-transformer f)
-    (lambda (expr use-env mac-env)
-
-      (define cache (make-dictionary))
-
-      (define (rename sym)
-        (if (dictionary-has? cache sym)
-            (dictionary-ref cache sym)
-            (begin
-              (define id (make-identifier sym mac-env))
-              (dictionary-set! cache sym id)
-              id)))
-
-      (define (compare x y)
-        (if (not (symbol? x))
-            #f
-            (if (not (symbol? y))
-                #f
-                (identifier=? use-env x use-env y))))
-
-      (f expr rename compare)))
-
-  (define (ir-macro-transformer f)
-    (lambda (expr use-env mac-env)
-
-      (define protects (make-dictionary))
-
-      (define (wrap expr)
-        (walk
-         (lambda (atom)
-           (if (not (symbol? atom))
-               atom
-               (begin
-                 (define id (make-identifier atom use-env))
-                 (dictionary-set! protects id atom) ; lookup *atom* from id
-                 id)))
-         expr))
-
-      (define (unwrap expr)
-        (define cache (make-dictionary))
-        (walk
-         (lambda (atom)
-           (if (not (symbol? atom))
-               atom
-               (if (dictionary-has? protects atom)
-                   (dictionary-ref protects atom)
-                   (if (dictionary-has? cache atom)
-                       (dictionary-ref cache atom)
-                       (begin
-                         ;; implicit renaming
-                         (define id (make-identifier atom mac-env))
-                         (dictionary-set! cache atom id)
-                         id)))))
-         expr))
-
-      (define cache (make-dictionary))
-
-      (define (inject sym)
-        (if (dictionary-has? cache sym)
-            (dictionary-ref cache sym)
-            (begin
-              (define id (make-identifier sym use-env))
-              (dictionary-set! cache sym id)
-              id)))
-
-      (define (compare x y)
-        (if (not (symbol? x))
-            #f
-            (if (not (symbol? y))
-                #f
-                (identifier=? mac-env x mac-env y))))
-
-      (unwrap (f (wrap expr) inject compare))))
-
-  (export make-syntactic-closure
-          close-syntax
-          capture-syntactic-environment
-          sc-macro-transformer
-          rsc-macro-transformer
-          er-macro-transformer
-          ir-macro-transformer))
-
 ;;; core syntaces
 (define-library (picrin core-syntax)
   (import (scheme base)
-          (scheme cxr)
           (picrin macro))
 
   (define-syntax syntax-error
@@ -1155,25 +962,13 @@
 
 (export call-with-port)
 
-(define-library (scheme file)
-  (import (scheme base))
-
-  (define (call-with-input-file filename callback)
-    (call-with-port (open-input-file filename) callback))
-
-  (define (call-with-output-file filename callback)
-    (call-with-port (open-output-file filename) callback))
-
-  (export call-with-input-file
-          call-with-output-file))
-
 ;;; include syntax
 
 (import (scheme read)
         (scheme file))
 
 (define (read-many filename)
-  (call-with-input-file filename
+  (call-with-port (open-input-file filename)
     (lambda (port)
       (let loop ((expr (read port)) (exprs '()))
         (if (eof-object? expr)
@@ -1189,48 +984,6 @@
 
 (export include)
 
-;;; Appendix A. Standard Libraries Lazy
-(define-library (scheme lazy)
-  (import (scheme base)
-	  (picrin macro))
-
-  (define-record-type promise
-    (make-promise% done obj)
-    promise?
-    (done promise-done? promise-done!)
-    (obj promise-value promise-value!))
-
-  (define-syntax delay-force
-    (ir-macro-transformer
-     (lambda (form rename compare?)
-       (let ((expr (cadr form)))
-	 `(make-promise% #f (lambda () ,expr))))))
-
-  (define-syntax delay
-    (ir-macro-transformer
-     (lambda (form rename compare?)
-       (let ((expr (cadr form)))
-	 `(delay-force (make-promise% #t ,expr))))))
-
-  (define (promise-update! new old)
-    (promise-done! old (promise-done? new))
-    (promise-value! old (promise-value new)))
-
-  (define (force promise)
-    (if (promise-done? promise)
-	(promise-value promise)
-	(let ((promise* ((promise-value promise))))
-	  (unless (promise-done? promise)
-		  (promise-update! promise* promise))
-	  (force promise))))
-
-  (define (make-promise obj)
-    (if (promise? obj)
-	obj
-	(make-promise% #t obj)))
-
-  (export delay-force delay force make-promise promise?))
-
 ;;; syntax-rules
 (define-library (picrin syntax-rules)
   (import (scheme base)
@@ -1557,32 +1310,3 @@
 (import (picrin syntax-rules))
 (export syntax-rules)
 
-(define-library (scheme case-lambda)
-  (import (scheme base))
-
-  (define-syntax case-lambda
-    (syntax-rules ()
-      ((case-lambda (params body0 ...) ...)
-       (lambda args
-         (let ((len (length args)))
-           (letrec-syntax
-               ((cl (syntax-rules ::: ()
-                      ((cl)
-                       (error "no matching clause"))
-                      ((cl ((p :::) . body) . rest)
-                       (if (= len (length '(p :::)))
-                           (apply (lambda (p :::)
-                                    . body)
-                                  args)
-                           (cl . rest)))
-                      ((cl ((p ::: . tail) . body)
-                           . rest)
-                       (if (>= len (length '(p :::)))
-                           (apply
-                            (lambda (p ::: . tail)
-                              . body)
-                            args)
-                           (cl . rest))))))
-             (cl (params body0 ...) ...)))))))
-
-  (export case-lambda))
diff --git a/piclib/scheme/case-lambda.scm b/piclib/scheme/case-lambda.scm
new file mode 100644
index 00000000..fff2b26c
--- /dev/null
+++ b/piclib/scheme/case-lambda.scm
@@ -0,0 +1,29 @@
+(define-library (scheme case-lambda)
+  (import (scheme base))
+
+  (define-syntax case-lambda
+    (syntax-rules ()
+      ((case-lambda (params body0 ...) ...)
+       (lambda args
+         (let ((len (length args)))
+           (letrec-syntax
+               ((cl (syntax-rules ::: ()
+                      ((cl)
+                       (error "no matching clause"))
+                      ((cl ((p :::) . body) . rest)
+                       (if (= len (length '(p :::)))
+                           (apply (lambda (p :::)
+                                    . body)
+                                  args)
+                           (cl . rest)))
+                      ((cl ((p ::: . tail) . body)
+                           . rest)
+                       (if (>= len (length '(p :::)))
+                           (apply
+                            (lambda (p ::: . tail)
+                              . body)
+                            args)
+                           (cl . rest))))))
+             (cl (params body0 ...) ...)))))))
+
+  (export case-lambda))
diff --git a/piclib/scheme/cxr.scm b/piclib/scheme/cxr.scm
new file mode 100644
index 00000000..e92c536f
--- /dev/null
+++ b/piclib/scheme/cxr.scm
@@ -0,0 +1,36 @@
+;;; Appendix A. Standard Libraries CxR
+
+(define-library (scheme cxr)
+  (import (scheme base))
+
+  (define (caaar p) (car (caar p)))
+  (define (caadr p) (car (cadr p)))
+  (define (cadar p) (car (cdar p)))
+  (define (caddr p) (car (cddr p)))
+  (define (cdaar p) (cdr (caar p)))
+  (define (cdadr p) (cdr (cadr p)))
+  (define (cddar p) (cdr (cdar p)))
+  (define (cdddr p) (cdr (cddr p)))
+  (define (caaaar p) (caar (caar p)))
+  (define (caaadr p) (caar (cadr p)))
+  (define (caadar p) (caar (cdar p)))
+  (define (caaddr p) (caar (cddr p)))
+  (define (cadaar p) (cadr (caar p)))
+  (define (cadadr p) (cadr (cadr p)))
+  (define (caddar p) (cadr (cdar p)))
+  (define (cadddr p) (cadr (cddr p)))
+  (define (cdaaar p) (cdar (caar p)))
+  (define (cdaadr p) (cdar (cadr p)))
+  (define (cdadar p) (cdar (cdar p)))
+  (define (cdaddr p) (cdar (cddr p)))
+  (define (cddaar p) (cddr (caar p)))
+  (define (cddadr p) (cddr (cadr p)))
+  (define (cdddar p) (cddr (cdar p)))
+  (define (cddddr p) (cddr (cddr p)))
+
+  (export caaar caadr cadar caddr
+          cdaar cdadr cddar cdddr
+          caaaar caaadr caadar caaddr
+          cadaar cadadr caddar cadddr
+          cdaaar cdaadr cdadar cdaddr
+          cddaar cddadr cdddar cddddr))
diff --git a/piclib/scheme/file.scm b/piclib/scheme/file.scm
new file mode 100644
index 00000000..75c8bdd9
--- /dev/null
+++ b/piclib/scheme/file.scm
@@ -0,0 +1,11 @@
+(define-library (scheme file)
+  (import (scheme base))
+
+  (define (call-with-input-file filename callback)
+    (call-with-port (open-input-file filename) callback))
+
+  (define (call-with-output-file filename callback)
+    (call-with-port (open-output-file filename) callback))
+
+  (export call-with-input-file
+          call-with-output-file))
diff --git a/piclib/scheme/lazy.scm b/piclib/scheme/lazy.scm
new file mode 100644
index 00000000..444dda40
--- /dev/null
+++ b/piclib/scheme/lazy.scm
@@ -0,0 +1,42 @@
+;;; Appendix A. Standard Libraries Lazy
+
+(define-library (scheme lazy)
+  (import (scheme base)
+	  (picrin macro))
+
+  (define-record-type promise
+    (make-promise% done obj)
+    promise?
+    (done promise-done? promise-done!)
+    (obj promise-value promise-value!))
+
+  (define-syntax delay-force
+    (ir-macro-transformer
+     (lambda (form rename compare?)
+       (let ((expr (cadr form)))
+	 `(make-promise% #f (lambda () ,expr))))))
+
+  (define-syntax delay
+    (ir-macro-transformer
+     (lambda (form rename compare?)
+       (let ((expr (cadr form)))
+	 `(delay-force (make-promise% #t ,expr))))))
+
+  (define (promise-update! new old)
+    (promise-done! old (promise-done? new))
+    (promise-value! old (promise-value new)))
+
+  (define (force promise)
+    (if (promise-done? promise)
+	(promise-value promise)
+	(let ((promise* ((promise-value promise))))
+	  (unless (promise-done? promise)
+		  (promise-update! promise* promise))
+	  (force promise))))
+
+  (define (make-promise obj)
+    (if (promise? obj)
+	obj
+	(make-promise% #t obj)))
+
+  (export delay-force delay force make-promise promise?))

From 6a203d236aab9d88e0fd483bdf15fdef06358eaf Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 14:25:22 +0900
Subject: [PATCH 190/216] eliminate (scheme cxr) dependency

---
 piclib/CMakeLists.txt |  2 +-
 piclib/prelude.scm    | 92 +++++++++++++++++++++----------------------
 2 files changed, 47 insertions(+), 47 deletions(-)

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 6d7a37ac..ce373fb2 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,9 +1,9 @@
 list(APPEND PICLIB_SCHEME_LIBS
-  ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
   ${PROJECT_SOURCE_DIR}/piclib/prelude.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 9889c107..6d8d6be9 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -27,9 +27,9 @@
      (lambda (expr r compare)
        (if (symbol? (cadr expr))
            (begin
-             (define name (cadr expr))
-             (define bindings (caddr expr))
-             (define body (cdddr expr))
+             (define name     (car (cdr expr)))
+             (define bindings (car (cdr (cdr expr))))
+             (define body     (cdr (cdr (cdr expr))))
              (list (r 'let) '()
                    (list (r 'define) name
                          (cons (r 'lambda) (cons (map car bindings) body)))
@@ -46,18 +46,20 @@
        (let ((clauses (cdr expr)))
          (if (null? clauses)
              #f
-             (if (compare (r 'else) (caar clauses))
-                 (cons (r 'begin) (cdar clauses))
-                 (if (if (>= (length (car clauses)) 2)
-                         (compare (r '=>) (cadar clauses))
-                         #f)
-                     (list (r 'let) (list (list (r 'x) (caar clauses)))
-                           (list (r 'if) (r 'x)
-                                 (list (caddar clauses) (r 'x))
-                                 (cons (r 'cond) (cdr clauses))))
-                     (list (r 'if) (caar clauses)
-                           (cons (r 'begin) (cdar clauses))
-                           (cons (r 'cond) (cdr clauses))))))))))
+             (begin
+               (define clause (car clauses))
+               (if (compare (r 'else) (car clause))
+                   (cons (r 'begin) (cdr clause))
+                   (if (if (>= (length clause) 2)
+                           (compare (r '=>) (list-ref clause 1))
+                           #f)
+                       (list (r 'let) (list (list (r 'x) (car clause)))
+                             (list (r 'if) (r 'x)
+                                   (list (list-ref clause 2) (r 'x))
+                                   (cons (r 'cond) (cdr clauses))))
+                       (list (r 'if) (car clause)
+                             (cons (r 'begin) (cdr clause))
+                             (cons (r 'cond) (cdr clauses)))))))))))
 
   (define-syntax and
     (er-macro-transformer
@@ -203,9 +205,9 @@
   (define-syntax do
     (er-macro-transformer
      (lambda (form r compare)
-       (let ((bindings (cadr form))
-             (finish (caddr form))
-             (body (cdddr form)))
+       (let ((bindings (car (cdr form)))
+             (finish   (car (cdr (cdr form))))
+             (body     (cdr (cdr (cdr form)))))
          `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
                                         (list (car x) (cadr x)))
                                       bindings)
@@ -245,16 +247,18 @@
             ,(let loop ((clauses clauses))
                (if (null? clauses)
                    #f
-                   `(,(r 'if) ,(if (compare (r 'else) (caar clauses))
-                                   '#t
-                                   `(,(r 'or)
-                                     ,@(map (lambda (x)
-                                              `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
-                                            (caar clauses))))
-                     ,(if (compare (r '=>) (cadar clauses))
-                          `(,(caddar clauses) ,(r 'key))
-                          `(,(r 'begin) ,@(cdar clauses)))
-                        ,(loop (cdr clauses))))))))))
+                   (begin
+                     (define clause (car clauses))
+                     `(,(r 'if) ,(if (compare (r 'else) (car clause))
+                                     '#t
+                                     `(,(r 'or)
+                                       ,@(map (lambda (x)
+                                                `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
+                                              (car clause))))
+                       ,(if (compare (r '=>) (list-ref clause 1))
+                            `(,(list-ref clause 2) ,(r 'key))
+                            `(,(r 'begin) ,@(cdr clause)))
+                       ,(loop (cdr clauses)))))))))))
 
   (define-syntax letrec-syntax
     (er-macro-transformer
@@ -279,7 +283,6 @@
 ;;; multiple value
 (define-library (picrin multiple-value)
   (import (scheme base)
-          (scheme cxr)
           (picrin macro)
           (picrin core-syntax))
 
@@ -364,7 +367,6 @@
 ;;; parameter
 (define-library (picrin parameter)
   (import (scheme base)
-          (scheme cxr)
           (picrin macro)
           (picrin core-syntax)
           (picrin var)
@@ -434,8 +436,7 @@
 ;;; Record Type
 (define-library (picrin record)
   (import (scheme base)
-	  (scheme cxr)
-	  (picrin macro)
+          (picrin macro)
           (picrin core-syntax))
 
   (define record-marker (list 'record-marker))
@@ -541,9 +542,9 @@
   (define-syntax define-record-field
     (ir-macro-transformer
      (lambda (form inject compare?)
-       (let ((type (cadr form))
-	     (field-tag (caddr form))
-	     (acc-mod (cdddr form)))
+       (let ((type      (car (cdr form)))
+	     (field-tag (car (cdr (cdr form))))
+	     (acc-mod   (cdr (cdr (cdr form)))))
 	 (if (= 1 (length acc-mod))
 	     `(define ,(car acc-mod)
 		(record-accessor ,type ',field-tag))
@@ -557,9 +558,9 @@
     (ir-macro-transformer
      (lambda (form inject compare?)
        (let ((type (cadr form))
-	     (constructor (caddr form))
-	     (predicate (cadddr form))
-	     (field-tag (cddddr form)))
+	     (constructor (car (cdr (cdr form))))
+	     (predicate   (car (cdr (cdr (cdr form)))))
+	     (field-tag   (cdr (cdr (cdr (cdr form))))))
 	 `(begin
 	    (define ,type
 	      (make-record-type ',type ',(cdr constructor)))
@@ -987,8 +988,7 @@
 ;;; syntax-rules
 (define-library (picrin syntax-rules)
   (import (scheme base)
-	  (scheme cxr)
-	  (picrin macro))
+          (picrin macro))
 
   ;;; utility functions
   (define (reverse* l)
@@ -1261,9 +1261,9 @@
 	       ((compare (car clauses) 'mismatch)
 		`(,_syntax-error "invalid rule"))
 	       (else
-		(let ((vars (car (car clauses)))
-		      (match (cadr (car clauses)))
-		      (expand (caddr (car clauses))))
+		(let ((vars (list-ref (car clauses) 0))
+		      (match (list-ref (car clauses) 1))
+		      (expand (list-ref (car clauses) 2)))
 		  `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
 			  (,_let ((result (,_call/cc (,_lambda (exit) ,match))))
 				 (,_if result
@@ -1294,9 +1294,9 @@
 
        (let ((form (normalize-form form)))
 	 (if form
-	     (let ((ellipsis (cadr form))
-		   (literals (caddr form))
-		   (rules (cdddr form)))
+	     (let ((ellipsis (list-ref form 1))
+		   (literals (list-ref form 2))
+		   (rules (list-tail form 3)))
 	       (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
 				   rules)))
 		 `(,_er-macro-transformer

From d5a314b186ac1dc95a978911a644b28139360634 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 14:30:29 +0900
Subject: [PATCH 191/216] refactor define-values

---
 piclib/CMakeLists.txt |  2 +-
 piclib/prelude.scm    | 21 +++++++--------------
 2 files changed, 8 insertions(+), 15 deletions(-)

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index ce373fb2..50b59f9b 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,5 +1,5 @@
 list(APPEND PICLIB_SCHEME_LIBS
-  ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm # the only dependency prelude requires
   ${PROJECT_SOURCE_DIR}/piclib/prelude.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 6d8d6be9..7b45efa5 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -329,18 +329,6 @@
        expr)
       (reverse list)))
 
-  (define (predefine var)
-    `(define ,var #f))
-
-  (define (predefines vars)
-    (map predefine vars))
-
-  (define (assign var val)
-    `(set! ,var ,val))
-
-  (define (assigns vars vals)
-    (map assign vars vals))
-
   (define uniq
     (let ((counter 0))
       (lambda (x)
@@ -355,10 +343,15 @@
               (formal* (walk uniq formal))
               (exprs   (cddr form)))
          `(begin
-            ,@(predefines (flatten formal))
+            ,@(map
+               (lambda (var) `(define ,var #f))
+               (flatten formal))
             (call-with-values (lambda () ,@exprs)
               (lambda ,formal*
-                ,@(assigns (flatten formal) (flatten formal*)))))))))
+                ,@(map
+                   (lambda (var val) `(set! ,var ,val))
+                   (flatten formal)
+                   (flatten formal*)))))))))
 
   (export let-values
           let*-values

From c468b343d2aa7de6242f4d95e2670572f672dcf7 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 14:59:34 +0900
Subject: [PATCH 192/216] missing file

---
 piclib/picrin/macro.scm | 158 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 158 insertions(+)
 create mode 100644 piclib/picrin/macro.scm

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
new file mode 100644
index 00000000..e05003d3
--- /dev/null
+++ b/piclib/picrin/macro.scm
@@ -0,0 +1,158 @@
+;;; Hygienic Macros
+
+(define-library (picrin macro)
+  (import (scheme base)
+          (picrin dictionary))
+
+  ;; assumes no derived expressions are provided yet
+
+  (define (memq obj list)
+    (if (null? list)
+        #f
+        (if (eq? obj (car list))
+            list
+            (memq obj (cdr list)))))
+
+  (define (list->vector list)
+    (define vector (make-vector (length list)))
+    (define (go list i)
+      (if (null? list)
+          vector
+          (begin
+            (vector-set! vector i (car list))
+            (go (cdr list) (+ i 1)))))
+    (go list 0))
+
+  (define (vector->list vector)
+    (define (go i)
+      (if (= i (vector-length vector))
+          '()
+          (cons (vector-ref vector i)
+                (go (+ i 1)))))
+    (go 0))
+
+  (define (vector-map proc expr)
+    (list->vector (map proc (vector->list expr))))
+
+  (define (walk proc expr)
+    (if (null? expr)
+        '()
+        (if (pair? expr)
+            (cons (walk proc (car expr))
+                  (walk proc (cdr expr)))
+            (if (vector? expr)
+                (vector-map proc expr)
+                (proc expr)))))
+
+  (define (make-syntactic-closure env free form)
+    (define cache (make-dictionary))
+    (walk
+     (lambda (atom)
+       (if (not (symbol? atom))
+           atom
+           (if (memq atom free)
+               atom
+               (if (dictionary-has? cache atom)
+                   (dictionary-ref cache atom)
+                   (begin
+                     (define id (make-identifier atom env))
+                     (dictionary-set! cache atom id)
+                     id)))))
+     form))
+
+  (define (close-syntax form env)
+    (make-syntactic-closure env '() form))
+
+  (define-syntax capture-syntactic-environment
+    (lambda (form use-env mac-env)
+      (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))
+
+  (define (sc-macro-transformer f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure mac-env '() (f expr use-env))))
+
+  (define (rsc-macro-transformer f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure use-env '() (f expr mac-env))))
+
+  (define (er-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define cache (make-dictionary))
+
+      (define (rename sym)
+        (if (dictionary-has? cache sym)
+            (dictionary-ref cache sym)
+            (begin
+              (define id (make-identifier sym mac-env))
+              (dictionary-set! cache sym id)
+              id)))
+
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? use-env x use-env y))))
+
+      (f expr rename compare)))
+
+  (define (ir-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define protects (make-dictionary))
+
+      (define (wrap expr)
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (begin
+                 (define id (make-identifier atom use-env))
+                 (dictionary-set! protects id atom) ; lookup *atom* from id
+                 id)))
+         expr))
+
+      (define (unwrap expr)
+        (define cache (make-dictionary))
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (if (dictionary-has? protects atom)
+                   (dictionary-ref protects atom)
+                   (if (dictionary-has? cache atom)
+                       (dictionary-ref cache atom)
+                       (begin
+                         ;; implicit renaming
+                         (define id (make-identifier atom mac-env))
+                         (dictionary-set! cache atom id)
+                         id)))))
+         expr))
+
+      (define cache (make-dictionary))
+
+      (define (inject sym)
+        (if (dictionary-has? cache sym)
+            (dictionary-ref cache sym)
+            (begin
+              (define id (make-identifier sym use-env))
+              (dictionary-set! cache sym id)
+              id)))
+
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? mac-env x mac-env y))))
+
+      (unwrap (f (wrap expr) inject compare))))
+
+  (export make-syntactic-closure
+          close-syntax
+          capture-syntactic-environment
+          sc-macro-transformer
+          rsc-macro-transformer
+          er-macro-transformer
+          ir-macro-transformer))

From c148f7461849de196cbc3021363f4cd838603ad1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 15:11:17 +0900
Subject: [PATCH 193/216] include core-syntax at early stage

---
 piclib/prelude.scm | 25 +++++++++++--------------
 1 file changed, 11 insertions(+), 14 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 7b45efa5..16fe098d 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -279,12 +279,20 @@
           letrec-syntax
           _ ... syntax-error))
 
+(import (picrin core-syntax))
+
+(export let let* letrec letrec*
+        quasiquote unquote unquote-splicing
+        and or
+        cond case else =>
+        do when unless
+        letrec-syntax
+        _ ... syntax-error)
 
 ;;; multiple value
 (define-library (picrin multiple-value)
   (import (scheme base)
-          (picrin macro)
-          (picrin core-syntax))
+          (picrin macro))
 
   (define-syntax let*-values
     (er-macro-transformer
@@ -361,7 +369,6 @@
 (define-library (picrin parameter)
   (import (scheme base)
           (picrin macro)
-          (picrin core-syntax)
           (picrin var)
           (picrin attribute)
           (picrin dictionary))
@@ -429,8 +436,7 @@
 ;;; Record Type
 (define-library (picrin record)
   (import (scheme base)
-          (picrin macro)
-          (picrin core-syntax))
+          (picrin macro))
 
   (define record-marker (list 'record-marker))
 
@@ -569,19 +575,10 @@
   (export define-record-type vector?))
 
 (import (picrin macro)
-        (picrin core-syntax)
         (picrin multiple-value)
         (picrin parameter)
         (picrin record))
 
-(export let let* letrec letrec*
-        quasiquote unquote unquote-splicing
-        and or
-        cond case else =>
-        do when unless
-        letrec-syntax
-        _ ... syntax-error)
-
 (export let-values
         let*-values
         define-values)

From 88d86e13127e7645340774cf2e1f58aac9f5694a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 15:11:32 +0900
Subject: [PATCH 194/216] rename (picrin multiple-value) to (picrin values)

---
 piclib/prelude.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 16fe098d..204af992 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -290,7 +290,7 @@
         _ ... syntax-error)
 
 ;;; multiple value
-(define-library (picrin multiple-value)
+(define-library (picrin values)
   (import (scheme base)
           (picrin macro))
 
@@ -575,7 +575,7 @@
   (export define-record-type vector?))
 
 (import (picrin macro)
-        (picrin multiple-value)
+        (picrin values)
         (picrin parameter)
         (picrin record))
 

From 5779fcd4e4033d63aa214e6867313c8c19042723 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 15:13:47 +0900
Subject: [PATCH 195/216] no need to override vector? with export syntax

---
 piclib/prelude.scm | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 204af992..9bc59aa6 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -572,7 +572,7 @@
 		 `(define-record-field ,type ,(car x) ,(cadr x) ,@(cddr x)))
 	       field-tag))))))
 
-  (export define-record-type vector?))
+  (export define-record-type))
 
 (import (picrin macro)
         (picrin values)
@@ -586,8 +586,7 @@
 (export make-parameter
         parameterize)
 
-(export vector?                         ; override definition
-        define-record-type)
+(export define-record-type)
 
 (define (every pred list)
   (if (null? list)

From aa498b89949574c9c577e44fcb5c89d4173c7926 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Sat, 19 Jul 2014 16:37:38 +0900
Subject: [PATCH 196/216] unlock testable cases

---
 t/r7rs-tests.scm | 52 ++++++++++++++++++++++++------------------------
 1 file changed, 26 insertions(+), 26 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 7c7cfbeb..c0877161 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -2146,14 +2146,14 @@
 ;; tests are run by default - need to cond-expand and test for
 ;; infinities and -0.0.
 
-;; (define-syntax test-numeric-syntax
-;;   (syntax-rules ()
-;;     ((test-numeric-syntax str expect strs ...)
-;;      (let* ((z (read (open-input-string str)))
-;;             (out (open-output-string))
-;;             (z-str (begin (write z out) (get-output-string out))))
-;;        (test expect (values z))
-;;        (test #t (and (member z-str '(str strs ...)) #t))))))
+(define-syntax test-numeric-syntax
+  (syntax-rules ()
+    ((test-numeric-syntax str expect strs ...)
+     (let* ((z (read (open-input-string str)))
+            (out (open-output-string))
+            (z-str (begin (write z out) (get-output-string out))))
+       (test expect (values z))
+       (test #t (and (member z-str '(str strs ...)) #t))))))
 
 ;; Each test is of the form:
 ;;
@@ -2170,20 +2170,20 @@
 ;;   (test-numeric-syntax input-str expected-value (input-str))
 
 ;; Simple
-;; (test-numeric-syntax "1" 1)
+(test-numeric-syntax "1" 1)
 ;; (test-numeric-syntax "+1" 1 "1")
-;; (test-numeric-syntax "-1" -1)
+(test-numeric-syntax "-1" -1)
 ;; (test-numeric-syntax "#i1" 1.0 "1.0" "1.")
 ;; (test-numeric-syntax "#I1" 1.0 "1.0" "1.")
 ;; (test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.")
 ;; ;; Decimal
-;; (test-numeric-syntax "1.0" 1.0 "1.0" "1.")
-;; (test-numeric-syntax "1." 1.0 "1.0" "1.")
-;; (test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3")
-;; (test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3")
+(test-numeric-syntax "1.0" 1.0 "1.0" "1.")
+(test-numeric-syntax "1." 1.0 "1.0" "1.")
+(test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3")
+(test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3")
 ;; ;; Some Schemes don't allow negative zero. This is okay with the standard
-;; (test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0")
-;; (test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0")
+(test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0")
+(test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0")
 ;; (test-numeric-syntax "#i1.0" 1.0 "1.0" "1.")
 ;; (test-numeric-syntax "#e1.0" 1 "1")
 ;; (test-numeric-syntax "#e-.0" 0 "0")
@@ -2200,21 +2200,21 @@
 ;; (test-numeric-syntax "1l2" 100.0 "100.0" "100.")
 ;; (test-numeric-syntax "1L2" 100.0 "100.0" "100.")
 ;; ;; NaN, Inf
-;; (test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0")
-;; (test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0")
-;; (test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0")
-;; (test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0")
-;; (test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0")
-;; (test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0")
+(test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0")
+(test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0")
 ;; (test-numeric-syntax "#i+nan.0" +nan.0 "+nan.0" "+NaN.0")
 ;; (test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0")
 ;; (test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0")
 ;; ;; Exact ratios
-;; (test-numeric-syntax "1/2" (/ 1 2))
+(test-numeric-syntax "1/2" (/ 1 2))
 ;; (test-numeric-syntax "#e1/2" (/ 1 2) "1/2")
-;; (test-numeric-syntax "10/2" 5 "5")
-;; (test-numeric-syntax "-1/2" (- (/ 1 2)))
-;; (test-numeric-syntax "0/10" 0 "0")
+(test-numeric-syntax "10/2" 5 "5")
+(test-numeric-syntax "-1/2" (- (/ 1 2)))
+(test-numeric-syntax "0/10" 0 "0")
 ;; (test-numeric-syntax "#e0/10" 0 "0")
 ;; (test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5")
 ;; ;; Exact complex

From 79afb228332ee12c11cdbb95d706b890133f6fb0 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Sat, 19 Jul 2014 16:44:41 +0900
Subject: [PATCH 197/216] fix a bug of plus reader

---
 src/read.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/read.c b/src/read.c
index 2b5c53be..62467ece 100644
--- a/src/read.c
+++ b/src/read.c
@@ -278,7 +278,7 @@ read_plus(pic_state *pic, struct pic_port *port, char c)
   pic_value sym;
 
   if (isdigit(peek(port))) {
-    return read_number(pic, port, c);
+    return read_number(pic, port, next(port));
   }
   else {
     sym = read_symbol(pic, port, c);

From 346494524fdabffb487f33d5eb6eef5a4b6d0efb Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 18:10:14 +0900
Subject: [PATCH 198/216] share cache between wrap and inject

---
 piclib/picrin/macro.scm | 69 +++++++++++++++++++++--------------------
 1 file changed, 35 insertions(+), 34 deletions(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index f1281fec..ffb713b5 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -93,44 +93,26 @@
   (define (ir-macro-transformer f)
     (lambda (expr use-env mac-env)
 
-      (define protects (make-dictionary))
-
-      (define (wrap expr)
-        (walk
-         (lambda (atom)
-           (if (not (symbol? atom))
-               atom
-               (begin
-                 (define id (make-identifier atom use-env))
-                 (dictionary-set! protects id atom) ; lookup *atom* from id
-                 id)))
-         expr))
-
-      (define (unwrap expr)
-        (define cache (make-dictionary))
-        (walk
-         (lambda (atom)
-           (if (not (symbol? atom))
-               atom
-               (if (dictionary-has? protects atom)
-                   (dictionary-ref protects atom)
-                   (if (dictionary-has? cache atom)
-                       (dictionary-ref cache atom)
-                       (begin
-                         ;; implicit renaming
-                         (define id (make-identifier atom mac-env))
-                         (dictionary-set! cache atom id)
-                         id)))))
-         expr))
-
-      (define cache (make-dictionary))
+      (define icache (make-dictionary))
+      (define icache* (make-dictionary))
 
       (define (inject sym)
-        (if (dictionary-has? cache sym)
-            (dictionary-ref cache sym)
+        (if (dictionary-has? icache sym)
+            (dictionary-ref icache sym)
             (begin
               (define id (make-identifier sym use-env))
-              (dictionary-set! cache sym id)
+              (dictionary-set! icache sym id)
+              (dictionary-set! icache* id sym)
+              id)))
+
+      (define rcache (make-dictionary))
+
+      (define (rename sym)
+        (if (dictionary-has? rcache sym)
+            (dictionary-ref rcache sym)
+            (begin
+              (define id (make-identifier sym mac-env))
+              (dictionary-set! rcache sym id)
               id)))
 
       (define (compare x y)
@@ -140,6 +122,25 @@
                 #f
                 (identifier=? mac-env x mac-env y))))
 
+      (define (wrap expr)
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (inject atom)))
+         expr))
+
+      (define (unwrap expr)
+        (define cache (make-dictionary))
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (if (dictionary-has? icache* atom)
+                   (dictionary-ref icache* atom)
+                   (rename atom))))
+         expr))
+
       (unwrap (f (wrap expr) inject compare))))
 
   (export make-syntactic-closure

From 2c1db4472bc49d3e3772b6d11e8e67ad03862192 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 18:14:11 +0900
Subject: [PATCH 199/216] add walk-symbol

---
 piclib/picrin/macro.scm | 52 ++++++++++++++++++++---------------------
 1 file changed, 25 insertions(+), 27 deletions(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index ffb713b5..e5002f8a 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -37,20 +37,26 @@
                 (vector-map proc expr)
                 (proc expr)))))
 
-  (define (make-syntactic-closure env free form)
-    (define cache (make-dictionary))
+  (define (walk-symbol proc expr)
     (walk
      (lambda (atom)
-       (if (not (symbol? atom))
-           atom
-           (if (memq atom free)
-               atom
-               (if (dictionary-has? cache atom)
-                   (dictionary-ref cache atom)
-                   (begin
-                     (define id (make-identifier atom env))
-                     (dictionary-set! cache atom id)
-                     id)))))
+       (if (symbol? atom)
+           (proc atom)
+           atom))
+     expr))
+
+  (define (make-syntactic-closure env free form)
+    (define cache (make-dictionary))
+    (walk-symbol
+     (lambda (sym)
+       (if (memq sym free)
+           sym
+           (if (dictionary-has? cache sym)
+               (dictionary-ref cache sym)
+               (begin
+                 (define id (make-identifier sym env))
+                 (dictionary-set! cache sym id)
+                 id))))
      form))
 
   (define (close-syntax form env)
@@ -115,6 +121,11 @@
               (dictionary-set! rcache sym id)
               id)))
 
+      (define (uninject sym)
+        (if (dictionary-has? icache* sym)
+            (dictionary-ref icache* sym)
+            (rename sym)))
+
       (define (compare x y)
         (if (not (symbol? x))
             #f
@@ -123,23 +134,10 @@
                 (identifier=? mac-env x mac-env y))))
 
       (define (wrap expr)
-        (walk
-         (lambda (atom)
-           (if (not (symbol? atom))
-               atom
-               (inject atom)))
-         expr))
+        (walk-symbol inject expr))
 
       (define (unwrap expr)
-        (define cache (make-dictionary))
-        (walk
-         (lambda (atom)
-           (if (not (symbol? atom))
-               atom
-               (if (dictionary-has? icache* atom)
-                   (dictionary-ref icache* atom)
-                   (rename atom))))
-         expr))
+        (walk-symbol uninject expr))
 
       (unwrap (f (wrap expr) inject compare))))
 

From 03cc21953f30614469961536230092e07e43f83f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 18:15:38 +0900
Subject: [PATCH 200/216] walk-symbol by default

---
 piclib/picrin/macro.scm | 18 +++++++-----------
 1 file changed, 7 insertions(+), 11 deletions(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index e5002f8a..bec9cdd0 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -28,6 +28,7 @@
     (list->vector (map proc (vector->list expr))))
 
   (define (walk proc expr)
+    "walk on symbols"
     (if (null? expr)
         '()
         (if (pair? expr)
@@ -35,19 +36,14 @@
                   (walk proc (cdr expr)))
             (if (vector? expr)
                 (vector-map proc expr)
-                (proc expr)))))
+                (if (symbol? expr)
+                    (proc expr)
+                    expr)))))
 
-  (define (walk-symbol proc expr)
-    (walk
-     (lambda (atom)
-       (if (symbol? atom)
-           (proc atom)
-           atom))
-     expr))
 
   (define (make-syntactic-closure env free form)
     (define cache (make-dictionary))
-    (walk-symbol
+    (walk
      (lambda (sym)
        (if (memq sym free)
            sym
@@ -134,10 +130,10 @@
                 (identifier=? mac-env x mac-env y))))
 
       (define (wrap expr)
-        (walk-symbol inject expr))
+        (walk inject expr))
 
       (define (unwrap expr)
-        (walk-symbol uninject expr))
+        (walk uninject expr))
 
       (unwrap (f (wrap expr) inject compare))))
 

From 1297ef9fb8e176a2d75cc7975c35a35a26385aff Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 18:26:03 +0900
Subject: [PATCH 201/216] add memoize function

---
 piclib/picrin/macro.scm | 65 ++++++++++++++++++++---------------------
 1 file changed, 31 insertions(+), 34 deletions(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index bec9cdd0..a5155b21 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -40,19 +40,29 @@
                     (proc expr)
                     expr)))))
 
+  (define (memoize f)
+    "memoize on a symbol"
+    (define cache (make-dictionary))
+    (lambda (sym)
+      (if (dictionary-has? cache sym)
+          (dictionary-ref cache sym)
+          (begin
+            (define val (f sym))
+            (dictionary-set! cache sym val)
+            val))))
 
   (define (make-syntactic-closure env free form)
-    (define cache (make-dictionary))
+
+    (define resolve
+      (memoize
+       (lambda (sym)
+         (make-identifier sym env))))
+
     (walk
      (lambda (sym)
        (if (memq sym free)
            sym
-           (if (dictionary-has? cache sym)
-               (dictionary-ref cache sym)
-               (begin
-                 (define id (make-identifier sym env))
-                 (dictionary-set! cache sym id)
-                 id))))
+           (resolve sym)))
      form))
 
   (define (close-syntax form env)
@@ -73,15 +83,10 @@
   (define (er-macro-transformer f)
     (lambda (expr use-env mac-env)
 
-      (define cache (make-dictionary))
-
-      (define (rename sym)
-        (if (dictionary-has? cache sym)
-            (dictionary-ref cache sym)
-            (begin
-              (define id (make-identifier sym mac-env))
-              (dictionary-set! cache sym id)
-              id)))
+      (define rename
+        (memoize
+         (lambda (sym)
+           (make-identifier sym mac-env))))
 
       (define (compare x y)
         (if (not (symbol? x))
@@ -95,27 +100,19 @@
   (define (ir-macro-transformer f)
     (lambda (expr use-env mac-env)
 
-      (define icache (make-dictionary))
       (define icache* (make-dictionary))
 
-      (define (inject sym)
-        (if (dictionary-has? icache sym)
-            (dictionary-ref icache sym)
-            (begin
-              (define id (make-identifier sym use-env))
-              (dictionary-set! icache sym id)
-              (dictionary-set! icache* id sym)
-              id)))
+      (define inject
+        (memoize
+         (lambda (sym)
+           (define id (make-identifier sym use-env))
+           (dictionary-set! icache* id sym)
+           id)))
 
-      (define rcache (make-dictionary))
-
-      (define (rename sym)
-        (if (dictionary-has? rcache sym)
-            (dictionary-ref rcache sym)
-            (begin
-              (define id (make-identifier sym mac-env))
-              (dictionary-set! rcache sym id)
-              id)))
+      (define rename
+        (memoize
+         (lambda (sym)
+           (make-identifier sym mac-env))))
 
       (define (uninject sym)
         (if (dictionary-has? icache* sym)

From 63c34327b97185bc68cbf502f5044951f256d941 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 18:26:09 +0900
Subject: [PATCH 202/216] fix a bug in walk function

---
 piclib/picrin/macro.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index a5155b21..8f279b51 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -35,7 +35,7 @@
             (cons (walk proc (car expr))
                   (walk proc (cdr expr)))
             (if (vector? expr)
-                (vector-map proc expr)
+                (list->vector (walk proc (vector->list expr)))
                 (if (symbol? expr)
                     (proc expr)
                     expr)))))

From 8b82498cd7932fae3fa6bc71b5907f7552beb313 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 18:28:10 +0900
Subject: [PATCH 203/216] inline some trivial functions

---
 piclib/picrin/macro.scm | 17 +++++------------
 1 file changed, 5 insertions(+), 12 deletions(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index 8f279b51..b2cccec3 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -114,11 +114,6 @@
          (lambda (sym)
            (make-identifier sym mac-env))))
 
-      (define (uninject sym)
-        (if (dictionary-has? icache* sym)
-            (dictionary-ref icache* sym)
-            (rename sym)))
-
       (define (compare x y)
         (if (not (symbol? x))
             #f
@@ -126,13 +121,11 @@
                 #f
                 (identifier=? mac-env x mac-env y))))
 
-      (define (wrap expr)
-        (walk inject expr))
-
-      (define (unwrap expr)
-        (walk uninject expr))
-
-      (unwrap (f (wrap expr) inject compare))))
+      (walk (lambda (sym)
+              (if (dictionary-has? icache* sym)
+                  (dictionary-ref icache* sym)
+                  (rename sym)))
+            (f (walk inject expr) inject compare))))
 
   (export make-syntactic-closure
           close-syntax

From 3e5fd1a54b21c91e3ba5b3701e3eb6a2a1ce90cc Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sat, 19 Jul 2014 18:46:09 +0900
Subject: [PATCH 204/216] vector-map is no longer used

---
 piclib/picrin/macro.scm | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index b2cccec3..9c3d482e 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -24,9 +24,6 @@
                 (go (+ i 1)))))
     (go 0))
 
-  (define (vector-map proc expr)
-    (list->vector (map proc (vector->list expr))))
-
   (define (walk proc expr)
     "walk on symbols"
     (if (null? expr)

From 6a038bc9268f6c082e07bd7ea795831f9b3f5f3e Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 09:36:18 +0900
Subject: [PATCH 205/216] change init_contrib API

---
 contrib/10.regexp/CMakeLists.txt |  2 +-
 contrib/CMakeLists.txt           |  2 --
 etc/mkinit.pl                    | 32 ++++++++++++++++++++++++++++++++
 src/CMakeLists.txt               | 14 ++++++++++++--
 src/init.c                       |  7 +------
 5 files changed, 46 insertions(+), 11 deletions(-)
 create mode 100755 etc/mkinit.pl

diff --git a/contrib/10.regexp/CMakeLists.txt b/contrib/10.regexp/CMakeLists.txt
index f71ccfc7..6ab06aaa 100644
--- a/contrib/10.regexp/CMakeLists.txt
+++ b/contrib/10.regexp/CMakeLists.txt
@@ -7,7 +7,7 @@ if (REGEX_FOUND)
 
   file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.regexp/src/*.c)
 
-  list(APPEND PICRIN_CONTRIB_INITS "void pic_init_regexp(pic_state *)\; pic_init_regexp(pic)\;")
+  list(APPEND PICRIN_CONTRIB_INITS regexp)
   list(APPEND PICRIN_CONTRIB_LIBRARIES ${REGEX_LIBRARIES})
   list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_REGEX_SOURCES})
 endif()
diff --git a/contrib/CMakeLists.txt b/contrib/CMakeLists.txt
index 2487f0d0..11050d90 100644
--- a/contrib/CMakeLists.txt
+++ b/contrib/CMakeLists.txt
@@ -3,5 +3,3 @@ list(SORT CONTRIBS)
 foreach(contrib ${CONTRIBS})
   include(${contrib})
 endforeach()
-
-add_definitions("-DPIC_CONTRIB_INITS=${PICRIN_CONTRIB_INITS}")
diff --git a/etc/mkinit.pl b/etc/mkinit.pl
new file mode 100755
index 00000000..d559db27
--- /dev/null
+++ b/etc/mkinit.pl
@@ -0,0 +1,32 @@
+#!/usr/bin/perl
+
+use strict;
+
+print <<EOL;
+/**
+ *                                !!NOTICE!!
+ * This file was automatically generated by mkinit.pl, and includes all of
+ * the prelude files required by Picrin. PLEASE DO NOT EDIT THIS FILE, changes
+ * will be overwritten the next time the script runs.
+ */
+
+#include "picrin.h"
+
+void
+pic_init_contrib(pic_state *pic)
+{
+EOL
+
+foreach my $lib (@ARGV) {
+    print "  void pic_init_$lib(pic_state *);\n";
+}
+
+print;
+
+foreach my $lib (@ARGV) {
+    print "  pic_init_$lib(pic);\n";
+}
+
+print <<EOL;
+}
+EOL
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
index 9318f442..f3e51499 100644
--- a/src/CMakeLists.txt
+++ b/src/CMakeLists.txt
@@ -1,8 +1,9 @@
+find_package(Perl REQUIRED)
+
 # xfile
 set(XFILE_SOURCES extlib/xfile/xfile.c)
 
 # piclib
-find_package(Perl REQUIRED)
 set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c)
 add_custom_command(
   OUTPUT ${PICLIB_SOURCE}
@@ -11,9 +12,18 @@ add_custom_command(
   WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}
   )
 
+# contrib
+set(CONTRIB_INIT ${PROJECT_SOURCE_DIR}/src/init_contrib.c)
+add_custom_command(
+  OUTPUT ${CONTRIB_INIT}
+  COMMAND ${PERL_EXECUTABLE} etc/mkinit.pl ${PICRIN_CONTRIB_INITS} > ${CONTRIB_INIT}
+  DEPENDS ${PICRIN_CONTRIB_SOURCES}
+  WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}
+  )
+
 # build!
 file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c)
-add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES})
+add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
 target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES})
 
 # install
diff --git a/src/init.c b/src/init.c
index c6667a3b..b59e0600 100644
--- a/src/init.c
+++ b/src/init.c
@@ -31,15 +31,10 @@ void pic_init_load(pic_state *);
 void pic_init_write(pic_state *);
 void pic_init_read(pic_state *);
 void pic_init_dict(pic_state *);
+void pic_init_contrib(pic_state *);
 
 void pic_load_piclib(pic_state *);
 
-void
-pic_init_contrib(pic_state *pic)
-{
-  PIC_CONTRIB_INITS
-}
-
 #define push_sym(pic, name, list)                                       \
   pic_push(pic, pic_symbol_value(pic_intern_cstr(pic, name)), list)
 

From b901188aa08484049a9c7973cf5978df1897a482 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 09:46:04 +0900
Subject: [PATCH 206/216] update gitignore

---
 .gitignore | 1 +
 1 file changed, 1 insertion(+)

diff --git a/.gitignore b/.gitignore
index e0975baf..d13a2485 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,5 +1,6 @@
 build/*
 src/load_piclib.c
+src/init_contrib.c
 .dir-locals.el
 GPATH
 GRTAGS

From 240c5d9ac4ba3401b12352f8944f6c3e162a114f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 11:11:39 +0900
Subject: [PATCH 207/216] implement define-macro in scheme

---
 piclib/picrin/macro.scm | 17 ++++++++++++++++-
 1 file changed, 16 insertions(+), 1 deletion(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index 9c3d482e..2f9fe7e0 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -124,10 +124,25 @@
                   (rename sym)))
             (f (walk inject expr) inject compare))))
 
+  (define-syntax define-macro
+    (er-macro-transformer
+     (lambda (expr r c)
+       (define formal (car (cdr expr)))
+       (define body   (cdr (cdr expr)))
+       (if (symbol? formal)
+           (list (r 'define-syntax) formal
+                 (list (r 'lambda) (list (r 'form) '_ '_)
+                       (list (r 'apply) (car body) (list (r 'cdr) (r 'form)))))
+           (list (r 'define-macro) (car formal)
+                 (cons (r 'lambda)
+                       (cons (cdr formal)
+                             body)))))))
+
   (export make-syntactic-closure
           close-syntax
           capture-syntactic-environment
           sc-macro-transformer
           rsc-macro-transformer
           er-macro-transformer
-          ir-macro-transformer))
+          ir-macro-transformer
+          define-macro))

From c43120077ca0baf629064477364b04133f5cba7a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 11:15:12 +0900
Subject: [PATCH 208/216] remove internal defmacro expander

---
 include/picrin.h |  4 ++--
 src/macro.c      | 54 ------------------------------------------------
 src/state.c      |  2 --
 3 files changed, 2 insertions(+), 58 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index 2d14dc68..ff0b1a78 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -80,14 +80,14 @@ typedef struct {
 
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
-  pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO, sLET_SYNTAX;
+  pic_sym sDEFINE_SYNTAX, sLET_SYNTAX;
   pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
   pic_sym sCONS, sCAR, sCDR, sNILP;
   pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
   pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
 
   pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
-  pic_sym rDEFINE_SYNTAX, rDEFINE_MACRO, rLET_SYNTAX;
+  pic_sym rDEFINE_SYNTAX, rLET_SYNTAX;
   pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
 
   xhash syms;                   /* name to symbol */
diff --git a/src/macro.c b/src/macro.c
index 13eea311..b69855c8 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -316,53 +316,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   return pic_none_value();
 }
 
-static pic_value
-macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  pic_value var, val;
-  pic_sym sym, rename;
-
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  var = pic_car(pic, pic_cdr(pic, expr));
-  if (pic_pair_p(var)) {
-    /* FIXME: unhygienic */
-    val = pic_cons(pic, pic_sym_value(pic->sLAMBDA),
-                   pic_cons(pic, pic_cdr(pic, var),
-                            pic_cdr(pic, pic_cdr(pic, expr))));
-    var = pic_car(pic, var);
-  }
-  else {
-    if (pic_length(pic, expr) != 3) {
-      pic_error(pic, "syntax_error");
-    }
-    val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
-  }
-  if (! pic_sym_p(var)) {
-    pic_error(pic, "syntax error");
-  }
-  sym = pic_sym(var);
-  if (! pic_find_rename(pic, senv, sym, &rename)) {
-    rename = pic_add_rename(pic, senv, sym);
-  }
-
-  pic_try {
-    val = pic_eval(pic, val);
-  } pic_catch {
-    pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
-  }
-
-  if (! pic_proc_p(val)) {
-    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
-  }
-
-  define_macro(pic, rename, pic_proc_ptr(val), NULL);
-
-  return pic_none_value();
-}
-
 static pic_value
 macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
@@ -471,9 +424,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
       else if (tag == pic->rDEFINE_SYNTAX) {
         return macroexpand_defsyntax(pic, expr, senv);
       }
-      else if (tag == pic->rDEFINE_MACRO) {
-        return macroexpand_defmacro(pic, expr, senv);
-      }
       else if (tag == pic->rLET_SYNTAX) {
         return macroexpand_let_syntax(pic, expr, senv);
       }
@@ -693,10 +643,6 @@ void
 pic_init_macro(pic_state *pic)
 {
   pic_deflibrary ("(picrin macro)") {
-
-    /* export define-macro syntax */
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->rDEFINE_MACRO);
-
     pic_defun(pic, "gensym", pic_macro_gensym);
     pic_defun(pic, "macroexpand", pic_macro_macroexpand);
     pic_defun(pic, "identifier?", pic_macro_identifier_p);
diff --git a/src/state.c b/src/state.c
index 9da1852c..b910baed 100644
--- a/src/state.c
+++ b/src/state.c
@@ -95,7 +95,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sUNQUOTE, "unquote");
   register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
   register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
-  register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
   register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
@@ -129,7 +128,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_renamed_symbol(pic, rSETBANG, "set!");
   register_renamed_symbol(pic, rQUOTE, "quote");
   register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
-  register_renamed_symbol(pic, rDEFINE_MACRO, "define-macro");
   register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax");
   register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
   register_renamed_symbol(pic, rIMPORT, "import");

From 1b104a00a7f64bcc81e00e51e05ab656d86f8de1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 13:16:50 +0900
Subject: [PATCH 209/216] add macroexpand-1

---
 src/macro.c | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 59 insertions(+)

diff --git a/src/macro.c b/src/macro.c
index b69855c8..7e7c8ee2 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -10,6 +10,7 @@
 #include "picrin/lib.h"
 #include "picrin/error.h"
 #include "picrin/dict.h"
+#include "picrin/cont.h"
 
 pic_sym
 pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
@@ -508,6 +509,47 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   return v;
 }
 
+static pic_value
+macroexpand_one(pic_state *pic, pic_value expr, struct pic_senv *senv)
+{
+  struct pic_macro *mac;
+  pic_value v, args;
+
+  if (pic_sym_p(expr)) {
+    pic_sym sym;
+
+    sym = pic_sym(expr);
+
+    if (pic_interned_p(pic, sym)) {
+      return pic_sym_value(make_identifier(pic, pic_sym(expr), senv));
+    }
+  }
+  if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) {
+    pic_sym sym;
+
+    sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv);
+
+    if ((mac = find_macro(pic, sym)) != NULL) {
+      if (mac->senv == NULL) { /* legacy macro */
+        args = pic_cdr(pic, expr);
+      }
+      else {
+        args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
+      }
+
+      pic_try {
+        v = pic_apply(pic, mac->proc, args);
+      } pic_catch {
+        pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
+      }
+
+      return v;
+    }
+  }
+
+  return pic_undef_value();     /* no expansion occurred */
+}
+
 struct pic_senv *
 pic_senv_new(pic_state *pic, struct pic_senv *up)
 {
@@ -595,6 +637,22 @@ pic_macro_macroexpand(pic_state *pic)
   return pic_macroexpand(pic, expr);
 }
 
+static pic_value
+pic_macro_macroexpand_1(pic_state *pic)
+{
+  pic_value expr, val;
+
+  pic_get_args(pic, "o", &expr);
+
+  val = macroexpand_one(pic, expr, pic->lib->senv);
+  if (pic_undef_p(val)) {
+    return pic_values2(pic, expr, pic_false_value());
+  }
+  else {
+    return pic_values2(pic, val, pic_true_value());
+  }
+}
+
 static pic_value
 pic_macro_identifier_p(pic_state *pic)
 {
@@ -645,6 +703,7 @@ pic_init_macro(pic_state *pic)
   pic_deflibrary ("(picrin macro)") {
     pic_defun(pic, "gensym", pic_macro_gensym);
     pic_defun(pic, "macroexpand", pic_macro_macroexpand);
+    pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1);
     pic_defun(pic, "identifier?", pic_macro_identifier_p);
     pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
     pic_defun(pic, "make-identifier", pic_macro_make_identifier);

From 95a3f8880c803553845dda83370bfdea176b4a08 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 13:52:48 +0900
Subject: [PATCH 210/216] disallow non-symbol objects at places where symbol is
 required

---
 src/macro.c | 15 ---------------
 1 file changed, 15 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 7e7c8ee2..1d338cad 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -216,17 +216,11 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
   for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
     pic_value v = pic_car(pic, a);
 
-    if (! pic_sym_p(v)) {
-      v = macroexpand(pic, v, senv);
-    }
     if (! pic_sym_p(v)) {
       pic_error(pic, "syntax error");
     }
     pic_add_rename(pic, in, pic_sym(v));
   }
-  if (! pic_sym_p(a)) {
-    a = macroexpand(pic, a, senv);
-  }
   if (pic_sym_p(a)) {
     pic_add_rename(pic, in, pic_sym(a));
   }
@@ -259,9 +253,6 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
     }
     var = formal;
   }
-  if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv);
-  }
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
   }
@@ -289,9 +280,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   }
 
   var = pic_cadr(pic, expr);
-  if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv);
-  }
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
   }
@@ -336,9 +324,6 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   }
   pic_for_each (v, formal) {
     var = pic_car(pic, v);
-    if (! pic_sym_p(var)) {
-      var = macroexpand(pic, var, senv);
-    }
     if (! pic_sym_p(var)) {
       pic_error(pic, "binding to non-symbol object");
     }

From 0d8e50bf586b9925d92e97da22d5d424e8837aa0 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 13:54:03 +0900
Subject: [PATCH 211/216] update docs

---
 docs/libs.rst | 1 +
 1 file changed, 1 insertion(+)

diff --git a/docs/libs.rst b/docs/libs.rst
index 91593c89..b87d7980 100644
--- a/docs/libs.rst
+++ b/docs/libs.rst
@@ -50,6 +50,7 @@ Utility functions and syntaces for macro definition.
 - define-macro
 - gensym
 - macroexpand
+- macroexpand-1
 
 Old-fashioned macro.
 

From 7a2f8abd9c227a3d3233d1e12a7594f0a30ff90a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 14:55:17 +0900
Subject: [PATCH 212/216] rewrite let-syntax in scheme

---
 include/picrin.h   |  4 ++--
 piclib/prelude.scm |  9 +++++++--
 src/init.c         |  1 -
 src/macro.c        | 38 --------------------------------------
 src/state.c        |  2 --
 5 files changed, 9 insertions(+), 45 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index ff0b1a78..fd3b4ca2 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -80,14 +80,14 @@ typedef struct {
 
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
-  pic_sym sDEFINE_SYNTAX, sLET_SYNTAX;
+  pic_sym sDEFINE_SYNTAX;
   pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
   pic_sym sCONS, sCAR, sCDR, sNILP;
   pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
   pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
 
   pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
-  pic_sym rDEFINE_SYNTAX, rLET_SYNTAX;
+  pic_sym rDEFINE_SYNTAX;
   pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
 
   xhash syms;                   /* name to symbol */
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index e9c756b2..7049c2f0 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -271,12 +271,17 @@
                    formal)
             ,@body)))))
 
+  (define-syntax let-syntax
+    (er-macro-transformer
+     (lambda (form r c)
+       `(,(r 'letrec-syntax) ,@(cdr form)))))
+
   (export let let* letrec letrec*
           quasiquote unquote unquote-splicing
           and or
           cond case else =>
           do when unless
-          letrec-syntax
+          let-syntax letrec-syntax
           _ ... syntax-error))
 
 (import (picrin core-syntax))
@@ -286,7 +291,7 @@
         and or
         cond case else =>
         do when unless
-        letrec-syntax
+        let-syntax letrec-syntax
         _ ... syntax-error)
 
 ;;; multiple value
diff --git a/src/init.c b/src/init.c
index b59e0600..56264da7 100644
--- a/src/init.c
+++ b/src/init.c
@@ -70,7 +70,6 @@ pic_init_core(pic_state *pic)
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX);
 
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
diff --git a/src/macro.c b/src/macro.c
index 1d338cad..d0372540 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -305,41 +305,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   return pic_none_value();
 }
 
-static pic_value
-macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  struct pic_senv *in;
-  pic_value formal, v, var, val;
-  pic_sym sym, rename;
-
-  in = pic_senv_new(pic, senv);
-
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  formal = pic_cadr(pic, expr);
-  if (! pic_list_p(formal)) {
-    pic_error(pic, "syntax error");
-  }
-  pic_for_each (v, formal) {
-    var = pic_car(pic, v);
-    if (! pic_sym_p(var)) {
-      pic_error(pic, "binding to non-symbol object");
-    }
-    sym = pic_sym(var);
-    if (! pic_find_rename(pic, in, sym, &rename)) {
-      rename = pic_add_rename(pic, in, sym);
-    }
-    val = pic_eval(pic, pic_cadr(pic, v));
-    if (! pic_proc_p(val)) {
-      pic_errorf(pic, "macro definition \"~s\" evaluated to non-procedure object", var);
-    }
-    define_macro(pic, rename, pic_proc_ptr(val), senv);
-  }
-  return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in));
-}
-
 static pic_value
 macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
 {
@@ -410,9 +375,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
       else if (tag == pic->rDEFINE_SYNTAX) {
         return macroexpand_defsyntax(pic, expr, senv);
       }
-      else if (tag == pic->rLET_SYNTAX) {
-        return macroexpand_let_syntax(pic, expr, senv);
-      }
       else if (tag == pic->rLAMBDA) {
         return macroexpand_lambda(pic, expr, senv);
       }
diff --git a/src/state.c b/src/state.c
index b910baed..758bae9c 100644
--- a/src/state.c
+++ b/src/state.c
@@ -95,7 +95,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sUNQUOTE, "unquote");
   register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
   register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
-  register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
   register_core_symbol(pic, sEXPORT, "export");
@@ -128,7 +127,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_renamed_symbol(pic, rSETBANG, "set!");
   register_renamed_symbol(pic, rQUOTE, "quote");
   register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
-  register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax");
   register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
   register_renamed_symbol(pic, rIMPORT, "import");
   register_renamed_symbol(pic, rEXPORT, "export");

From 72422343c08dd1c5b5b28b8b9ba235efe4a95490 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 15:30:48 +0900
Subject: [PATCH 213/216] s/lib->senv/lib->env/g

---
 include/picrin/lib.h |  2 +-
 src/codegen.c        |  2 +-
 src/gc.c             |  2 +-
 src/init.c           | 16 ++++++++--------
 src/lib.c            |  8 ++++----
 src/macro.c          |  8 ++++----
 src/vm.c             |  4 ++--
 7 files changed, 21 insertions(+), 21 deletions(-)

diff --git a/include/picrin/lib.h b/include/picrin/lib.h
index 53a086f2..ba43e49d 100644
--- a/include/picrin/lib.h
+++ b/include/picrin/lib.h
@@ -12,7 +12,7 @@ extern "C" {
 struct pic_lib {
   PIC_OBJECT_HEADER
   pic_value name;
-  struct pic_senv *senv;
+  struct pic_senv *env;
   xhash exports;
 };
 
diff --git a/src/codegen.c b/src/codegen.c
index df4c0239..a5c35eb8 100644
--- a/src/codegen.c
+++ b/src/codegen.c
@@ -51,7 +51,7 @@ static void pop_scope(analyze_state *);
 #define register_renamed_symbol(pic, state, slot, lib, id) do {         \
     pic_sym sym, gsym;                                                  \
     sym = pic_intern_cstr(pic, id);                                     \
-    if (! pic_find_rename(pic, lib->senv, sym, &gsym)) {                \
+    if (! pic_find_rename(pic, lib->env, sym, &gsym)) {                \
       pic_error(pic, "internal error! native VM procedure not found");  \
     }                                                                   \
     state->slot = gsym;                                                 \
diff --git a/src/gc.c b/src/gc.c
index 7d285b32..e673f045 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -463,7 +463,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
   case PIC_TT_LIB: {
     struct pic_lib *lib = (struct pic_lib *)obj;
     gc_mark(pic, lib->name);
-    gc_mark_object(pic, (struct pic_object *)lib->senv);
+    gc_mark_object(pic, (struct pic_object *)lib->env);
     break;
   }
   case PIC_TT_VAR: {
diff --git a/src/init.c b/src/init.c
index 56264da7..3bb10991 100644
--- a/src/init.c
+++ b/src/init.c
@@ -62,14 +62,14 @@ pic_init_core(pic_state *pic)
   pic_deflibrary ("(scheme base)") {
 
     /* load core syntaces */
-    pic->lib->senv = pic_null_syntactic_environment(pic);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE, pic->rDEFINE);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG, pic->rSETBANG);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE, pic->rQUOTE);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA, pic->rLAMBDA);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
+    pic->lib->env = pic_null_syntactic_environment(pic);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
 
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
diff --git a/src/lib.c b/src/lib.c
index b12e8c9b..5ac5336a 100644
--- a/src/lib.c
+++ b/src/lib.c
@@ -27,7 +27,7 @@ pic_make_library(pic_state *pic, pic_value name)
   senv = pic_null_syntactic_environment(pic);
 
   lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
-  lib->senv = senv;
+  lib->env = senv;
   lib->name = name;
   xh_init_int(&lib->exports, sizeof(pic_sym));
 
@@ -78,7 +78,7 @@ pic_import(pic_state *pic, pic_value spec)
     printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym)));
 #endif
 
-    pic_put_rename(pic, pic->lib->senv, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
+    pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
   }
 }
 
@@ -87,7 +87,7 @@ pic_export(pic_state *pic, pic_sym sym)
 {
   pic_sym rename;
 
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
   }
 
@@ -103,7 +103,7 @@ pic_export_as(pic_state *pic, pic_sym sym, pic_sym as)
 {
   pic_sym rename;
 
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
   }
 
diff --git a/src/macro.c b/src/macro.c
index d0372540..7711a860 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -445,7 +445,7 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   puts("");
 #endif
 
-  v = macroexpand(pic, expr, pic->lib->senv);
+  v = macroexpand(pic, expr, pic->lib->env);
 
 #if DEBUG
   puts("after expand:");
@@ -528,7 +528,7 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym,
 {
   pic_put_rename(pic, senv, sym, rsym);
 
-  if (pic->lib && pic->lib->senv == senv) {
+  if (pic->lib && pic->lib->env == senv) {
     pic_export(pic, sym);
   }
 }
@@ -540,7 +540,7 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
 
   /* symbol registration */
   sym = pic_intern_cstr(pic, name);
-  rename = pic_add_rename(pic, pic->lib->senv, sym);
+  rename = pic_add_rename(pic, pic->lib->env, sym);
   define_macro(pic, rename, macro, NULL);
 
   /* auto export! */
@@ -591,7 +591,7 @@ pic_macro_macroexpand_1(pic_state *pic)
 
   pic_get_args(pic, "o", &expr);
 
-  val = macroexpand_one(pic, expr, pic->lib->senv);
+  val = macroexpand_one(pic, expr, pic->lib->env);
   if (pic_undef_p(val)) {
     return pic_values2(pic, expr, pic_false_value());
   }
diff --git a/src/vm.c b/src/vm.c
index 8a2430a0..7dc788cc 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -376,7 +376,7 @@ global_ref(pic_state *pic, const char *name)
   pic_sym sym, rename;
 
   sym = pic_intern_cstr(pic, name);
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     return SIZE_MAX;
   }
   if (! (e = xh_get_int(&pic->global_tbl, rename))) {
@@ -398,7 +398,7 @@ global_def(pic_state *pic, const char *name)
   }
 
   /* register to the senv */
-  rename = pic_add_rename(pic, pic->lib->senv, sym);
+  rename = pic_add_rename(pic, pic->lib->env, sym);
 
   /* register to the global table */
   gidx = pic->glen++;

From 720eb94395bc6b3ef94d815a37b360b5f2bb0dd5 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Sun, 20 Jul 2014 17:24:03 +0900
Subject: [PATCH 214/216] separate (picrin test) and import some test macros
 from chibi scheme

---
 piclib/CMakeLists.txt  |   1 +
 piclib/picrin/test.scm | 103 +++++++++++++++++++++++++++++++++++++++++
 t/r7rs-tests.scm       | 102 +---------------------------------------
 3 files changed, 106 insertions(+), 100 deletions(-)
 create mode 100644 piclib/picrin/test.scm

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 50b59f9b..9d81aae3 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -3,6 +3,7 @@ list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/prelude.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
diff --git a/piclib/picrin/test.scm b/piclib/picrin/test.scm
new file mode 100644
index 00000000..f786ba58
--- /dev/null
+++ b/piclib/picrin/test.scm
@@ -0,0 +1,103 @@
+(define-library (picrin test)
+  (import (scheme base)
+          (scheme write)
+          (scheme read)
+          (scheme process-context))
+  (define test-counter 0)
+  (define counter 0)
+  (define failure-counter 0)
+
+  (define fails '())
+
+  (define (print-statistics)
+    (newline)
+    (display "Test Result: ")
+    (write (- counter failure-counter))
+    (display " / ")
+    (write counter)
+    (display " (")
+    (write (* (/ (- counter failure-counter) counter) 100))
+    (display "%)")
+    (display " [PASS/TOTAL]")
+    (display "")
+    (newline)
+    (for-each
+     (lambda (fail)
+       (display fail))
+     fails))
+
+  (define (test-begin . o)
+    (set! test-counter (+ test-counter 1)))
+
+  (define (test-end . o)
+    (set! test-counter (- test-counter 1))
+    (if (= test-counter 0)
+        (print-statistics)))
+
+  (define-syntax test
+    (syntax-rules ()
+      ((test expected expr)
+       (let ((res expr))
+         (display "case ")
+         (write counter)
+         (cond
+          ((equal? res expected)
+           (display " PASS: ")
+           (write 'expr)
+           (display " equals ")
+           (write expected)
+           (display "")
+           (newline)
+           )
+          ((not (equal? res expected))
+           (set! failure-counter (+ failure-counter 1))
+           (let ((out (open-output-string)))
+             (display " FAIL: " out)
+             (write 'expr out)
+             (newline out)
+             (display "   expected " out)
+             (write expected out)
+             (display " but got " out)
+             (write res out)
+             (display "" out)
+             (newline out)
+             (let ((str (get-output-string out)))
+               (set! fails (cons str fails))
+               (display str)))))
+         (set! counter (+ counter 1))))))
+
+  (define-syntax test-values
+    (syntax-rules ()
+      ((_ expect expr)
+       (test-values #f expect expr))
+      ((_ name expect expr)
+       (test name (call-with-values (lambda () expect) (lambda results results))
+             (call-with-values (lambda () expr) (lambda results results))))))
+
+
+  (define (test-failure-count)
+    (length fails))
+
+  (define (test-exit)
+    (exit (zero? (test-failure-count))))
+
+  (define-syntax test-syntax-error
+    (syntax-rules ()
+      ((_) (syntax-error "invalid use of test-syntax-error"))))
+
+  (define-syntax test-numeric-syntax
+    (syntax-rules ()
+      ((test-numeric-syntax str expect strs ...)
+       (let* ((z (read (open-input-string str)))
+              (out (open-output-string))
+              (z-str (begin (write z out) (get-output-string out))))
+         (test expect (values z))
+         (test #t (and (member z-str '(str strs ...)) #t))))))
+
+  ;; (define (test-read-error str)
+  ;;   (test-assert
+  ;;       (guard (exn (else #t))
+  ;;         (read (open-input-string str))
+  ;;         #f)))
+  (export test test-begin test-end test-values test-exit test-syntax-error test-numeric-syntax)
+  )
diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index c0877161..0282062c 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -36,75 +36,14 @@
         (scheme write)
 ;        (scheme eval)
         (scheme process-context)
-        (scheme case-lambda))
+        (scheme case-lambda)
+        (picrin test))
 
 ;; R7RS test suite.  Covers all procedures and syntax in the small
 ;; language except `delete-file'.  Currently assumes full-unicode
 ;; support, the full numeric tower and all standard libraries
 ;; provided.
 
-(define test-counter 0)
-(define counter 0)
-(define failure-counter 0)
-
-(define fails '())
-
-(define (print-statistics)
-  (newline)
-  (display "Test Result: ")
-  (write (- counter failure-counter))
-  (display " / ")
-  (write counter)
-  (display " (")
-  (write (* (/ (- counter failure-counter) counter) 100))
-  (display "%)")
-  (display " [PASS/TOTAL]")
-  (display "")
-  (newline)
-  (for-each
-   (lambda (fail)
-     (display fail))
-   fails))
-
-(define (test-begin . o)
-  (set! test-counter (+ test-counter 1)))
-
-(define (test-end . o)
-  (set! test-counter (- test-counter 1))
-  (if (= test-counter 0)
-      (print-statistics)))
-
-(define-syntax test
-  (syntax-rules ()
-    ((test expected expr)
-     (let ((res expr))
-       (display "case ")
-       (write counter)
-       (cond
-        ((equal? res expected)
-         (display " PASS: ")
-         (write 'expr)
-         (display " equals ")
-         (write expected)
-         (display "")
-         (newline)
-         )
-        ((not (equal? res expected))
-         (set! failure-counter (+ failure-counter 1))
-         (let ((out (open-output-string)))
-           (display " FAIL: " out)
-           (write 'expr out)
-           (newline out)
-           (display "   expected " out)
-           (write expected out)
-           (display " but got " out)
-           (write res out)
-           (display "" out)
-           (newline out)
-           (let ((str (get-output-string out)))
-             (set! fails (cons str fails))
-             (display str)))))
-       (set! counter (+ counter 1))))))
 
 (newline)
 
@@ -2089,12 +2028,6 @@
 (test '(a . c) (read (open-input-string "(a . #;b c)")))
 (test '(a . b) (read (open-input-string "(a . b #;c)")))
 
-;; (define (test-read-error str)
-;;   (test-assert
-;;       (guard (exn (else #t))
-;;         (read (open-input-string str))
-;;         #f)))
-
 ;; (test-read-error "(#;a . b)")
 ;; (test-read-error "(a . #;b)")
 ;; (test-read-error "(a #;. b)")
@@ -2138,37 +2071,6 @@
 
 (test-begin "Numeric syntax")
 
-;; Numeric syntax adapted from Peter Bex's tests.
-;;
-;; These are updated to R7RS, using string ports instead of
-;; string->number, and "error" tests removed because implementations
-;; are free to provide their own numeric extensions.  Currently all
-;; tests are run by default - need to cond-expand and test for
-;; infinities and -0.0.
-
-(define-syntax test-numeric-syntax
-  (syntax-rules ()
-    ((test-numeric-syntax str expect strs ...)
-     (let* ((z (read (open-input-string str)))
-            (out (open-output-string))
-            (z-str (begin (write z out) (get-output-string out))))
-       (test expect (values z))
-       (test #t (and (member z-str '(str strs ...)) #t))))))
-
-;; Each test is of the form:
-;;
-;;   (test-numeric-syntax input-str expected-value expected-write-values ...)
-;;
-;; where the input should be eqv? to the expected-value, and the
-;; written output the same as any of the expected-write-values.  The
-;; form
-;;
-;;   (test-numeric-syntax input-str expected-value)
-;;
-;; is a shorthand for
-;;
-;;   (test-numeric-syntax input-str expected-value (input-str))
-
 ;; Simple
 (test-numeric-syntax "1" 1)
 ;; (test-numeric-syntax "+1" 1 "1")

From 28894dd07a23bb6446d3f12f0afc336bf2a5da21 Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Sun, 20 Jul 2014 21:19:12 +0900
Subject: [PATCH 215/216] remove useless newline

---
 t/r7rs-tests.scm | 2 --
 1 file changed, 2 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 0282062c..1cf0cb0a 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -45,8 +45,6 @@
 ;; provided.
 
 
-(newline)
-
 (test-begin "R7RS")
 
 (test-begin "4.1 Primitive expression types")

From 12fb80b857b4f4201f3724613b10ad9bcd80288a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 21 Jul 2014 16:32:51 +0900
Subject: [PATCH 216/216] allow multiple identifier aliasing

---
 src/macro.c | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/src/macro.c b/src/macro.c
index 7711a860..597eb57f 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -35,12 +35,7 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren
 {
   xh_entry *e;
 
-  if (! pic_interned_p(pic, sym)) {
-    if (rename != NULL) {
-      *rename = sym;
-    }
-    return true;
-  }
+  UNUSED(pic);
 
   if ((e = xh_get_int(&senv->map, sym)) == NULL) {
     return false;
@@ -87,7 +82,12 @@ make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv)
       break;
     senv = senv->up;
   }
-  return pic_gensym(pic, sym);
+  if (! pic_interned_p(pic, sym)) {
+    return sym;
+  }
+  else {
+    return pic_gensym(pic, sym);
+  }
 }
 
 static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);