diff options
Diffstat (limited to 'modules/language/python/compile.scm')
-rw-r--r-- | modules/language/python/compile.scm | 258 |
1 files changed, 141 insertions, 117 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 821389c..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)) @@ -286,7 +299,7 @@ (define (pr . x) (if do-pr (let () - (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a")) + (define port (open-file "/home/stis/src/python-on-guile/modules/log.txt" "a")) (with-output-to-port port (lambda () (pretty-print (syntax->datum x)))) @@ -294,7 +307,7 @@ (car (reverse x))) (define (pf x) - (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a")) + (define port (open-file "/home/stis/src/python-on-guile/modules/compile.log" "a")) (with-output-to-port port (lambda () (pretty-print (syntax->datum x)) x)) (close port) @@ -1259,7 +1272,7 @@ `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l))))) (#:import - ((_ (#:from (() . nm) . #f)) + ((_ (#:from (() () . nm) . #f)) (let* ((xl (map (lambda (nm) (exp vs nm)) nm)) (l `(language python module ,@xl))) @@ -1297,7 +1310,7 @@ (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l))) `(,(C 'use) ,? ,l ,l)))) - ((_ (#:from (() . nm) l)) + ((_ (#:from (() () . nm) l)) ;; Make sure to load the module in (let* ((xl (map (lambda (nm) (exp vs nm)) nm)) (ll `(language python module ,@xl))) @@ -1389,10 +1402,13 @@ ,@(map (lambda (dots ids as) `(,(G 'begin) - ,@(map (lambda (dots ids as) - (let* ((u (module-name (current-module))) - (u (reverse (list-cdr-ref (reverse (u-it u)) - (- (length dots) 1)))) + ,@(map (lambda (dots ids as) + (let* ((u (module-name (current-module))) + (u (if (null? dots) + '() + (reverse (list-cdr-ref + (reverse (u-it u)) + (- (length dots) 1))))) (path (append (if (null? dots) '() u) (map (g vs exp) ids)))) @@ -1451,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)))))))) @@ -1465,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) @@ -1480,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)) @@ -1507,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))) @@ -1515,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))))) @@ -1525,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))) @@ -1587,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) @@ -1610,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)))))))) @@ -2059,7 +2076,7 @@ (define (exp vs x) - (match x + (match (pr 'exp x) ((e) (exp vs e)) ((tag . l) @@ -2078,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 @@ -2100,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) @@ -2117,56 +2145,55 @@ (x '()))) (fluid-set! ignore '()) - (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))) @@ -2431,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)) @@ -2514,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 @@ -2528,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))) @@ -2543,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 @@ -2558,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))) @@ -2619,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)) @@ -2639,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)) @@ -2677,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)) @@ -2693,7 +2720,7 @@ #'(let ((inv (wrap-in in))) (clet (yy ...) - (let/ec break-ret + (let/ecx break-ret (catch StopIteration (lambda () (let lp () @@ -2714,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)) @@ -2730,7 +2757,7 @@ #'(clet (yy ...) (let ((inv (wrap-in in)) ...) - (let/ec break-ret + (let/ecx break-ret (catch StopIteration (lambda () (let lp () @@ -2783,7 +2810,7 @@ (call-with-prompt ab (lambda () - (let/ec return + (let/ecx return (apply code x)) (slot-set! obj 'closed #t) (throw StopIteration)) @@ -2838,10 +2865,7 @@ ((_ v (#:apply x ...) . l) #'(ref-x (py-apply v x ...) . l)) - - ((_ v (#:apply x ...) . l) - #'(ref-x (py-apply v x ...) . l)) - + ((_ v (#:vecref x) . l) #'(ref-x (pylist-ref v x) . l)) @@ -2959,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 '())) |