From c4d7f3178bbd2d16660ff1f94961c811c9d528c3 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Tue, 11 Dec 2018 22:47:14 +0100 Subject: fix misscompilation of while loops --- modules/language/python/compile.scm | 233 ++++++++++++++++++++---------------- modules/language/python/module/g.py | 9 -- modules/language/python/spec.scm | 46 +++++-- 3 files changed, 165 insertions(+), 123 deletions(-) delete mode 100644 modules/language/python/module/g.py 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 ( ))) + #: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 ( ))) (,(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)) -- cgit v1.2.3