Commit | Line | Data |
---|---|---|
9b2a2a39 AW |
1 | ;;; Beyond call/cc |
2 | ||
18e444b4 | 3 | ;; Copyright (C) 2010, 2011 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) | |
18e444b4 | 24 | #:export (% abort shift reset shift* reset*)) |
9b2a2a39 | 25 | |
8fc43b12 AW |
26 | (define (abort . args) |
27 | (apply abort-to-prompt (default-prompt-tag) args)) | |
9b2a2a39 | 28 | |
747022e4 AW |
29 | (define-syntax % |
30 | (syntax-rules () | |
32ce4058 AW |
31 | ((_ expr) |
32 | (call-with-prompt (default-prompt-tag) | |
33 | (lambda () expr) | |
34 | default-prompt-handler)) | |
747022e4 | 35 | ((_ expr handler) |
8fc43b12 AW |
36 | (call-with-prompt (default-prompt-tag) |
37 | (lambda () expr) | |
38 | handler)) | |
c8df9973 | 39 | ((_ tag expr handler) |
8fc43b12 AW |
40 | (call-with-prompt tag |
41 | (lambda () expr) | |
42 | handler)))) | |
32ce4058 AW |
43 | |
44 | ;; Each prompt tag has a type -- an expected set of arguments, and an unwritten | |
45 | ;; contract of what its handler will do on an abort. In the case of the default | |
46 | ;; prompt tag, we could choose to return values, exit nonlocally, or punt to the | |
47 | ;; user. | |
48 | ;; | |
49 | ;; We choose the latter, by requiring that the user return one value, a | |
50 | ;; procedure, to an abort to the prompt tag. That argument is then invoked with | |
51 | ;; the continuation as an argument, within a reinstated default prompt. In this | |
52 | ;; way the return value(s) from a default prompt are under the user's control. | |
53 | (define (default-prompt-handler k proc) | |
54 | (% (default-prompt-tag) | |
55 | (proc k) | |
56 | default-prompt-handler)) | |
18e444b4 AW |
57 | |
58 | ;; Kindly provided by Wolfgang J Moeller <wjm@heenes.com>, modelled | |
59 | ;; after the ones by Oleg Kiselyov in | |
60 | ;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the | |
61 | ;; public domain, as noted at the top of http://okmij.org/ftp/. | |
62 | ;; | |
0c65f52c AW |
63 | (define-syntax-rule (reset . body) |
64 | (call-with-prompt (default-prompt-tag) | |
65 | (lambda () . body) | |
66 | (lambda (cont f) (f cont)))) | |
18e444b4 | 67 | |
0c65f52c AW |
68 | (define-syntax-rule (shift var . body) |
69 | (abort-to-prompt (default-prompt-tag) | |
70 | (lambda (cont) | |
71 | ((lambda (var) (reset . body)) | |
72 | (lambda vals (reset (apply cont vals))))))) | |
18e444b4 AW |
73 | |
74 | (define (reset* thunk) | |
75 | (reset (thunk))) | |
76 | ||
77 | (define (shift* fc) | |
78 | (shift c (fc c))) |