source: project/release/4/continuations/trunk/continuations.scm @ 29411

Last change on this file since 29411 was 29411, checked in by juergen, 6 years ago

some tests rewritten and packaged in second module

File size: 8.2 KB
Line 
1; Author: Juergen Lorenz
2; ju (at) jugilo (dot) de
3;
4; Copyright (c) 2013, 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: Jul 23, 2013
35;
36;;; simplifying Marc Feeley's continuation interface with some additions,
37;;; i.a. by  Matt Might
38
39(module continuations
40  (continuations catch capture graft throw continuation? continuation
41                 goto continuation->procedure)
42
43  (import scheme
44          (rename (only chicken
45                        continuation-capture
46                        continuation-graft
47                        continuation-return
48                        continuation?)
49                  (continuation-capture capture)
50                  (continuation-graft graft)
51                  (continuation-return throw)))
52
53(define-syntax catch
54  (syntax-rules ()
55    ((_ cont xpr . xprs)
56     (capture (lambda (cont) xpr . xprs)))))
57
58(define (continuation->procedure cont)
59  (lambda vals (apply throw cont vals)))
60
61(define (continuation)
62  (capture (lambda (cc) (throw cc cc))))
63
64(define (goto cc) (throw cc cc))
65
66(define (continuations . args)
67  (let ((lst '(catch capture continuation continuation?
68                continuation->procedure goto graft throw)))
69    (if (null? args)
70      lst
71      (case (car args)
72        ((catch)
73         '(macro ()
74             ((_ cont xpr . xprs)
75              #t
76              (capture (lambda (cont) xpr . xprs)))))
77        ((capture)
78         '(procedure (result)
79            ((_ proc)
80             (procedure? proc)
81             "alias for continuation-capture")))
82        ((continuation?)
83         '(procedure (result)
84            ((_ xpr) #t (boolean? result))))
85        ((continuation->procedure)
86         '(procedure (result)
87            ((_ cont)
88             (continuation? cont)
89             (procedure? result))))
90        ((graft)
91         '(procedure (return)
92            ((_ cont thunk)
93             (and (continuation? cont) (procedure? thunk))
94             "alias for continuation-graft")))
95        ((throw)
96         '(procedure (result)
97            ((_ cont . vals)
98             (continuation? cont)
99             "alias for continuation-return")))
100        ((continuation)
101         '(procedure (result)
102            ((_)
103             #t
104             (continuation? result))))
105        ((goto cont)
106         '(procedure (result)
107            (continuation? cont)
108            (continuation? result)))
109        (else lst)))))
110
111) ; end continuations
112
113(module continuations-used
114  (continuations-used make-amb make-threads iterate)
115(import scheme continuations
116        (only chicken when unless error)
117        (only extras format))
118
119;;; iterators
120(define-syntax iterate
121  (syntax-rules ()
122    ((_ var iterator xpr . xprs)
123     (let ((it iterator) (it-cont #f))
124       (let loop ()
125         (let ((cc (continuation)))
126           (if (continuation? cc)
127             ;; first let-pass
128             (if (continuation? it-cont)
129               (throw it-cont (void))
130               (it (lambda (val)
131                   (catch next-cc
132                     (throw cc (cons next-cc val))))))
133             ;; second let-pass (cc is now pair)
134             (let ((next-cont (car cc))
135                   (next-val (cdr cc)))
136               (set! it-cont next-cont)
137               (let ((var next-val)) xpr . xprs)
138               (loop)))))))))
139
140;; amb packaged as a message-passing object
141;; ----------------------------------------
142(define (make-amb)
143  (let ((stack '()))
144    (define (amb-fail)
145      (if (null? stack)
146        (error 'amb-fail "amb-stack exhausted")
147        (begin
148          (let ((choice (car stack)))
149            (set! stack (cdr stack))
150            (goto choice)))))
151    (define (amb-choose . choices)
152      (let ((cc (continuation)))
153        (cond
154          ((null? choices)
155           (amb-fail))
156          ((pair? choices)
157           (let ((choice (car choices)))
158             (set! choices (cdr choices))
159             (set! stack (cons cc stack))
160             choice)))))
161    (define (amb-assert xpr)
162      (if xpr
163        #t
164        (amb-fail)))
165    (lambda (sym)
166      (case sym
167        ((fail) amb-fail)
168        ((choose) amb-choose)
169        ((assert) amb-assert)
170        (else
171          (error 'make-amb
172                 (format #f "message not in ~s: ~s"
173                         '(fail choose assert)
174                         sym)))))))
175
176;; cooperative threads packaged as a message-passing object
177;; -------------------------------------------------------
178(define (make-threads)
179  ;; a queue implemented by two lists giving
180  ;; amortized constant time access to its items
181  (let ((in '()) (out '()))
182    (define (enq! var)
183      (set! in (cons var in)))
184    (define (deq!)
185      (when (null? out)
186        (set! out (reverse in))
187        (set! in '()))
188      (let ((var (car out)))
189        (set! out (cdr out))
190        var))
191    (define threads-halt #f)
192    (define (threads-spawn thunk)
193      (let ((cc (continuation)))
194        (if (continuation? cc)
195          (enq! cc)
196          (begin (thunk) (threads-quit)))))
197    (define (threads-yield)
198      (let ((cc (continuation)))
199        (if (and (continuation? cc)
200                 (not (and (null? in) (null? out))))
201          (let ((next-thread (deq!)))
202            (enq! cc)
203            (throw next-thread 'resume)))))
204    (define (threads-quit)
205      (if (and (null? in) (null? out))
206        (threads-halt)
207        (throw (deq!) 'resume)))
208    (define (threads-start)
209      (let ((cc (continuation)))
210        (when cc;(continuation? cc)
211          (set! threads-halt (lambda () (throw cc #f)))
212          (unless (and (null? in) (null? out))
213            (throw (deq!) 'resume)))))
214    (lambda (sym)
215      (case sym
216        ((halt) threads-halt)
217        ((spawn) threads-spawn)
218        ((yield) threads-yield)
219        ((quit) threads-quit)
220        ((start) threads-start)
221        (else
222          (error 'make-threads
223                 (format #f "message not in ~s: ~s"
224                         '(spawn yield quit start halt)
225                         sym)))))))
226
227(define (continuations-used . args)
228  (let ((lst '(iterate make-amb make-threads)))
229    (if (null? args)
230      lst
231      (case (car args)
232        ((iterate)
233         '(macro ()
234             ((_ var iterator xpr . xprs)
235              (and (procedure? iterator)
236                   "(iterator container) -> (lambda (yield) ...)")
237              "applies yield to every var in contqainer")))
238        ((make-amb)
239         '(procedure (result)
240            ((_)
241             #t
242             (and "ambiguous choice"
243                  (procedure? result)
244                  "result accepts symbols choose fail and assert"))))
245        ((make-threads)
246         '(procedure (result)
247            ((_)
248             #t
249             (and "cooperative threads"
250                  (procedure? result)
251                  "result accepts symbols halt, spawn, yield, quit and start"))))
252        (else lst)))))
253
254) ; module continuations-used
Note: See TracBrowser for help on using the repository browser.