summaryrefslogtreecommitdiffstats
path: root/dynwind.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /dynwind.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'dynwind.scm')
-rw-r--r--dynwind.scm74
1 files changed, 74 insertions, 0 deletions
diff --git a/dynwind.scm b/dynwind.scm
new file mode 100644
index 0000000..9212422
--- /dev/null
+++ b/dynwind.scm
@@ -0,0 +1,74 @@
+; "dynwind.scm", wind-unwind-protect for Scheme
+; Copyright (c) 1992, 1993 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;This facility is a generalization of Common Lisp `unwind-protect',
+;designed to take into account the fact that continuations produced by
+;CALL-WITH-CURRENT-CONTINUATION may be reentered.
+
+; (dynamic-wind <thunk1> <thunk2> <thunk3>) procedure
+
+;The arguments <thunk1>, <thunk2>, and <thunk3> must all be procedures
+;of no arguments (thunks).
+
+;DYNAMIC-WIND calls <thunk1>, <thunk2>, and then <thunk3>. The value
+;returned by <thunk2> is returned as the result of DYNAMIC-WIND.
+;<thunk3> is also called just before control leaves the dynamic
+;context of <thunk2> by calling a continuation created outside that
+;context. Furthermore, <thunk1> is called before reentering the
+;dynamic context of <thunk2> by calling a continuation created inside
+;that context. (Control is inside the context of <thunk2> if <thunk2>
+;is on the current return stack).
+
+;;;WARNING: This code has no provision for dealing with errors or
+;;;interrupts. If an error or interrupt occurs while using
+;;;dynamic-wind, the dynamic environment will be that in effect at the
+;;;time of the error or interrupt.
+
+(define dynamic:winds '())
+
+(define (dynamic-wind <thunk1> <thunk2> <thunk3>)
+ (<thunk1>)
+ (set! dynamic:winds (cons (cons <thunk1> <thunk3>) dynamic:winds))
+ (let ((ans (<thunk2>)))
+ (set! dynamic:winds (cdr dynamic:winds))
+ (<thunk3>)
+ ans))
+
+(define call-with-current-continuation
+ (let ((oldcc call-with-current-continuation))
+ (lambda (proc)
+ (let ((winds dynamic:winds))
+ (oldcc
+ (lambda (cont)
+ (proc (lambda (c2)
+ (dynamic:do-winds winds (- (length dynamic:winds)
+ (length winds)))
+ (cont c2)))))))))
+
+(define (dynamic:do-winds to delta)
+ (cond ((eq? dynamic:winds to))
+ ((negative? delta)
+ (dynamic:do-winds (cdr to) (+ 1 delta))
+ ((caar to))
+ (set! dynamic:winds to))
+ (else
+ (let ((from (cdar dynamic:winds)))
+ (set! dynamic:winds (cdr dynamic:winds))
+ (from)
+ (dynamic:do-winds to (+ -1 delta))))))