add reset and shift

* module/ice-9/control.scm (reset, shift): Add implementations of these
  operators from Wolfgang J Moeller, derived from implementations by
  Oleg Kiselyov.
  (reset*, shift*): Procedural variants.

* test-suite/tests/control.test ("shift and reset"): Add tests,
  originally from Oleg Kiselyov.

2 files changed, 66 insertions, 2 deletions

diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm
index dbee61e25..908e0e938 100644
--- a/module/ice-9/control.scm
+++ b/module/ice-9/control.scm
@@ -1,6 +1,6 @@
 ;;; Beyond call/cc
 
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -21,7 +21,7 @@
 (define-module (ice-9 control)
   #:re-export (call-with-prompt abort-to-prompt
                default-prompt-tag make-prompt-tag)
-  #:export (% abort))
+  #:export (% abort shift reset shift* reset*))
 
 (define (abort . args)
   (apply abort-to-prompt (default-prompt-tag) args))
@@ -54,3 +54,29 @@
   (% (default-prompt-tag)
      (proc k)
      default-prompt-handler))
+
+;; Kindly provided by Wolfgang J Moeller <wjm@heenes.com>, modelled
+;; after the ones by Oleg Kiselyov in
+;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
+;; public domain, as noted at the top of http://okmij.org/ftp/.
+;; 
+(define-syntax reset
+  (syntax-rules ()
+    ((_ . body)
+     (call-with-prompt (default-prompt-tag)
+                       (lambda () . body)
+                       (lambda (cont f) (f cont))))))
+
+(define-syntax shift
+  (syntax-rules ()
+    ((_ var . body)
+     (abort-to-prompt (default-prompt-tag)
+                      (lambda (cont)
+                        ((lambda (var) (reset . body))
+                         (lambda vals (reset (apply cont vals)))))))))
+
+(define (reset* thunk)
+  (reset (thunk)))
+
+(define (shift* fc)
+  (shift c (fc c)))
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 6f1804a3f..1c30b9c07 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -350,3 +350,41 @@
           (and (eq? key 'foo)
                (eq? vm new-vm)
                (eq? (the-vm) prev-vm)))))))
+
+;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
+;; http://okmij.org/ftp/Scheme/delim-control-n.scm.  Public domain.
+;;
+(with-test-prefix "shift and reset"
+  (pass-if (equal?
+            117
+            (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))))
+
+  (pass-if (equal?
+            60
+            (* 10 (reset (* 2 (shift g (* 5 (shift f (+ (f 1) 1)))))))))
+
+  (pass-if (equal?
+            121
+            (let ((f (lambda (x) (shift k (k (k x))))))
+              (+ 1 (reset (+ 10 (f 100)))))))
+
+  (pass-if (equal?
+            'a
+            (car (reset
+                  (let ((x (shift f
+                                  (shift f1 (f1 (cons 'a (f '())))))))
+                    (shift g x))))))
+  
+  ;; Example by Olivier Danvy
+  (pass-if (equal?
+            '(1 2 3 4 5)
+            (let ()
+              (define (traverse xs)
+                (define (visit xs)
+                  (if (null? xs)
+                      '()
+                      (visit (shift*
+                              (lambda (k)
+                                (cons (car xs) (k (cdr xs))))))))
+                (reset* (lambda () (visit xs))))
+              (traverse '(1 2 3 4 5))))))