diff --git a/scheme/httpd/surflets/shift-reset.scm b/scheme/httpd/surflets/shift-reset.scm new file mode 100644 index 0000000..3394574 --- /dev/null +++ b/scheme/httpd/surflets/shift-reset.scm @@ -0,0 +1,164 @@ +; no copyright notice +; out from the scsh package: scheme/misc/shift-reset.scm +; with the mentioned modifications + +; ,open signals escapes + +; Changes by Andreas Bernauer: +; make *META-CONTINUATION* thread-local +; +; ,open thread-cells + +; Changes by jar: +; Added Uses of Scheme 48's WITH-CONTINUATION primitive, so that unreachable +; continuations can be reclaimed by the GC. +; +; Renamed reset-thunk -> *reset +; call/ct -> *shift +; +; Note: the meta-continuation ought to be thread-specific. +; Alternatively, the threads package could be defined in terms of +; shift and reset. This would have the advantage of making the threads +; package itself re-entrant. It would be nice to rehabilitate the +; runnable-threads queue, currently a piece of global state, as local +; to a particular invocation of WITH-MULTITASKING. + +;Date: Wed, 29 Dec 1993 13:54:52 +0100 +;From: Olivier Danvy +;To: jar@martigny.ai.mit.edu +;Subject: little Christmas gift +;Reply-To: danvy@daimi.aau.dk +; +;Hi again: +; +;Here is a contribution for the Scheme48 library: the shift and reset +;operators from "Abstracting Control" (LFP90) and "Representing Control" +;(MSCS92). In his POPL94 paper, Andrzej Filinski observed that since the +;meta-continuation is single-threaded, it can be globalized in a +;register. Andrzej has programmed this both in SML and in Scheme. I +;only have prettified the Scheme definition a wee bit. + +(define-syntax reset + (syntax-rules () + ((_ ?e) (*reset (lambda () ?e))))) + +(define-syntax shift + (syntax-rules () + ((_ ?k ?e) (*shift (lambda (?k) ?e))))) + +(define *meta-continuation* + (make-thread-cell + (lambda (v) + (error "You forgot the top-level reset...")))) + +(define *abort + (lambda (thunk) + (with-continuation null-continuation ;JAR hack + (lambda () + (let ((val (thunk))) + ((thread-cell-ref *meta-continuation*) val)))))) + +(define null-continuation #f) + +(define *reset + (lambda (thunk) + (let ((mc (thread-cell-ref *meta-continuation*))) + (call-with-current-continuation + (lambda (k) + (begin + (thread-cell-set! + *meta-continuation* + (lambda (v) + (thread-cell-set! *meta-continuation* mc) + (k v))) + (*abort thunk))))))) + +(define *shift + (lambda (f) + (call-with-current-continuation + (lambda (k) + (*abort (lambda () + (f (lambda (v) + (reset (k v)))))))))) + +;---------- +; +;Reminder: reset specifies a control delimiter. shift grabs the current +;continuation up to the current control delimiter, and reifies it as a +;composable procedure. If the procedure is not used, shift has the +;effect of aborting up to the current control delimiter. +; +;Examples: +; +;(+ 10 (reset (+ 2 3))) +;--> +;15 +; +;(+ 10 (reset (+ 2 (shift k 3)))) +;--> +;13 +; +;(+ 10 (reset (+ 2 (shift k (k 3))))) +;--> +;15 +; +;(+ 10 (reset (+ 2 (shift k (+ 100 (k 3)))))) +;--> +;115 +; +;(+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))) +;--> +;117 +; +; +;Other reminder: shift and reset are weaker than Matthias's control and +;prompt, in that they can be CPS-transformed. +; +;Have a happy holiday, +; +;-- Olivier +; +;PS: This definition is not unlike David Espinoza's implementation of monadic +;effects, ie, it has no interpretive or translation overhead. + + + +; JAR's notes: +; +; ; CWCC defined in terms of SHIFT +; +; (define cwcc +; (lambda (p) +; (shift k (k (p (lambda (x) +; (shift k1 (k x)))))))) +; +; ; Monads from shift and reset (from Filinski, POPL '94) +; +; (define (reflect meaning) +; (shift k (extend k meaning))) +; +; (define (reify thunk) +; (reset (eta (thunk)))) +; +; Example: nondeterminism monad. +; +; > (define (eta x) (list x)) +; > (define (extend f l) (apply append (map f l))) +; > +; > (define-syntax amb +; (syntax-rules () ((amb ?x ?y) (*amb (lambda () ?x) (lambda () ?y))))) +; +; > (define (*amb t1 t2) +; (reflect (append (reify t1) (reify t2)))) +; > +; > (reify (lambda () (amb 1 2))) +; '(1 2) +; > (reify (lambda () (+ (amb 1 2) 3))) +; '(4 5) +; > +; > (define cwcc call-with-current-continuation) +; > (reify (lambda () +; (+ 1 (cwcc (lambda (k) +; (* 10 (amb 3 (k 4)))))))) +; '(31 51) +; >