ce503d95e8f1511f39aaf6dd4b5f9886ec5a97f2
[software/python-on-guile.git] / modules / language / python / compile.scm
1 (define-module (language python compile)
2 #:use-module (ice-9 match)
3 #:use-module (ice-9 control)
4 #:use-module (oop pf-objects)
5 #:use-module (oop goops)
6 #:use-module (ice-9 pretty-print)
7 #:export (comp))
8
9 (define-syntax clear-warning-data
10 (lambda (x)
11 (pr 'clear)
12 (set! (@@ (system base message) %dont-warn-list) '())
13 #f))
14
15 (define-syntax dont-warn
16 (lambda (x)
17 (syntax-case x ()
18 ((_ d)
19 #t
20 (begin
21 (set! (@@ (system base message) %dont-warn-list)
22 (cons (syntax->datum #'d)
23 (@@ (system base message) %dont-warn-list)))
24 #f)))))
25
26 (define-syntax call
27 (syntax-rules ()
28 ((_ (f) . l) (f . l))))
29
30 (define (fold f init l)
31 (if (pair? l)
32 (fold f (f (car l) init) (cdr l))
33 init))
34
35 (define (pr . x)
36 (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
37 (with-output-to-port port
38 (lambda ()
39 (pretty-print (syntax->datum x))))
40 (close port)
41 (car (reverse x)))
42
43 (define (pf x)
44 (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
45 (with-output-to-port port
46 (lambda () (pretty-print (syntax->datum x)) x))
47 (close port)
48 x)
49
50 (define (C x) `(@@ (language python compile) ,x))
51 (define (O x) `(@@ (oop pf-objects) ,x))
52 (define (G x) `(@ (guile) ,x))
53
54 (define (union as vs)
55 (let lp ((as as) (vs vs))
56 (match as
57 ((x . as)
58 (if (member x vs)
59 (lp as vs)
60 (lp as (cons x vs))))
61 (()
62 vs))))
63
64 (define (diff as vs)
65 (let lp ((as as) (rs '()))
66 (match as
67 ((x . as)
68 (if (member x vs)
69 (lp as rs)
70 (lp as (cons x rs))))
71 (()
72 rs))))
73
74 (define (get-globals code)
75 (let lp ((vs (glob code '())) (rs (scope code '())))
76 (match vs
77 ((x . l)
78 (if (member x rs)
79 (lp l rs)
80 (lp l (cons x rs))))
81 (()
82 rs))))
83
84 (define (glob x vs)
85 (match x
86 ((#:global . l)
87 (let lp ((l l) (vs vs))
88 (match l
89 (((#:identifier v . _) . l)
90 (let ((s (string->symbol v)))
91 (if (member s vs)
92 (lp l vs)
93 (lp l (cons s vs)))))
94 (()
95 vs))))
96 ((x . y)
97 (glob y (glob x vs)))
98 (x vs)))
99
100 (define (scope x vs)
101 (match x
102 ((#:def (#:identifier f . _) . _)
103 (union (list (string->symbol f)) vs))
104 ((#:lambdef . _)
105 vs)
106 ((#:classdef . _)
107 vs)
108 ((#:global . _)
109 vs)
110 ((#:identifier v . _)
111 (let ((s (string->symbol v)))
112 (if (member s vs)
113 vs
114 (cons s vs))))
115 ((x . y)
116 (scope y (scope x vs)))
117 (_ vs)))
118
119 (define (defs x vs)
120 (match x
121 ((#:def (#:identifier f . _) . _)
122 (union (list (string->symbol f)) vs))
123 ((#:lambdef . _)
124 vs)
125 ((#:class . _)
126 vs)
127 ((#:global . _)
128 vs)
129 ((x . y)
130 (defs y (defs x vs)))
131 (_ vs)))
132
133 (define (g vs e)
134 (lambda (x) (e vs x)))
135
136 (define return (make-fluid 'error-return))
137
138 (define (make-set vs x u)
139 (match x
140 ((#:test (#:power (#:identifier v . _) addings . _) . _)
141 (let ((v (string->symbol v)))
142 (if (null? addings)
143 `(set! ,v ,u)
144 (let* ((rev (reverse addings))
145 (las (car rev))
146 (new (reverse (cdr rev))))
147 `(,(O 'set) ,(let lp ((v v) (new new))
148 (match new
149 ((x . new)
150 (lp `(,(O 'ref) ,v ,(exp vs x)) ',new))
151 (() v)))
152 ',(exp vs las) ,u)))))))
153
154 (define is-class? (make-fluid #f))
155
156 (define (exp vs x)
157 (match (pr x)
158
159 ((#:power (x) () . #f)
160 (exp vs x))
161 ((#:power x () . #f)
162 (exp vs x))
163
164
165 ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
166 ((#:power vf trailer . #f)
167 (let lp ((e (exp vs vf)) (trailer trailer))
168 (match trailer
169 (()
170 e)
171 ((#f)
172 (list e))
173 ((x . trailer)
174 (match (pr x)
175 ((#:identifier . _)
176 (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
177 ((#:arglist args #f #f)
178 (lp `(,e ,@(map (g vs exp) args)) trailer))
179 (_ (error "unhandled trailer")))))))
180
181 ((#:identifier x . _)
182 (string->symbol x))
183
184 ((#:string #f x)
185 x)
186
187 (((and x (or #:+ #:- #:* #:/)) . l)
188 (cons (keyword->symbol x) (map (g vs exp) l)))
189
190 ((#:u~ x)
191 (list 'lognot (exp vs x)))
192
193 ((#:band . l)
194 (cons 'logand (map (g vs exp) l)))
195
196 ((#:bxor . l)
197 (cons 'logxor (map (g vs exp) l)))
198
199 ((#:bor . l)
200 (cons 'logior (map (g vs exp) l)))
201
202 ((#:not x)
203 (list 'not (exp vs x)))
204
205 ((#:or . x)
206 (cons 'or (map (g vs exp) x)))
207
208 ((#:and . x)
209 (cons 'and (map (g vs exp) x)))
210
211 ((#:test e1 #f)
212 (exp vs e1))
213
214 ((#:test e1 e2 e3)
215 (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
216
217 ((#:if test a ((tests . as) ...) . else)
218 `(,(G 'cond)
219 (,(exp vs test) ,(exp vs a))
220 ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
221 ,@(if else `((else ,(exp vs else))) '())))
222
223 ((#:suite . l) (cons 'begin (map (g vs exp) l)))
224
225 ((#:try x #f #f fin)
226 `(dynamic-wind
227 (lambda () #f)
228 (lambda () ,(exp vs x))
229 (lambda () ,(exp vs fin))))
230
231 ((#:while test code #f)
232 (let ((lp (gensym "lp")))
233 `(let ,lp ()
234 (if test
235 (begin
236 ,(exp vs code)
237 (,lp))))))
238
239 ((#:classdef (#:identifier class . _) parents defs)
240 (with-fluids ((is-class? #t))
241 (let ()
242 (define (filt l)
243 (reverse
244 (fold (lambda (x s)
245 (match x
246 (((or 'fast 'functional)) s)
247 (x (cons x s))))
248 '() l)))
249 (define (is-functional l)
250 (fold (lambda (x pred)
251 (if pred
252 pred
253 (match x
254 (('functional) #t)
255 (_ #f)))) #f l))
256 (define (is-fast l)
257 (fold (lambda (x pred)
258 (if pred
259 pred
260 (match x
261 (('fast) #t)
262 (_ #f)))) #f l))
263
264
265 (let* ((class (string->symbol class))
266 (parents (match parents
267 (#f
268 '())
269 ((#:arglist args . _)
270 (map (g vs exp) args))))
271 (is-func (is-functional parents))
272 (is-fast (is-fast parents))
273 (kind (if is-func
274 (if is-fast
275 'mk-pf-class
276 'mk-pyf-class)
277 (if is-fast
278 'mk-p-class
279 'mk-py-class)))
280 (parents (filt parents)))
281 `(define ,class (,(O 'wrap)
282 (,(O kind)
283 ,class
284 ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
285 #:const
286 ,(match (exp vs defs)
287 (('begin . l)
288 l)
289 ((('begin . l))
290 l)
291 (l l))
292 #:dynamic
293 ())))))))
294
295
296 (#:break
297 (C 'break))
298
299 (#:continue
300 (C 'continue))
301
302 ((#:for e in code . #f)
303 (=> next)
304 (match e
305 (((#:power (#:identifier x . _) () . #f))
306 (match in
307 (((#:test power . _))
308 (match power
309 ((#:power
310 (#:identifier "range" . _)
311 ((#:arglist arglist . _))
312 . _)
313 (match arglist
314 ((arg)
315 (let ((v (gensym "v"))
316 (x (string->symbol x))
317 (lp (gensym "lp")))
318 `(let ((,v ,(exp vs arg)))
319 (let ,lp ((,x 0))
320 (if (< ,x ,v)
321 (begin
322 ,(exp vs code)
323 (,lp (+ ,x 1))))))))
324 ((arg1 arg2)
325 (let ((v1 (gensym "va"))
326 (v2 (gensym "vb"))
327 (lp (gensym "lp")))
328 `(let ((,v1 ,(exp vs arg1))
329 (,v2 ,(exp vs arg2)))
330 (let ,lp ((,x ,v1))
331 (if (< ,x ,v2)
332 (begin
333 ,(exp vs code)
334 (,lp (+ ,x 1))))))))
335 ((arg1 arg2 arg3)
336 (let ((v1 (gensym "va"))
337 (v2 (gensym "vb"))
338 (st (gensym "vs"))
339 (lp (gensym "lp")))
340 `(let ((,v1 ,(exp vs arg1))
341 (,st ,(exp vs arg2))
342 (,v2 ,(exp vs arg3)))
343 (if (> st 0)
344 (let ,lp ((,x ,v1))
345 (if (< ,x ,v2)
346 (begin
347 ,(exp vs code)
348 (,lp (+ ,x ,st)))))
349 (if (< st 0)
350 (let ,lp ((,x ,v1))
351 (if (> ,x ,v2)
352 (begin
353 ,(exp vs code)
354 (,lp (+ ,x ,st)))))
355 (error "range with step 0 not allowed"))))))
356 (_ (next))))
357 (_ (next))))
358 (_ (next))))
359 (_ (next))))
360
361 ((#:for es in code . else)
362 (let* ((es2 (map (g vs exp) es))
363 (vs2 (union es2 vs))
364 (code2 (exp vs2 code))
365 (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
366 (else2 (if else (exp vs2 else) #f))
367 (in2 (map (g vs exp) in)))
368 (list (C 'for) es2 in2 code2 else2 p)))
369
370 ((#:while test code else)
371 (let ((lp (gensym "lp")))
372 `(let ,lp ()
373 (if test
374 (begin
375 ,(exp vs code)
376 (,lp))
377 ,(exp vs else)))))
378
379 ((#:try x exc else fin)
380 (define (f x)
381 (match else
382 ((#f x)
383 `(catch #t
384 (lambda () ,x)
385 (lambda ,(gensym "x") ,(exp vs x))))))
386
387 `(dynamic-wind
388 (lambda () #f)
389 (lambda ()
390 ,(f
391 (let lp ((code (exp vs x)) (l (reverse exc)))
392 (match l
393 ((((e) c) . l)
394 (lp `(catch ,(exp vs e)
395 (lambda () ,code)
396 (lambda ,(gensym "x")
397 ,(exp vs c))) l))
398 ((((e . as) c) . l)
399 (lp `(let ((,as ,(exp vs e)))
400 (catch ,as
401 (lambda () ,code)
402 (lambda ,(gensym "x")
403 ,(exp vs c)))) l))
404 (()
405 code))))
406 (lambda () ,(exp vs fin)))))
407
408 ((#:def (#:identifier f . _)
409 (#:types-args-list
410 args
411 #f #f)
412 #f
413 code)
414 (let* ((c? (fluid-ref is-class?))
415 (f (string->symbol f))
416 (r (gensym "return"))
417 (as (map (lambda (x) (match x
418 ((((#:identifier x . _) . #f) #f)
419 (string->symbol x))))
420 args))
421 (vs (union as vs))
422 (ns (scope code vs))
423 (df (defs code '()))
424 (ex (gensym "ex"))
425 (ls (diff (diff ns vs) df)))
426 (with-fluids ((is-class? #f))
427 (if c?
428 `(define ,f (letrec ((,f
429 (case-lambda
430 ((,ex ,@as)
431 (,f ,@as))
432 ((,@as)
433 (,(C 'with-return) ,r
434 (let ,(map (lambda (x) (list x #f)) ls)
435 ,(with-fluids ((return r))
436 (exp ns code))))))))
437 ,f))
438
439 `(define ,f (lambda (,@as)
440 (,(C 'with-return) ,r
441 (let ,(map (lambda (x) (list x #f)) ls)
442 ,(with-fluids ((return r))
443 (exp ns code))))))))))
444
445 ((#:global . _)
446 '(values))
447
448 ((#:lambdef v e)
449 (list `lambda v (exp vs e)))
450
451 ((#:stmt l)
452 (if (> (length l) 1)
453 (cons 'values (map (g vs exp) l))
454 (exp vs (car l))))
455
456
457 ((#:expr-stmt (l) (#:assign))
458 (exp vs l))
459
460 ((#:expr-stmt l (#:assign u))
461 (cond
462 ((= (length l) (length u))
463 (if (= (length l) 1)
464 (make-set vs (car l) (exp vs (car u)))
465 (cons 'begin
466 (map make-set
467 (map (lambda x vs) l)
468 l
469 (map (g vs exp) u)))))
470 ((= (length u) 1)
471 (let ((vars (map (lambda (x) (gensym "v")) l)))
472 `(call-with-values (lambda () (exp vs (car u)))
473 (lambda vars
474 ,@(map make-set l vars)))))))
475
476
477
478 ((#:return . x)
479 `(,(fluid-ref return) ,@(map (g vs exp) x)))
480
481 ((#:expr-stmt
482 ((#:test (#:power (#:identifier v . _) () . #f) #f))
483 (#:assign (l)))
484 (let ((s (string->symbol v)))
485 `(set! ,s ,(exp vs l))))
486
487 ((#:comp x #f)
488 (exp vs x))
489
490 ((#:comp x (op . y))
491 (define (tr op x y)
492 (match op
493 ((or "<" ">" "<=" ">=")
494 (list (G (string->symbol op)) x y))
495 ("!=" (list 'not (list 'equal? x y)))
496 ("==" (list 'equal? x y))
497 ("is" (list 'eq? x y))
498 ("isnot" (list 'not (list 'eq? x y)))
499 ("in" (list 'member x y))
500 ("notin" (list 'not (list 'member x y)))
501 ("<>" (list 'not (list 'equal? x y)))))
502 (tr op (exp vs x) (exp vs y)))
503
504 (x x)))
505
506 (define (comp x)
507 (define start
508 (match (pr 'start x)
509 (((#:stmt
510 ((#:expr-stmt
511 ((#:test
512 (#:power
513 (#:identifier "module" . _)
514 ((#:arglist arglist #f #f))
515 . #f) #f))
516 (#:assign)))) . _)
517 (let ()
518 (define args
519 (map (lambda (x)
520 (exp '() x))
521 arglist))
522
523 `((,(G 'define-module)
524 (language python module ,@args)))))
525 (x '())))
526
527 (if (pair? start)
528 (set! x (cdr x)))
529
530 (let ((globs (get-globals x)))
531 `(begin
532 ,@start
533 ,(C 'clear-warning-data)
534 (set! (@@ (system base message) %dont-warn-list) '())
535 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
536 ,@(map (g globs exp) x))))
537
538 (define-syntax-parameter break
539 (lambda (x) #'(values)))
540
541 (define-syntax-parameter continue
542 (lambda (x) (error "continue must be bound")))
543
544 (define-syntax-rule (with-sp ((x v) ...) code ...)
545 (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
546
547 (define (is-ec ret x tail tags)
548 (syntax-case (pr 'is-ec x) (begin let if define @@)
549 ((begin a ... b)
550 #t
551 (or
552 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
553 (is-ec ret #'b tail tags)))
554
555 ((let lp ((y x) ...) a ... b)
556 (symbol? (syntax->datum #'lp))
557 (or
558 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
559 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
560 (is-ec ret #'b tail tags)))
561
562 ((let ((y x) ...) a ... b)
563 #t
564 (or
565 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
566 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
567 (is-ec ret #'b tail tags)))
568
569 ((if p a b)
570 #t
571 (or
572 (is-ec ret #'p #f tags)
573 (is-ec ret #'a tail tags)
574 (is-ec ret #'b tail tags)))
575
576 ((define . _)
577 #t
578 #f)
579
580 ((if p a)
581 #t
582 (or
583 (is-ec ret #'p #f tags)
584 (is-ec ret #'a tail tags)))
585
586 ((@@ _ _)
587 #t
588 (if (member (pr (syntax->datum x)) tags)
589 #t
590 #f))
591
592 ((a ...)
593 #t
594 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
595
596 (x
597 #t
598 #f)))
599
600 (define-syntax with-return
601 (lambda (x)
602 (define (analyze ret x)
603 (syntax-case x (begin let if)
604 ((begin a ... b)
605 #`(begin a ... #,(analyze ret #'b)))
606 ((let lp v a ... b)
607 (symbol? (syntax->datum #'lp))
608 #`(let lp v a ... #,(analyze ret #'b)))
609 ((let v a ... b)
610 #`(let v a ... #,(analyze ret #'b)))
611 ((if p a b)
612 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
613 ((if p a)
614 #`(if p #,(analyze ret #'a)))
615 ((return a b ...)
616 (equal? (syntax->datum #'return) (syntax->datum ret))
617 (if (eq? #'(b ...) '())
618 #'a
619 #`(values a b ...)))
620 (x #'x)))
621
622 (define (is-ec ret x tail)
623 (syntax-case x (begin let if define @@)
624 ((begin a ... b)
625 #t
626 (or
627 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
628 (is-ec ret #'b tail)))
629
630 ((let lp ((y x) ...) a ... b)
631 (symbol? (syntax->datum #'lp))
632 (or
633 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
634 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
635 (is-ec ret #'b tail)))
636
637 ((let ((y x) ...) a ... b)
638 #t
639 (or
640 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
641 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
642 (is-ec ret #'b tail)))
643
644 ((define . _)
645 #t
646 #f)
647
648 ((if p a b)
649 #t
650 (or
651 (is-ec ret #'p #f)
652 (is-ec ret #'a tail)
653 (is-ec ret #'b tail)))
654
655 ((if p a)
656 #t
657 (or
658 (is-ec ret #'p #f)
659 (is-ec ret #'a tail)))
660
661 ((return a b ...)
662 (equal? (syntax->datum #'return) (syntax->datum ret))
663 (not tail))
664
665 ((a ...)
666 #t
667 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
668
669 (x
670 #t
671 #f)))
672
673 (syntax-case x ()
674 ((_ ret l)
675 (let ((code (analyze #'ret #'l)))
676 (if (is-ec #'ret #'l #t)
677 #`(let/ec ret #,code)
678 code))))))
679
680 (define-syntax-rule (var v)
681 (begin
682 (dont-warn v)
683 (if (defined? 'v)
684 (values)
685 (define! 'v #f))))
686
687 (define-inlinable (non? x) (eq? x #:nil))
688
689 (define-syntax for
690 (syntax-rules ()
691 ((_ (x) (a) code #f #f)
692 (if (pair? a)
693 (let lp ((l a))
694 (if (pair? l)
695 (let ((x (car l)))
696 (with-sp ((continue (lp (cdr l)))
697 (break (values)))
698 code
699 (lp (cdr l))))))
700 (for/adv1 (x) (a) code #f #f)))
701
702 ((_ (x) (a) code #f #t)
703 (if (pair? a)
704 (let/ec break-ret
705 (let lp ((l a))
706 (if (pair? l)
707 (begin
708 (let/ec continue-ret
709 (let ((x (car l)))
710 (with-sp ((continue (continue-ret))
711 (break (break-ret)))
712 code)))
713 (lp (cdr l))))))
714 (for/adv1 (x) (a) code #f #t)))
715
716 ((_ (x) (a) code next #f)
717 (if (pair? a)
718 (let/ec break-ret
719 (let ((x (let lp ((l a) (old #f))
720 (if (pair? l)
721 (let ((x (car l)))
722 (let/ec continue-ret
723 (with-sp ((continue (continue-ret))
724 (break (break-ret)))
725 code))
726 (lp (cdr l)))
727 old))))
728 next))
729 (for/adv1 (x) (a) code next #f)))
730
731 ((_ x a code next p)
732 (for/adv1 x a code next p))))
733
734 (define-syntax for/adv1
735 (lambda (x)
736 (syntax-case x ()
737 ((_ (x ...) (in ...) code #f #f)
738 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
739 #'(let ((inv (wrap-in in)) ...)
740 (let lp ()
741 (call-with-values (lambda () (values (next inv) ...))
742 (lambda (x ...)
743 (if (or (non? x) ...)
744 (values)
745 (begin
746 code
747 (lp)))))))))
748
749 ((_ (x ...) (in ...) code #f #t)
750 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
751 #'(let ((inv (wrap-in in)) ...)
752 (let lp ()
753 (let/ec break-ret
754 (call-with-values (lambda () (values (next inv) ...))
755 (lambda (x ...)
756 (if (or (non? x) ...)
757 (values)
758 (begin
759 (let/ec continue-ret
760 (with-sp ((break (break-ret))
761 (continue (continue-ret)))
762 code))
763 (lp))))))))))
764
765 ((_ (x ...) in code else #f)
766 #'(for-adv (x ...) in code else #f))
767
768 ((_ (x ...) in code else #t)
769 #'(for-adv (x ...) in code else #t)))))
770
771
772 (define-syntax for-adv
773 (lambda (x)
774 (define (gen x y)
775 (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
776 (syntax-case x ()
777 ((x ...) #'(values (next x) ...)))
778 (syntax-case x ()
779 ((x) #'(next x)))))
780
781 (syntax-case x ()
782 ((_ (x ...) (in ...) code else p)
783 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
784 (with-syntax ((get (gen #'(inv ...) #'(x ...)))
785 ((xx ...) (generate-temporaries #'(x ...))))
786 #'(let ((inv (wrap-in in)) ...)
787 (if p
788 (let/ec break-ret
789 (call-with-values
790 (lambda ()
791 (let lp ((xx #f) ...)
792 (call-with-values (lambda () get)
793 (lambda (x ...)
794 (let/ec continue-ret
795 (if (or (non? x) ...)
796 (values xx ...)
797 (with-sp ((break (break-ret))
798 (continue (continue-ret)))
799 code)))
800 (lp x ...))))))
801 (lambda (x ...) else))
802
803 (let/ec break-ret
804 (call-with-values
805 (lambda ()
806 (let lp ((xx #f) ...)
807 (call-with-values (lambda () get)
808 (lambda (x ...)
809 (if (or (non? x) ...)
810 (values xx ...)
811 (begin
812 (with-sp ((break (break-ret))
813 (continue (values)))
814 code)
815 (lp x ...)))))))
816 (lambda (x ...) else)))))))))))
817
818
819 (define-class <scm-list> () (x) l)
820 (define-class <scm-string> () (x) s i)
821
822 (define-method (next (l <scm-list>))
823 (let ((ll (slot-ref l 'l)))
824 (if (pair? ll)
825 (begin
826 (slot-set! l 'l (cdr ll))
827 (car ll))
828 #:nil)))
829
830 (define-method (next (l <scm-string>))
831 (let ((s (slot-ref l 's))
832 (i (slot-ref l 'i)))
833 (if (= i (string-length s))
834 #:nil
835 (begin
836 (slot-set! l 'i (+ i 1))
837 (string-ref s i)))))
838
839 (define (wrap-in x)
840 (cond
841 ((pair? x)
842 (let ((o (make <scm-list>)))
843 (slot-set! o 'l x)
844 o))
845
846 ((string? x)
847 (let ((o (make <scm-string>)))
848 (slot-set! o 's x)
849 (slot-set! o 'i 0)
850 o))
851
852 (else
853 x)))
854