fcd562bc65be5f515bc2f07784065a389b9b7da2
[software/python-on-guile.git] / modules / language / python / for.scm
1 (define-module (language python for)
2 #:use-module (language python yield)
3 #:use-module (oop pf-objects)
4 #:use-module (language python exceptions)
5 #:use-module (oop goops)
6 #:use-module (ice-9 control)
7 #:use-module (language python persist)
8 #:export (for break next wrap-in))
9
10 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
11
12 (eval-when (compile eval load)
13 (define (generate-temporaries2 x)
14 (map (lambda (x) (generate-temporaries x)) x)))
15
16 (define-syntax-parameter break (lambda (x) #f))
17
18 (define-syntax for
19 (syntax-rules (:)
20 ((for ((x ... : E) ...) ((c n) ...) code ... #:final fin)
21 (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) fin values))
22
23 ((for ((x ... : E) ...) ((c n) ...) code ... #:else fin)
24 (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values)
25 (lambda () fin)))
26
27 ((for lp ((x ... : E) ...) ((c n) ...) code ... #:final fin)
28 (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) fin values))
29
30 ((for lp ((x ... : E) ...) ((c n) ...) code ... #:else fin)
31 (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values)
32 (lambda () fin)))
33
34 ((for ((x ... : E) ...) ((c n) ...) code ...)
35 (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values) values))
36
37 ((for lp ((x ... : E) ...) ((c n) ...) code ...)
38 (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values) values))))
39
40 (define-syntax for-work
41 (lambda (z)
42 (define (wrap-continue lp code)
43 (if (syntax->datum lp)
44 #`(lambda () (let/ec #,lp #,@code))
45 #`(lambda () #,@code)))
46
47 (syntax-case z ()
48 ((for lp ((x ... : E) ...) ((c n) ...) (code ...) fin er)
49 (with-syntax (((It ...) (generate-temporaries #'(E ...)))
50 ((cc ...) (generate-temporaries #'(c ...)))
51 (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...)))
52 (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))
53 ((N ...) (map length #'((x ...) ...)))
54 (else- (datum->syntax #'for 'else-))
55 (llp (if (syntax->datum #'lp) #'lp #'lpu)))
56
57 #`(let/ec lp-break0
58 (let ((It (wrap-in E)) ...
59 (c n ) ...
60 (x 'None ) ... ...
61 (x1 #f ) ... ...)
62 (let* ((else- er )
63 (lp-break (lambda q (else-) (apply lp-break0 q))))
64 (syntax-parameterize ((break (lambda (z)
65 (syntax-case z ()
66 ((_ . l)
67 #'(lp-break . l))
68 (_ #'lp-break)))))
69
70 (catch StopIteration
71 (lambda ()
72 (let llp ((cc c) ...)
73 (set! c cc) ...
74 (call-with-values
75 (lambda () (next It))
76 (let ((f
77 (lambda (x2 ...)
78 (set! x1 x2) ...)))
79 (if (> N 1)
80 (case-lambda
81 ((q)
82 (apply f q))
83 (q
84 (apply f q)))
85 (lambda (x2 ... . ll)
86 (set! x1 x2) ...))))
87 ...
88 (set! x x1)
89 ... ...
90 (call-with-values
91 #,(wrap-continue
92 #'lp
93 #'((let ((x x) ... ...) code ...)))
94 (lambda (cc ... . q) (llp cc ...)))))
95 (lambda q (else-) fin)))))))))))
96
97 (define-class <scm-list> () l)
98 (define-class <scm-string> () s i)
99
100 (name-object <scm-list>)
101 (name-object <scm-string>)
102 (cpit <scm-list> (o (lambda (o l) (slot-set! o 'l l))
103 (list (slot-ref o 'l))))
104 (cpit <scm-string> (o (lambda (o s i)
105 (slot-set! o 's s)
106 (slot-set! o 'i i))
107 (list
108 (slot-ref o 's)
109 (slot-ref o 'i))))
110
111 (define-method (next (l <scm-list>))
112 (let ((ll (slot-ref l 'l)))
113 (if (pair? ll)
114 (begin
115 (slot-set! l 'l (cdr ll))
116 (car ll))
117 (throw StopIteration))))
118
119 (define-method (next (l <scm-string>))
120 (let ((s (slot-ref l 's))
121 (i (slot-ref l 'i)))
122 (if (= i (string-length s))
123 (throw StopIteration)
124 (begin
125 (slot-set! l 'i (+ i 1))
126 (string-ref s i)))))
127
128 (define-method (next (l <yield>))
129 (let ((k (slot-ref l 'k))
130 (s (slot-ref l 's)))
131 (if k
132 (k (lambda () 'None))
133 (s))))
134
135 (define-method (wrap-in (o <yield>))
136 o)
137
138 (define-method (wrap-in (o <p>))
139 (aif it (ref o '__iter__)
140 (it)
141 (next-method)))
142
143 (define-method (next (l <p>))
144 ((ref l '__next__)))
145
146 (define-method (wrap-in x)
147 (cond
148 ((pair? x)
149 (let ((o (make <scm-list>)))
150 (slot-set! o 'l x)
151 o))
152
153 ((string? x)
154 (let ((o (make <scm-string>)))
155 (slot-set! o 's x)
156 (slot-set! o 'i 0)
157 o))
158
159 (else
160 x)))
161
162 (set! (@@ (oop pf-objects) hashforeach)
163 (lambda (f d)
164 (for ((k v : d)) () (f k v))))
165
166 #;
167 (pk
168 (for c ((x : (gen '(1 2 3)))) ((s 0))
169 (pk x)
170 (if (> x 2) (c s))
171 (+ s x)
172
173 #:final
174 s))