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