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 01/10] 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 02/10] 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 03/10] 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 04/10] 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 05/10] 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 06/10] 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 07/10] 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 08/10] 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 09/10] 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 10/10] 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))