From 34701f6df522f0a29e163841860b064f12ac9646 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= <marc@nieper-wisskirchen.de>
Date: Tue, 1 Aug 2017 18:37:38 +0200
Subject: [PATCH] Implement SRFI 139

---
 lib/srfi/139.scm      | 29 ++++++++++++++++++++++++
 lib/srfi/139.sld      |  6 +++++
 lib/srfi/139/test.sld | 52 +++++++++++++++++++++++++++++++++++++++++++
 tests/lib-tests.scm   |  2 ++
 4 files changed, 89 insertions(+)
 create mode 100644 lib/srfi/139.scm
 create mode 100644 lib/srfi/139.sld
 create mode 100644 lib/srfi/139/test.sld

diff --git a/lib/srfi/139.scm b/lib/srfi/139.scm
new file mode 100644
index 00000000..a9e317e3
--- /dev/null
+++ b/lib/srfi/139.scm
@@ -0,0 +1,29 @@
+(define-syntax out
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (for-each set-cdr! (car (cddr expr)) (cadr (cddr expr)))
+     (car (cdr expr)))))
+
+(define-syntax syntax-parameterize
+  (lambda (expr use-env mac-env)
+    (let* ((_let (make-syntactic-closure mac-env '() 'let))
+	   (_set! (make-syntactic-closure mac-env '() 'set!))
+	   (_out (make-syntactic-closure mac-env '() 'out))
+	   (_tmp (make-syntactic-closure mac-env '() 'tmp))
+	   (bindings (cadr expr))
+	   (body (cddr expr))
+	   (keywords (map car bindings))
+	   (transformers (map cadr bindings))
+	   (cells
+	    (map (lambda (keyword)
+		   (env-cell use-env keyword))
+		 keywords))
+	   (old (map cdr cells))
+	   (new (map (lambda (transformer)
+		       (make-macro (eval (make-syntactic-closure use-env '() transformer))
+				   use-env))
+		     transformers)))
+      (for-each set-cdr! cells new)
+      `(,_let ((,_tmp #f))
+         (,_set! ,_tmp (,_let () ,@body))
+         (,_out ,_tmp ,cells ,old)))))
diff --git a/lib/srfi/139.sld b/lib/srfi/139.sld
new file mode 100644
index 00000000..09ef4cdd
--- /dev/null
+++ b/lib/srfi/139.sld
@@ -0,0 +1,6 @@
+(define-library (srfi 139)
+  (export (rename define-syntax define-syntax-parameter)
+	  syntax-parameterize)
+  (import (chibi)
+	  (chibi ast))
+  (include "139.scm"))
diff --git a/lib/srfi/139/test.sld b/lib/srfi/139/test.sld
new file mode 100644
index 00000000..fb5d8df9
--- /dev/null
+++ b/lib/srfi/139/test.sld
@@ -0,0 +1,52 @@
+(define-library (srfi 139 test)
+  (export run-tests)
+  (import (scheme base)
+          (chibi test)
+          (srfi 139))
+  (begin
+    (define-syntax-parameter abort
+      (syntax-rules ()
+	((_ . _)
+	 (syntax-error "abort used outside of a loop"))))
+    
+    (define-syntax-parameter foo
+      (syntax-rules ()
+	((foo) 'old)))
+    
+    (define-syntax forever
+      (syntax-rules ()
+	((forever body1 body2 ...)
+	 (call-with-current-continuation
+	  (lambda (escape) 
+	    (syntax-parameterize
+		((abort
+		  (syntax-rules ()
+		    ((abort value (... ...))
+		     (escape value (... ...))))))
+	      (let loop ()
+		body1 body2 ... (loop))))))))
+
+    (define (run-tests)
+      (test-begin "srfi-139: syntax parameters")
+
+      (test (list 'old 'new)
+	    (let ((new
+		   (syntax-parameterize
+		       ((foo (syntax-rules ()
+			       ((foo) 'new))))
+		     (foo))))
+	      (list (foo) new)))
+
+      
+      (test 10
+	    (let ((i 0))
+	      (forever
+	       (set! i (+ 1 i))
+	       (when (= i 10)
+		 (abort)))
+	      i))
+
+
+      
+
+      (test-end))))
diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm
index 14222456..c8aa2b2a 100644
--- a/tests/lib-tests.scm
+++ b/tests/lib-tests.scm
@@ -18,6 +18,7 @@
         (rename (srfi 130 test) (run-tests run-srfi-130-tests))
         (rename (srfi 132 test) (run-tests run-srfi-132-tests))
         (rename (srfi 133 test) (run-tests run-srfi-133-tests))
+	(rename (srfi 139 test) (run-tests run-srfi-139-tests))
         (rename (srfi 142 test) (run-tests run-srfi-142-tests))
         (rename (chibi base64-test) (run-tests run-base64-tests))
         (rename (chibi crypto md5-test) (run-tests run-md5-tests))
@@ -67,6 +68,7 @@
 (run-srfi-130-tests)
 (run-srfi-132-tests)
 (run-srfi-133-tests)
+(run-srfi-139-tests)
 (run-srfi-142-tests)
 (run-base64-tests)
 (run-doc-tests)