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