source: project/release/5/continuations/trunk/continuations.scm @ 37408

Last change on this file since 37408 was 37408, checked in by juergen, 21 months ago

continuations 1.0

File size: 5.2 KB
Line 
1; Author: Juergen Lorenz
2; ju (at) jugilo (dot) de
3;
4; Copyright (c) 2013-2019, Juergen Lorenz
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions are
9; met:
10;
11; Redistributions of source code must retain the above copyright
12; notice, this list of conditions and the following disclaimer.
13;
14; Redistributions in binary form must reproduce the above copyright
15; notice, this list of conditions and the following disclaimer in the
16; documentation and/or other materials provided with the distribution.
17;
18; Neither the name of the author nor the names of its contributors may be
19; used to endorse or promote products derived from this software without
20; specific prior written permission.
21;
22; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
23; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
24; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
25; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
26; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
27; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
28; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
29; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
30; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
31; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
32; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33;
34; Last update: Mar 17, 2019
35;
36;;; simplifying Marc Feeley's continuation interface with some additions,
37;;; i.a. by  Matt Might
38
39(module continuations (
40  continuations
41  call
42  capture
43  catch
44  continuation
45  continuation?
46  continuation->procedure
47  ;current
48  escape-procedure
49  escape-procedure?
50  goto
51  graft
52  throw
53  )
54
55  (import scheme
56          (only (chicken base)
57                define-values
58                case-lambda
59                print
60                gensym)
61          (rename (only (chicken continuation)
62                        continuation-capture
63                        continuation-graft
64                        continuation-return
65                        continuation?)
66                  (continuation-capture capture)
67                  (continuation-graft graft)
68                  (continuation-return throw))
69          (only (chicken memory representation)
70                extend-procedure
71                procedure-data
72                extended-procedure?))
73
74(define-syntax catch
75  (syntax-rules ()
76    ((_ cont xpr . xprs)
77     (capture (lambda (cont) xpr . xprs)))))
78
79(define (continuation->procedure cont)
80  (lambda vals (apply throw cont vals)))
81
82(define (call receiver)
83  (capture (lambda (cc)
84             (receiver (continuation->procedure cc)))))
85
86;(define (current)
87;  (capture (lambda (cc) (throw cc cc))))
88
89(define (continuation)
90  (capture (lambda (cc) (throw cc cc))))
91
92(define (goto cc) (throw cc cc))
93
94;;; Matt Wright's functional interface
95(define-values (escape-procedure escape-procedure?)
96  (let ((type (gensym 'escape-procedure)))
97    (values
98      (lambda ()
99        (call-with-current-continuation
100          (lambda (cc)
101                   (cc (extend-procedure cc type)))))
102      (lambda (xpr)
103        (and (extended-procedure? xpr)
104             (eq? (procedure-data xpr) type)))
105      )))
106
107(define continuations
108  (let ((alist '(
109          (catch
110            macro:
111            (catch cc xpr ....)
112            "catches cc as a continuation"
113            "and evaluates xpr .... in this context")
114          (capture
115            procedure:
116            (capture receiver)
117             "alias for continuation-capture")
118          (continuation?
119            procedure:
120            (continuation xpr)
121            "tests if xpr is a continuation")
122          (continuation->procedure
123            procedure:
124            (continuation->procedure cc)
125            "transforms a continuation into a procedure")
126          (call
127            procedure:
128            (call receiver)
129            "the same as call/cc, but implemented via capture")
130          ;(current
131          ;  procedure:
132          ;  (current)
133          ;  "captures the current continuation as a continuation")
134          (graft
135            procedure:
136            (graft cc thunk)
137            "alias for continuation-graft")
138          (goto
139            procedure:
140            (goto cc)
141            "jumps to the continuation cc")
142          (throw
143            procedure:
144            (throw cc val ...)
145            "alias for continuation-return")
146          (escape-procedure
147            procedure:
148            (escape-procedure)
149            "captures the current continuation as an escape procedure")
150          (escape-procedure?
151            procedure:
152            (escape-procedure? xpr)
153            "checks if xpr is an escape procedure")
154          (continuations
155            procedure:
156            (continuations sym ..)
157            "documentation procedure")
158          )))
159    (case-lambda
160      (() (map car alist))
161      ((sym)
162       (let ((result (assq sym alist)))
163         (if result
164           (for-each print result)
165           (begin
166             (print "choose one of "
167                    (map car alist)))))))))
168
169) ; end continuations
170
Note: See TracBrowser for help on using the repository browser.