fix misscompilation of while loops

3 files changed, 165 insertions, 123 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 06e529b..973ae3a 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -43,6 +43,19 @@
 (define-inlinable (H   x) `(@  (language python hash)    ,x))
 (define-inlinable (W   x) `(@  (language python with)    ,x))
 
+(define (mk/ec x) x)
+
+(define-syntax-rule (let/ecx c a ...)
+  (let/ec c a ...))
+
+(define-syntax-rule (let/ect c a ...)
+  (let/ec c ((mk/ec (lambda (c) a ...)) c)))
+
+(eval-when (compile eval load)
+  (if (equal? (effective-version) "3.0")
+      (module-set! (current-module) 'let/ecx
+                   (module-ref (current-module) 'let/ect))))
+                   
 (define exit-prompt (make-prompt-tag))
 (define exit-fluid  (make-fluid #f))
 
@@ -1454,13 +1467,13 @@
                      (let ((v   (gensym "v"))
                            (x   (string->symbol x))
                            (lp  (gensym "lp")))
-                       `(,(C 'let/ec) break-ret
+                       `(,(C 'let/ecx) break-ret
                          (,(G 'let) ((,v ,(exp vs arg)))
                            (,(G 'let) ,lp ((,x 0))
                                 (,(G 'if) (< ,x ,v)
                                     (,(G 'begin)
-                                      (,(C 'let/ec) continue-ret
-                                       (,(C 'with-sp) ((continue (,cvalues))
+                                      (,(C 'let/ecx) continue-ret
+                                       (,(C 'with-sp) ((continue (continue-ret))
                                                        (break    (break-ret)))
                                         ,code2))
                                       (,lp (+ ,x 1))))))))
@@ -1468,7 +1481,7 @@
                      (let ((v   (gensym "v"))
                            (x   (string->symbol x))
                            (lp  (gensym "lp")))
-                       `(,(C 'let/ec) break-ret
+                       `(,(C 'let/ecx) break-ret
                          (,(G 'let) ((,v ,(exp vs arg)))
                            (,(G 'let) ,lp ((,x 0))
                                 (,(G 'if) (< ,x ,v)
@@ -1483,18 +1496,18 @@
                        (x    (string->symbol x))
                        (lp  (gensym "lp")))
                    (if p
-                       `(,(C 'let/ec) break-ret
+                       `(,(C 'let/ecx) break-ret
                          (,(G 'let) ((,v1 ,(exp vs arg1))
                                      (,v2 ,(exp vs arg2)))
                            (,(G 'let) ,lp ((,x ,v1))
                                 (,(G 'if) (< ,x ,v2)
                                     (,(G 'begin)
-                                      (,(C 'let/ec) continue-ret
-                                       (,(C 'with-sp) ((continue (,cvalues))
+                                      (,(C 'let/ecx) continue-ret
+                                       (,(C 'with-sp) ((continue (continue-ret))
                                                        (break    (break-ret)))
                                         ,code2))
                                       (,lp (+ ,x 1)))))))
-                       `(,(C 'let/ec) break-ret
+                       `(,(C 'let/ecx) break-ret
                          (,(G 'let) ((,v1 ,(exp vs arg1))
                                      (,v2 ,(exp vs arg2)))
                            (,(G 'let) ,lp ((,x ,v1))
@@ -1510,7 +1523,7 @@
                        (x    (string->symbol x))
                        (lp  (gensym "lp")))
                    (if p
-                       `(,(C 'let/ec) break-ret
+                       `(,(C 'let/ecx) break-ret
                          (,(G 'let) ((,v1 ,(exp vs arg1))
                                      (,st ,(exp vs arg3))  
                                      (,v2 ,(exp vs arg2)))
@@ -1518,9 +1531,9 @@
                                (,(G 'let) ,lp ((,x ,v1))
                                     (,(G 'if) (< ,x ,v2)
                                         (,(G 'begin)
-                                          (,(C 'let/ec) continue-ret
+                                          (,(C 'let/ecx) continue-ret
                                            (,(C 'with-sp)
-                                            ((continue (,cvalues))
+                                            ((continue (continue-ret))
                                              (break    (break-ret)))
                                             ,code2))
                                           (,lp (+ ,x ,st)))))
@@ -1528,15 +1541,15 @@
                                    (,(G 'let) ,lp ((,x ,v1))
                                         (,(G 'if) (> ,x ,v2)
                                             (,(G 'begin)
-                                              (,(C 'let/ec) continue-ret
+                                              (,(C 'let/ecx) continue-ret
                                                (,(C 'with-sp)
-                                                ((continue (,cvalues))
+                                                ((continue (continue-ret))
                                                  (break    (break-ret)))
                                                 ,code2))
                                               (,lp (+ ,x ,st)))))
                                    (,(G 'error)
                                     "range with step 0 not allowed")))))
-                       `(,(C 'let/ec) break-ret
+                       `(,(C 'let/ecx) break-ret
                          (,(G 'let) ((,v1 ,(exp vs arg1))
                                      (,st ,(exp vs arg3))
                                      (,v2 ,(exp vs arg2)))
@@ -1590,17 +1603,17 @@
           (code2 (exp vs code))
           (p     (is-ec #t code2 #t (list (C 'continue)))))
      (if p
-         `(,(C 'let/ec) break-ret
+         `(,(C 'let/ecx) break-ret
            (,(G 'let) ,lp ()
             (,(G 'if) (,(C 'boolit) ,(exp vs test))
                 (,(G 'begin)
-                  (,(C 'let/ec) continue-ret
-                   (,(C 'with-sp) ((continue (,cvalues))
+                  (,(C 'let/ecx) continue-ret
+                   (,(C 'with-sp) ((continue (continue-ret))
                                    (break    (break-ret)))                    
                     ,code2))
                   (,lp)))))
 
-         `(,(C 'let/ec) break-ret
+         `(,(C 'let/ecx) break-ret
            (,(G 'let) ,lp ()
             (,(G 'if) (,(C 'boolit) ,(exp vs test))
                 (,(G 'begin)
@@ -1613,21 +1626,22 @@
           (code2 (exp vs code))
           (p     (is-ec #t code2 #t (list (C 'continue)))))
      (if p
-         `(,(C 'let/ec) break-ret
+         `(,(C 'let/ecx) break-ret
            (,(G 'let) ,lp ()
             (,(G 'if) (,(C 'boolit) ,(exp vs test))
                 (,(G 'begin)
-                  (,(C 'let/ec) ,(C 'continue-ret)
-                   (,(C 'with-sp) ((continue (,cvalues))
+                  (,(C 'let/ecx) ,(C 'continue-ret)
+                   (,(C 'with-sp) ((continue (continue-ret))
                                    (break    (break-ret)))
                     ,code2))
                   (,lp))
                 ,(exp vs else))))
-         `(,(C 'let/ec) break-ret
+         
+         `(,(C 'let/ecx) break-ret
            (,(G 'let) ,lp ()
              (,(G 'if) (,(C 'boolit) ,(exp vs test))
                  (,(G 'begin)
-                   (,(C 'with-sp) ((break    (break-ret)))
+                   (,(C 'with-sp) ((break (break-ret)))
                     ,code2)
                    (,lp))
                  ,(exp vs else))))))))
@@ -2081,7 +2095,18 @@
      (C 'continue))
     (x x)))
 
-(define (comp x)
+(define (comp in x)
+  (define (strit x)
+    (if in
+        x
+        (with-output-to-string
+          (lambda ()
+            (let lp ((x x))
+              (if (pair? x)
+                  (begin
+                    (format #t "~s~%" (car x))
+                    (lp (cdr x)))))))))
+  
   (define start
     (match x
       (((#:stmt
@@ -2103,16 +2128,16 @@
 	 (define name (string-join (map symbol->string args) "."))
 	 
          `((define-module (language python module ,@args)
-            #:pure
-            #:use-module ((guile) #:select
-                          (@ @@ pk let* lambda call-with-values case-lambda
-                                   set! = * + - < <= > >= / pair? fluid-set!
-                                   fluid-ref
-                                   syntax-rules let-syntax abort-to-prompt))
-            #:use-module (language python module python)
-            #:use-module ((language python compile) #:select (pks))
-            #:use-module (language python exceptions)
-	    #:use-module ((oop goops) #:select (<complex> <real> <fraction> <integer> <number>)))
+             #:pure
+             #:use-module ((guile) #:select
+                           (@ @@ pk let* lambda call-with-values case-lambda
+                                    set! = * + - < <= > >= / pair? fluid-set!
+                                    fluid-ref
+                                    syntax-rules let-syntax abort-to-prompt))
+             #:use-module (language python module python)
+             #:use-module ((language python compile) #:select (pks))
+             #:use-module (language python exceptions)
+             #:use-module ((oop goops) #:select (<complex> <real> <fraction> <integer> <number>)))
            (,(G 'define) __doc__    #f)
 	   (,(G 'define) __name__   ,name)
            (,(G 'define) __module__ (,(G 'quote)
@@ -2120,57 +2145,55 @@
       (x '())))
 
   (fluid-set! ignore '())
-  (pr
-  (if (fluid-ref (@@ (system base compile) %in-compile))
-      (begin
-	(if (fluid-ref (@@ (system base compile) %in-compile))
-	    (set! s/d (C 'qset!))
-	    (set! s/d (C 'define-)))
-  
-	(if (pair? start)
-	    (set! x (cdr x)))
-
-	(let* ((globs (get-globals x))
-	       (e.doc (with-fluids ((*doc* #f))
-                        (let ((r (map (g globs exp) x)))
-                          (cons r (get-doc)))))
-               (e     (car e.doc))
-               (doc   (cdr e.doc)))
-          
-	  `(begin
-	     ,@start
-	     (,(G 'define) ,fnm (,(G 'make-hash-table)))
-	     ,@(map (lambda (s)
-		      (if (member s (fluid-ref ignore))
-			  `(,cvalues)
-			  `(,(C 'var) ,s)))
-                    (cons '__doc__ globs))
-             (,(G 'set!) __doc__ ,doc)
-	     ,@e
-	     (,(C 'export-all)))))
 
-      (begin
-	(if (fluid-ref (@@ (system base compile) %in-compile))
-	    (set! s/d 'set!)
-	    (set! s/d (C 'define-)))
+  (strit
+   (pr
+    (if (fluid-ref (@@ (system base compile) %in-compile))
+        (begin
+          (if (fluid-ref (@@ (system base compile) %in-compile))
+              (set! s/d (C 'qset!))
+              (set! s/d (C 'define-)))
+          
+          (if (pair? start)
+              (set! x (cdr x)))
+          
+          (let* ((globs (get-globals x))
+                 (e.doc (with-fluids ((*doc* #f))
+                          (let ((r (map (g globs exp) x)))
+                            (cons r (get-doc)))))
+                 (e     (car e.doc))
+                 (doc   (cdr e.doc)))
+          
+            `(,@start
+              (,(G 'define) ,fnm (,(G 'make-hash-table)))
+              ,@(map (lambda (s)
+                       (if (member s (fluid-ref ignore))
+                           `(,cvalues)
+                           `(,(C 'var) ,s)))
+                     (cons '__doc__ globs))
+              (,(G 'set!) __doc__ ,doc)
+              ,@e
+              (,(C 'export-all)))))
+
+        (begin
+          (if (fluid-ref (@@ (system base compile) %in-compile))
+              (set! s/d 'set!)
+              (set! s/d (C 'define-)))
   
-        (if (pair? start)
-            (set! x (cdr x)))
+          (if (pair? start)
+              (set! x (cdr x)))
         
-        (let* ((globs (get-globals x))
-               (res   (gensym "res"))
-               (e     (map (g globs exp) x)))
-          `(,(G 'begin)
-            ,@start
-            ,@(map (lambda (s)
-                     (if (member s (fluid-ref ignore))
-                         `(,cvalues)
-                         `(,(C 'var) ,s))) globs)
-            (,(C 'with-exit) ,@e)))))))
-	       
-		     
-
-
+          (let* ((globs (get-globals x))
+                 (res   (gensym "res"))
+                 (e     (map (g globs exp) x)))
+            `(begin
+               ,@start
+              ,@(map (lambda (s)
+                       (if (member s (fluid-ref ignore))
+                           `(,cvalues)
+                           `(,(C 'var) ,s))) globs)
+              (,(C 'with-exit) ,@e))))))))
+  
 (define-syntax-parameter break
   (lambda (x) #'(values)))
 
@@ -2435,7 +2458,7 @@
       ((_ ret  l)
        (let ((code (analyze #'ret #'l)))
          (if (is-ec #'ret #'l #t)
-             #`(let/ec ret l)
+             #`(let/ecx ret l)
              code))))))
 
 (define void (list 'void))
@@ -2518,7 +2541,7 @@
       ((_ (x) (a) code #f #f)
        (with-syntax ((x (replace_ xx #'x)))
          #'(if (pair? a)
-	       (let/ec break-ret
+	       (let/ecx break-ret
 		 (let lp ((l a))
 		   (if (pair? l)
 		       (begin
@@ -2532,11 +2555,11 @@
       ((_ (x) (a) code #f #t)
        (with-syntax ((x (replace_ xx #'x)))
           #'(if (pair? a)
-		(let/ec break-ret
+		(let/ecx break-ret
                    (let lp ((l a))
 		     (if (pair? l)
 			 (begin
-			   (let/ec continue-ret
+			   (let/ecx continue-ret
 			     (set! x (car l))
 			     (with-sp ((continue (continue-ret))
 				       (break    (break-ret)))                     
@@ -2547,7 +2570,7 @@
       ((_ (x) (a) code next #f)
        (with-syntax ((x (replace_ xx #'x)))
           #'(if (pair? a)
-		(let/ec break-ret
+		(let/ecx break-ret
 		    (let lp ((l a))
 		      (if (pair? l)
 			  (begin
@@ -2562,10 +2585,10 @@
       ((_ (x) (a) code next #t)
        (with-syntax ((x (replace_ xx #'x)))
           #'(if (pair? a)
-		(let/ec break-ret
+		(let/ecx break-ret
 		   (let lp ((l a))
 		     (if (pair? l)
-			 (let/ec continue-ret
+			 (let/ecx continue-ret
                             (set! x (car l))
 			    (with-sp ((continue (continue-ret))
 				      (break    (break-ret)))
@@ -2623,13 +2646,13 @@
 	#'(let ((inv (wrap-in in)))
 	    (clet (yy ...)
               (let lp ()
-                (let/ec break-ret
+                (let/ecx break-ret
                   (catch StopIteration
                     (lambda ()
                       (call-with-values (lambda () (next inv))
                         (clambda (xx ...)
                           (cset! yy xx) ...
-                          (let/ec continue-ret
+                          (let/ecx continue-ret
                             (with-sp ((break     (break-ret))
                                       (continue  (continue-ret)))
                                      code))
@@ -2643,13 +2666,13 @@
 	 #'(let ((inv (wrap-in in)) ...)
 	     (clet (yy ...)
               (let lp ()
-                (let/ec break-ret
+                (let/ecx break-ret
                   (catch StopIteration
                     (lambda ()
                       (call-with-values (lambda () (values (next inv) ...))
                         (clambda (xx ...)
                           (cset! yy xx) ...
-                          (let/ec continue-ret
+                          (let/ecx continue-ret
                             (with-sp ((break     (break-ret))
                                       (continue  (continue-ret)))
                                      code))
@@ -2681,14 +2704,14 @@
            (if (syntax->datum #'p)
                #'(let ((inv (wrap-in in)))
                    (clet (yy ...)
-                     (let/ec break-ret
+                     (let/ecx break-ret
                        (catch StopIteration
                          (lambda ()
                            (let lp ()
                              (call-with-values (lambda () (next inv))
                                (clambda (xx ...)
                                  (cset! yy xx) ...
-                                 (let/ec continue-ret
+                                 (let/ecx continue-ret
                                    (with-sp ((break     (break-ret))
                                              (continue  (continue-ret)))
                                             code))
@@ -2697,7 +2720,7 @@
              
                    #'(let ((inv (wrap-in in)))
                        (clet (yy ...)
-                             (let/ec break-ret
+                             (let/ecx break-ret
                                (catch StopIteration
                                  (lambda ()
                                    (let lp ()
@@ -2718,14 +2741,14 @@
          (if (syntax->datum #'p)
              #'(clet (yy ...)
                  (let ((inv (wrap-in in)) ...)               
-                   (let/ec break-ret
+                   (let/ecz break-ret
                      (catch StopIteration
                        (lambda ()
                          (let lp ()
                            (call-with-values (lambda () get)
                              (clambda (xx ...)
                                (cset! yy xx) ...
-                               (let/ec continue-ret
+                               (let/ecx continue-ret
                                  (with-sp ((break     (break-ret))
                                            (continue  (continue-ret)))
                                           code))
@@ -2734,7 +2757,7 @@
              
                  #'(clet (yy ...)
                      (let ((inv (wrap-in in)) ...)
-                       (let/ec break-ret
+                       (let/ecx break-ret
                          (catch StopIteration
                            (lambda ()
                              (let lp ()
@@ -2787,7 +2810,7 @@
                         (call-with-prompt
                          ab
                          (lambda ()
-                           (let/ec return                          
+                           (let/ecx return                          
                              (apply code x))
                            (slot-set! obj 'closed #t)
                            (throw StopIteration))
@@ -2960,11 +2983,11 @@
   (if (module-defined? mod '__all__)
       (begin
         (module-export! mod
-        (for ((x : (module-ref mod '__all__))) ((l '()))
-             (let ((x (string->symbol (scm-str x))))
-               (if (module-locally-bound? mod x)
-                   (cons x l)
-                   l))
+          (for ((x : (module-ref mod '__all__))) ((l '()))
+               (let ((x (string->symbol (scm-str x))))
+                 (if (module-locally-bound? mod x)
+                     (cons x l)
+                     l))
                #:final l))
         (module-re-export! mod
           (for ((x : (module-ref mod '__all__))) ((l '()))
diff --git a/modules/language/python/module/g.py b/modules/language/python/module/g.py
deleted file mode 100644
index dafef95..0000000
--- a/modules/language/python/module/g.py
+++ /dev/null
@@ -1,9 +0,0 @@
-module(g)
-
-class A(dict):
-    def __getitem__(self,k):
-        pk(k)
-        return super().__getitem__(k)
-
-
-__all__= ['A']
diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm
index 8291a14..46ac186 100644
--- a/modules/language/python/spec.scm
+++ b/modules/language/python/spec.scm
@@ -18,6 +18,7 @@
 ;;; Language definition
 ;;;
 
+
 (define (pr . x)
   (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
   (with-output-to-port port
@@ -26,11 +27,42 @@
   (close port)
   (car (reverse x)))
 
-(define (c x) (pr (comp (pr (p (pr x))))))
-(define (cc port x)
-  (if (equal? x "") (read port) (c x)))
+(define (c int x) (pr (comp int (pr (p (pr x))))))
+(define (cc int port x)
+  (if (equal? x "") (read port) (c int x)))
+
+(define (e x) (eval (c #t x) (current-module)))
 
-(define (e x) (eval (c x) (current-module)))
+
+(define (int)
+  (catch #t
+    (lambda ()
+      (if (fluid-ref (@@ (system base compile) %in-compile))
+          #f
+          #t))
+    (lambda x #f)))
+
+(define (in)
+  (catch #t
+    (lambda ()
+      (fluid-set! (@@ (system base compile) %in-compile) #t))
+    (lambda x #f)))
+
+(define mapper (make-weak-key-hash-table))
+
+(define python-reader-wrap
+  (lambda (port env)
+    (if (int)
+        (cc #t port (read-line port))
+        (let lp ((port2 (hash-ref mapper port)))
+          (if port2
+              (read port2)
+              (let ((port2
+                     (open-input-string (cc #f port (read-string port)))))
+                (use-modules (language python guilemod))
+                (in)
+                (hash-set! mapper port port2)
+                (lp port2)))))))
 
 (catch #t
   (lambda ()
@@ -40,11 +72,7 @@
 
 (define-language python
   #:title	"python"
-  #:reader      (lambda (port env)
-                  (if (not (fluid-ref (@@ (system base compile) %in-compile)))
-                      (cc port (read-line port))
-                      (cc port (read-string port))))
-
+  #:reader      python-reader-wrap
   #:compilers   `((tree-il . ,compile-tree-il))
   #:decompilers `((tree-il . ,decompile-tree-il))
   #:evaluator	(lambda (x module) (primitive-eval x))