From 0a0c08500311614d0a4ec2083fb7271c1dfdfb7d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 15 Sep 2014 15:44:57 +0900
Subject: [PATCH] implement parameterize

---
 boot.c | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 58 insertions(+)

diff --git a/boot.c b/boot.c
index 6fa13d94..1dd344e8 100644
--- a/boot.c
+++ b/boot.c
@@ -300,6 +300,34 @@ my $src = <<'EOL';
                             `(,(r 'begin) ,@(cdr clause)))
                        ,(loop (cdr clauses)))))))))))
 
+  (define (dynamic-bind parameters values body)
+    (let* ((old-bindings
+            (current-dynamic-environment))
+           (binding
+            (let ((dict (dictionary)))
+              (for-each
+               (lambda (parameter value)
+                 (dictionary-set! dict parameter (list (parameter value #f))))
+               parameters
+               values)
+              dict))
+           (new-bindings
+            (cons binding old-bindings)))
+      (dynamic-wind
+          (lambda () (current-dynamic-environment new-bindings))
+          body
+          (lambda () (current-dynamic-environment old-bindings)))))
+
+  (define-syntax parameterize
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((formal (cadr form))
+             (body (cddr form)))
+         `(,(r 'dynamic-bind)
+           (list ,@(map car formal))
+           (list ,@(map cadr formal))
+           (,(r 'lambda) () ,@body))))))
+
   (define-syntax letrec-syntax
     (er-macro-transformer
      (lambda (form r c)
@@ -322,6 +350,7 @@ my $src = <<'EOL';
           and or
           cond case else =>
           do when unless
+          parameterize
           let-syntax letrec-syntax
           syntax-error))
 
@@ -668,6 +697,34 @@ const char pic_boot[] =
 "                            `(,(r 'begin) ,@(cdr clause)))\n"
 "                       ,(loop (cdr clauses)))))))))))\n"
 "\n"
+"  (define (dynamic-bind parameters values body)\n"
+"    (let* ((old-bindings\n"
+"            (current-dynamic-environment))\n"
+"           (binding\n"
+"            (let ((dict (dictionary)))\n"
+"              (for-each\n"
+"               (lambda (parameter value)\n"
+"                 (dictionary-set! dict parameter (list (parameter value #f))))\n"
+"               parameters\n"
+"               values)\n"
+"              dict))\n"
+"           (new-bindings\n"
+"            (cons binding old-bindings)))\n"
+"      (dynamic-wind\n"
+"          (lambda () (current-dynamic-environment new-bindings))\n"
+"          body\n"
+"          (lambda () (current-dynamic-environment old-bindings)))))\n"
+"\n"
+"  (define-syntax parameterize\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r compare)\n"
+"       (let ((formal (cadr form))\n"
+"             (body (cddr form)))\n"
+"         `(,(r 'dynamic-bind)\n"
+"           (list ,@(map car formal))\n"
+"           (list ,@(map cadr formal))\n"
+"           (,(r 'lambda) () ,@body))))))\n"
+"\n"
 "  (define-syntax letrec-syntax\n"
 "    (er-macro-transformer\n"
 "     (lambda (form r c)\n"
@@ -690,6 +747,7 @@ const char pic_boot[] =
 "          and or\n"
 "          cond case else =>\n"
 "          do when unless\n"
+"          parameterize\n"
 "          let-syntax letrec-syntax\n"
 "          syntax-error))\n"
 ;