string loops
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 7 Sep 2017 21:03:08 +0000 (23:03 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 7 Sep 2017 21:03:08 +0000 (23:03 +0200)
modules/language/python/compile.scm

index 7785195e1b22a549755f3afda99dc37f8a5d385d..ce503d95e8f1511f39aaf6dd4b5f9886ec5a97f2 100644 (file)
     ((_ (x) (a) code next #f)
      (if (pair? a)
          (let/ec break-ret
-         (let ((x (let lp ((l a) (old #f))
-                    (if (pair? l)
-                        (let ((x (car l)))
-                          (with-sp ((continue (lp (cdr l) x))
-                                    (break    (break-ret)))
-                              code
-                              (lp (cdr l))))
-                        old))))
-           next)
+           (let ((x (let lp ((l a) (old #f))
+                      (if (pair? l)                          
+                          (let ((x (car l)))
+                            (let/ec continue-ret
+                              (with-sp ((continue (continue-ret))
+                                        (break    (break-ret)))
+                                code))
+                            (lp (cdr l)))
+                          old))))
+             next))
          (for/adv1 (x) (a) code next #f)))
     
     ((_ x a code next p)
                      (lambda (x ...) else)))))))))))
     
 
-(define-class <scm-list> () (x) l)
+(define-class <scm-list>   () (x) l)
+(define-class <scm-string> () (x) s i)
 
 (define-method (next (l <scm-list>))
   (let ((ll (slot-ref l 'l)))
           (car ll))
         #:nil)))
 
+(define-method (next (l <scm-string>))
+  (let ((s (slot-ref l 's))
+        (i (slot-ref l 'i)))
+    (if (= i (string-length s))
+        #:nil
+        (begin
+          (slot-set! l 'i (+ i 1))
+          (string-ref s i)))))
+
 (define (wrap-in x)
-  (if (pair? x)
-      (let ((o (make <scm-list>)))
-        (slot-set! o 'l x)
-        o)
-      x))
+  (cond
+   ((pair? x)
+    (let ((o (make <scm-list>)))
+      (slot-set! o 'l x)
+      o))
+   
+   ((string? x)
+    (let ((o (make <scm-string>)))
+      (slot-set! o 's x)
+      (slot-set! o 'i 0)
+      o))
+   
+    (else
+     x)))