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 , 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))))))