d32ff4b7b3e7d7b658683eacef19a1f7e62610d3
[software/python-on-guile.git] / modules / language / python / yield.scm
1 (define-module (language python yield)
2 #:use-module (oop pf-objects)
3 #:use-module (language python exceptions)
4 #:use-module (oop goops)
5 #:use-module (ice-9 control)
6 #:use-module (ice-9 match)
7 #:replace (send)
8 #:export (<yield>
9 in-yield define-generator
10 make-generator
11 sendException sendClose))
12
13 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
14
15 (define in-yield (make-fluid #f))
16
17 (define-syntax-parameter YIELD (lambda (x) #f))
18
19 (define-syntax yield
20 (lambda (x)
21 (syntax-case x ()
22 ((_ x ...)
23 #'(begin
24 (fluid-set! in-yield #t)
25 ((abort-to-prompt YIELD x ...))))
26 (x
27 #'(lambda x
28 (fluid-set! in-yield #t)
29 ((apply abort-to-prompt YIELD x)))))))
30
31 (define-syntax make-generator
32 (syntax-rules ()
33 ((_ (args ...) closure)
34 (lambda (args ...)
35 (let ()
36 (define obj (make <yield>))
37 (define ab (make-prompt-tag))
38 (syntax-parameterize ((YIELD (lambda x #'ab)))
39 (slot-set! obj 'k #f)
40 (slot-set! obj 'closed #f)
41 (slot-set! obj 's
42 (lambda ()
43 (call-with-prompt
44 ab
45 (lambda ()
46 (closure yield args ...)
47 (slot-set! obj 'closed #t)
48 (throw StopIteration))
49 (letrec ((lam
50 (lambda (k . l)
51 (fluid-set! in-yield #f)
52 (slot-set! obj 'k
53 (lambda (a)
54 (call-with-prompt
55 ab
56 (lambda ()
57 (k a))
58 lam)))
59 (apply values l))))
60 lam))))
61 obj))))
62
63 ((_ (args ... . ***) closure)
64 (lambda (args ... . ***)
65 (let ()
66 (define obj (make <yield>))
67 (define ab (make-prompt-tag))
68 (syntax-parameterize ((YIELD (lambda x #'ab)))
69 (slot-set! obj 'k #f)
70 (slot-set! obj 'closed #f)
71 (slot-set! obj 's
72 (lambda ()
73 (call-with-prompt
74 ab
75 (lambda ()
76 (apply closure yield args ... ***)
77 (slot-set! obj 'closed #t)
78 (throw StopIteration))
79 (letrec ((lam
80 (lambda (k . l)
81 (fluid-set! in-yield #f)
82 (slot-set! obj 'k
83 (lambda (a)
84 (call-with-prompt
85 ab
86 (lambda ()
87 (k a))
88 lam)))
89 (apply values l))))
90 lam))))
91 obj))))))
92
93 (define-syntax define-generator
94 (lambda (x)
95 (syntax-case x ()
96 ((_ (f y . args) code ...)
97 #'(define f (make-generator args (lambda (y . args) code ...)))))))
98
99 (define-class <yield> () s k closed)
100
101 (define-method (send (l <yield>) . u)
102 (let ((k (slot-ref l 'k))
103 (s (slot-ref l 's))
104 (c (slot-ref l 'closed)))
105 (if (not c)
106 (if k
107 (k (lambda ()
108 (if (null? u)
109 'Null
110 (apply values u))))
111 (throw 'python (Exception))))))
112
113
114 (define-method (sendException (l <yield>) e . ls)
115 (let ((k (slot-ref l 'k))
116 (s (slot-ref l 's))
117 (c (slot-ref l 'closed)))
118 (if (not c)
119 (if k
120 (k (lambda ()
121 (if (pyclass? e)
122 (throw 'python (apply e ls))
123 (apply throw 'python e ls))))
124 (throw 'python (Exception))))))
125
126 (define-method (sendClose (l <yield>))
127 (let ((k (slot-ref l 'k))
128 (s (slot-ref l 's))
129 (c (slot-ref l 'closed)))
130 (if c
131 (values)
132 (if k
133 (catch #t
134 (lambda ()
135 (k (lambda () (throw 'python GeneratorExit)))
136 (slot-set! l 'closed #t)
137 (throw 'python RuntimeError))
138 (lambda (k tag . v)
139 (slot-set! l 'closed #t)
140 (if (eq? tag 'python)
141 (match v
142 ((tag . l)
143 (if (eq? tag GeneratorExit)
144 (values)
145 (apply throw tag l))))
146 (apply throw tag v))))
147 (slot-set! l 'closed #t)))))
148
149 (define-method (send (l <p>) . u)
150 (apply (ref l '__send__) u))
151
152 (define-method (sendException (l <p>) . u)
153 (apply (ref l '__exception__) u))
154
155 (define-method (sendClose (l <p>))
156 ((ref l '__close__)))