1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
#!r6rs
;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an
;; MIT-style license. My license is in the file named LICENSE from the original
;; collection this file is distributed with. If this file is redistributed with
;; some other collection, my license must also be included.
;; Taken from Oleg's http://okmij.org/ftp/Scheme/delim-control-n.scm
;; NOTE: Not currently designed for multi-threaded use.
;; Won't work across phases on a multiple-instantiation system.
(library (xitomatl delimited-control)
(export
abort prompt control shift reset prompt0 control0 shift0 reset0)
(import
(rnrs))
(define cells '())
(define (cell-push! x) (set! cells (cons x cells)))
(define (cell-pop!)
(let ((x (car cells)))
(set! cells (cdr cells))
x))
(define-record-type cell (fields cont (mutable mark)))
; Essentially this is the ``return from the function''
(define (abort-top! v) ((cell-cont (cell-pop!)) v))
(define (unwind-till-marked! keep? accum)
(let ((c (if (null? cells)
(error 'unwind-till-marked! "no prompt set")
(car cells)))) ; peek at the top cell
(if (cell-mark c) ; if marked, it's prompt's cell
(begin (unless keep? (cell-mark-set! c #F))
accum)
(begin (set! cells (cdr cells)) ; remove cell from the top of stack
(unwind-till-marked! keep? (cons c accum))))))
(define (make-control shift? keep?)
(lambda (f)
(call/cc
(lambda (k-control)
(let* ((cells-prefix (unwind-till-marked! keep? '()))
(invoke-subcont (lambda (v)
(call/cc
(lambda (k-return)
(cell-push! (make-cell k-return shift?))
(for-each cell-push! cells-prefix)
(k-control v))))))
(abort-top! (f invoke-subcont)))))))
(define (prompt* thunk)
(call/cc
(lambda (outer-k)
(cell-push! (make-cell outer-k #T)) ; it's prompt's cell
(abort-top! (thunk)))))
(define control* (make-control #F #T))
(define (abort v) (control* (lambda (ignore) v)))
(define-syntax prompt
(syntax-rules ()
((_ e) (prompt* (lambda () e)))))
(define-syntax control
(syntax-rules ()
((_ k e) (control* (lambda (k) e)))))
(define-syntax reset
(syntax-rules ()
((_ e) (prompt e))))
(define shift* (make-control #T #T))
(define-syntax shift
(syntax-rules ()
((_ k e) (shift* (lambda (k) e)))))
(define-syntax prompt0
(syntax-rules ()
((_ e) (prompt e))))
(define control0* (make-control #F #F))
(define-syntax control0
(syntax-rules ()
((_ k e) (control0* (lambda (k) e)))))
(define-syntax reset0
(syntax-rules ()
((_ e) (prompt e))))
(define shift0* (make-control #T #F))
(define-syntax shift0
(syntax-rules ()
((_ k e) (shift0* (lambda (k) e)))))
)
|