From a1941ff08a60c79452725695a8f4959eac98370a Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sat, 26 Dec 2009 00:50:45 +0900
Subject: [PATCH] somewhat reluctantly adding dynamic-wind

---
 lib/init.scm         | 46 ++++++++++++++++++++++++++++++++++++++++++++
 opcodes.c            |  2 +-
 tests/r5rs-tests.scm | 23 ++++++++++++++++++++++
 3 files changed, 70 insertions(+), 1 deletion(-)

diff --git a/lib/init.scm b/lib/init.scm
index ff7b4ece..75217d71 100644
--- a/lib/init.scm
+++ b/lib/init.scm
@@ -89,6 +89,12 @@
 (define (every pred ls)
   (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t))
 
+(define (delq x ls)
+  (if (pair? ls)
+      (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls))))
+      '()))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; syntax
 
 (define sc-macro-transformer
@@ -284,6 +290,9 @@
    (lambda (expr rename compare)
      `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; promises
+
 (define (make-promise thunk)
   (lambda ()
     (let ((computed? #f) (result #f))
@@ -295,6 +304,9 @@
 
 (define (force x) (if (procedure? x) (x) x))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exceptions
+
 (define (error msg . args)
   (raise (make-exception 'user msg args #f #f)))
 
@@ -305,6 +317,9 @@
       (current-exception-handler orig-handler)
       res)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; library functions
+
 ;; booleans
 
 (define (not x) (if x #f #t))
@@ -552,6 +567,7 @@
       (current-output-port old-out)
       res)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; values
 
 (define *values-tag* (list 'values))
@@ -567,6 +583,32 @@
         (apply consumer (cdr res))
         (consumer res))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; dynamic-wind
+
+(define *dk* (list #f))
+
+(define (dynamic-wind before thunk after)
+  (let ((dk *dk*))
+    (set-dk! (cons (cons before after) dk))
+    (let ((res (thunk))) (set-dk! dk) res)))
+
+(define (set-dk! dk)
+  (if (not (eq? dk *dk*))
+      (begin
+        (set-dk! (cdr dk))
+        (let ((before (car (car dk))) (dk dk))
+          (set-car! *dk* (cons (cdr (car dk)) before))
+          (set-cdr! *dk* dk)
+          (set-car! dk #f)
+          (set-cdr! dk '())
+          (set! *dk* dk)
+          (before)))))
+
+(define (call-with-current-continuation proc)
+  (let ((dk *dk*))
+    (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x)))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; syntax-rules
 
@@ -748,6 +790,9 @@
                 (list (list _error "no expansion for"
                             (list (rename 'strip-syntactic-closures) _expr)))))))))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; modules
+
 (define *config-env* #f)
 
 (define-syntax import
@@ -771,6 +816,7 @@
                          res))
                (error "couldn't find module" (car ls))))))))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; SRFI-0
 
 (define-syntax cond-expand
diff --git a/opcodes.c b/opcodes.c
index 470c694a..5d3a36cc 100644
--- a/opcodes.c
+++ b/opcodes.c
@@ -63,7 +63,7 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, 0, 0, 0, "opcode?", sexp_make
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0),
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL),
-_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL),
 _OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL),
 _OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL),
diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm
index 1a2091d6..cf6bc8ab 100644
--- a/tests/r5rs-tests.scm
+++ b/tests/r5rs-tests.scm
@@ -436,6 +436,29 @@
 (test '(2 3)
     ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y))))))
 
+(test '(a b c)
+    (let* ((path '())
+           (add (lambda (s) (set! path (cons s path)))))
+      (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c)))
+      (reverse path)))
+
+(test '(connect talk1 disconnect connect talk2 disconnect)
+    (let ((path '())
+          (c #f))
+      (let ((add (lambda (s)
+                   (set! path (cons s path)))))
+        (dynamic-wind
+            (lambda () (add 'connect))
+            (lambda ()
+              (add (call-with-current-continuation
+                    (lambda (c0)
+                      (set! c c0)
+                      'talk1))))
+            (lambda () (add 'disconnect)))
+        (if (< (length path) 4)
+            (c 'talk2)
+            (reverse path)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (test-report)