From 3d3bafce2dd07dd5b3f2ef2741fb1f8d893e10eb Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Thu, 7 Sep 2017 22:36:07 +0200 Subject: improved for loop methodology --- modules/language/python/compile.scm | 244 +++++++++++++++++++++++++++++++++++- 1 file changed, 238 insertions(+), 6 deletions(-) (limited to 'modules/language/python') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 565fdcf..7785195 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -1,5 +1,8 @@ (define-module (language python compile) #:use-module (ice-9 match) + #:use-module (ice-9 control) + #:use-module (oop pf-objects) + #:use-module (oop goops) #:use-module (ice-9 pretty-print) #:export (comp)) @@ -33,7 +36,7 @@ (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a")) (with-output-to-port port (lambda () - (pretty-print x))) + (pretty-print (syntax->datum x)))) (close port) (car (reverse x))) @@ -290,6 +293,11 @@ ()))))))) + (#:break + (C 'break)) + + (#:continue + (C 'continue)) ((#:for e in code . #f) (=> next) @@ -349,7 +357,16 @@ (_ (next)))) (_ (next)))) (_ (next)))) - + + ((#:for es in code . else) + (let* ((es2 (map (g vs exp) es)) + (vs2 (union es2 vs)) + (code2 (exp vs2 code)) + (p (is-ec #t code2 #t (list (C 'break) (C 'continue)))) + (else2 (if else (exp vs2 else) #f)) + (in2 (map (g vs exp) in))) + (list (C 'for) es2 in2 code2 else2 p))) + ((#:while test code else) (let ((lp (gensym "lp"))) `(let ,lp () @@ -518,6 +535,68 @@ ,@(map (lambda (s) `(,(C 'var) ,s)) globs) ,@(map (g globs exp) x)))) +(define-syntax-parameter break + (lambda (x) #'(values))) + +(define-syntax-parameter continue + (lambda (x) (error "continue must be bound"))) + +(define-syntax-rule (with-sp ((x v) ...) code ...) + (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...)) + +(define (is-ec ret x tail tags) + (syntax-case (pr 'is-ec x) (begin let if define @@) + ((begin a ... b) + #t + (or + (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)) + (is-ec ret #'b tail tags))) + + ((let lp ((y x) ...) a ... b) + (symbol? (syntax->datum #'lp)) + (or + (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...)) + (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)) + (is-ec ret #'b tail tags))) + + ((let ((y x) ...) a ... b) + #t + (or + (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...)) + (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)) + (is-ec ret #'b tail tags))) + + ((if p a b) + #t + (or + (is-ec ret #'p #f tags) + (is-ec ret #'a tail tags) + (is-ec ret #'b tail tags))) + + ((define . _) + #t + #f) + + ((if p a) + #t + (or + (is-ec ret #'p #f tags) + (is-ec ret #'a tail tags))) + + ((@@ _ _) + #t + (if (member (pr (syntax->datum x)) tags) + #t + #f)) + + ((a ...) + #t + (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))) + + (x + #t + #f))) + (define-syntax with-return (lambda (x) (define (analyze ret x) @@ -539,9 +618,9 @@ #'a #`(values a b ...))) (x #'x))) - + (define (is-ec ret x tail) - (syntax-case x (begin let) + (syntax-case x (begin let if define @@) ((begin a ... b) #t (or @@ -561,13 +640,18 @@ (or-map (lambda (x) (is-ec ret x #f)) #'(x ...)) (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) (is-ec ret #'b tail))) - + + ((define . _) + #t + #f) + ((if p a b) #t (or (is-ec ret #'p #f) (is-ec ret #'a tail) (is-ec ret #'b tail))) + ((if p a) #t (or @@ -577,7 +661,7 @@ ((return a b ...) (equal? (syntax->datum #'return) (syntax->datum ret)) (not tail)) - + ((a ...) #t (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))) @@ -600,3 +684,151 @@ (values) (define! 'v #f)))) +(define-inlinable (non? x) (eq? x #:nil)) + +(define-syntax for + (syntax-rules () + ((_ (x) (a) code #f #f) + (if (pair? a) + (let lp ((l a)) + (if (pair? l) + (let ((x (car l))) + (with-sp ((continue (lp (cdr l))) + (break (values))) + code + (lp (cdr l)))))) + (for/adv1 (x) (a) code #f #f))) + + ((_ (x) (a) code #f #t) + (if (pair? a) + (let/ec break-ret + (let lp ((l a)) + (if (pair? l) + (begin + (let/ec continue-ret + (let ((x (car l))) + (with-sp ((continue (continue-ret)) + (break (break-ret))) + code))) + (lp (cdr l)))))) + (for/adv1 (x) (a) code #f #t))) + + ((_ (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) + (for/adv1 (x) (a) code next #f))) + + ((_ x a code next p) + (for/adv1 x a code next p)))) + +(define-syntax for/adv1 + (lambda (x) + (syntax-case x () + ((_ (x ...) (in ...) code #f #f) + (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) + #'(let ((inv (wrap-in in)) ...) + (let lp () + (call-with-values (lambda () (values (next inv) ...)) + (lambda (x ...) + (if (or (non? x) ...) + (values) + (begin + code + (lp))))))))) + + ((_ (x ...) (in ...) code #f #t) + (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) + #'(let ((inv (wrap-in in)) ...) + (let lp () + (let/ec break-ret + (call-with-values (lambda () (values (next inv) ...)) + (lambda (x ...) + (if (or (non? x) ...) + (values) + (begin + (let/ec continue-ret + (with-sp ((break (break-ret)) + (continue (continue-ret))) + code)) + (lp)))))))))) + + ((_ (x ...) in code else #f) + #'(for-adv (x ...) in code else #f)) + + ((_ (x ...) in code else #t) + #'(for-adv (x ...) in code else #t))))) + + +(define-syntax for-adv + (lambda (x) + (define (gen x y) + (if (= (length (syntax->datum x)) (= (length (syntax->datum y)))) + (syntax-case x () + ((x ...) #'(values (next x) ...))) + (syntax-case x () + ((x) #'(next x))))) + + (syntax-case x () + ((_ (x ...) (in ...) code else p) + (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) + (with-syntax ((get (gen #'(inv ...) #'(x ...))) + ((xx ...) (generate-temporaries #'(x ...)))) + #'(let ((inv (wrap-in in)) ...) + (if p + (let/ec break-ret + (call-with-values + (lambda () + (let lp ((xx #f) ...) + (call-with-values (lambda () get) + (lambda (x ...) + (let/ec continue-ret + (if (or (non? x) ...) + (values xx ...) + (with-sp ((break (break-ret)) + (continue (continue-ret))) + code))) + (lp x ...)))))) + (lambda (x ...) else)) + + (let/ec break-ret + (call-with-values + (lambda () + (let lp ((xx #f) ...) + (call-with-values (lambda () get) + (lambda (x ...) + (if (or (non? x) ...) + (values xx ...) + (begin + (with-sp ((break (break-ret)) + (continue (values))) + code) + (lp x ...))))))) + (lambda (x ...) else))))))))))) + + +(define-class () (x) l) + +(define-method (next (l )) + (let ((ll (slot-ref l 'l))) + (if (pair? ll) + (begin + (slot-set! l 'l (cdr ll)) + (car ll)) + #:nil))) + +(define (wrap-in x) + (if (pair? x) + (let ((o (make ))) + (slot-set! o 'l x) + o) + x)) + -- cgit v1.2.3