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