Commit | Line | Data |
---|---|---|
9b2a2a39 AW |
1 | ;;; Beyond call/cc |
2 | ||
55e26a49 | 3 | ;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. |
9b2a2a39 AW |
4 | |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; Code: | |
20 | ||
21 | (define-module (ice-9 control) | |
8fc43b12 AW |
22 | #:re-export (call-with-prompt abort-to-prompt |
23 | default-prompt-tag make-prompt-tag) | |
55e26a49 LC |
24 | #:export (% abort shift reset shift* reset* |
25 | call-with-escape-continuation call/ec | |
26 | let-escape-continuation let/ec)) | |
9b2a2a39 | 27 | |
8fc43b12 AW |
28 | (define (abort . args) |
29 | (apply abort-to-prompt (default-prompt-tag) args)) | |
9b2a2a39 | 30 | |
747022e4 AW |
31 | (define-syntax % |
32 | (syntax-rules () | |
32ce4058 AW |
33 | ((_ expr) |
34 | (call-with-prompt (default-prompt-tag) | |
35 | (lambda () expr) | |
36 | default-prompt-handler)) | |
747022e4 | 37 | ((_ expr handler) |
8fc43b12 AW |
38 | (call-with-prompt (default-prompt-tag) |
39 | (lambda () expr) | |
40 | handler)) | |
c8df9973 | 41 | ((_ tag expr handler) |
8fc43b12 AW |
42 | (call-with-prompt tag |
43 | (lambda () expr) | |
44 | handler)))) | |
32ce4058 AW |
45 | |
46 | ;; Each prompt tag has a type -- an expected set of arguments, and an unwritten | |
47 | ;; contract of what its handler will do on an abort. In the case of the default | |
48 | ;; prompt tag, we could choose to return values, exit nonlocally, or punt to the | |
49 | ;; user. | |
50 | ;; | |
51 | ;; We choose the latter, by requiring that the user return one value, a | |
52 | ;; procedure, to an abort to the prompt tag. That argument is then invoked with | |
53 | ;; the continuation as an argument, within a reinstated default prompt. In this | |
54 | ;; way the return value(s) from a default prompt are under the user's control. | |
55 | (define (default-prompt-handler k proc) | |
56 | (% (default-prompt-tag) | |
57 | (proc k) | |
58 | default-prompt-handler)) | |
18e444b4 AW |
59 | |
60 | ;; Kindly provided by Wolfgang J Moeller <wjm@heenes.com>, modelled | |
61 | ;; after the ones by Oleg Kiselyov in | |
62 | ;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the | |
63 | ;; public domain, as noted at the top of http://okmij.org/ftp/. | |
64 | ;; | |
0c65f52c AW |
65 | (define-syntax-rule (reset . body) |
66 | (call-with-prompt (default-prompt-tag) | |
67 | (lambda () . body) | |
68 | (lambda (cont f) (f cont)))) | |
18e444b4 | 69 | |
0c65f52c AW |
70 | (define-syntax-rule (shift var . body) |
71 | (abort-to-prompt (default-prompt-tag) | |
72 | (lambda (cont) | |
73 | ((lambda (var) (reset . body)) | |
74 | (lambda vals (reset (apply cont vals))))))) | |
18e444b4 AW |
75 | |
76 | (define (reset* thunk) | |
77 | (reset (thunk))) | |
78 | ||
79 | (define (shift* fc) | |
80 | (shift c (fc c))) | |
55e26a49 LC |
81 | |
82 | (define (call-with-escape-continuation proc) | |
83 | "Call PROC with an escape continuation." | |
84 | (let ((tag (list 'call/ec))) | |
85 | (call-with-prompt tag | |
86 | (lambda () | |
87 | (proc (lambda args | |
88 | (apply abort-to-prompt tag args)))) | |
89 | (lambda (_ . args) | |
90 | (apply values args))))) | |
91 | ||
92 | (define call/ec call-with-escape-continuation) | |
93 | ||
94 | (define-syntax-rule (let-escape-continuation k body ...) | |
95 | "Bind K to an escape continuation within the lexical extent of BODY." | |
96 | (let ((tag (list 'let/ec))) | |
97 | (call-with-prompt tag | |
98 | (lambda () | |
99 | (let ((k (lambda args | |
100 | (apply abort-to-prompt tag args)))) | |
101 | body ...)) | |
102 | (lambda (_ . results) | |
103 | (apply values results))))) | |
104 | ||
105 | (define-syntax-rule (let/ec k body ...) | |
106 | (let-escape-continuation k body ...)) |