diff options
Diffstat (limited to 'modules/language/python/compile.scm')
-rw-r--r-- | modules/language/python/compile.scm | 117 |
1 files changed, 69 insertions, 48 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index b2f5ea7..de4299d 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -43,6 +43,8 @@ (define-inlinable (H x) `(@ (language python hash) ,x)) (define-inlinable (W x) `(@ (language python with) ,x)) +(define cvalues (G 'values)) + (define-syntax-rule (wth code) (let ((old s/d)) (set! s/d (C 'qset!)) @@ -616,7 +618,7 @@ (_ (error "unhandled addings"))) (get-addings vs l fast?)))))) - + (define-syntax-rule (setwrap u) (call-with-values (lambda () u) (case-lambda @@ -760,7 +762,7 @@ (#:decorated ((_ (l ...)) (fluid-set! decorations (map (g vs exp) l)) - '(values))) + `(,cvalues))) (#:string ((_ l) @@ -1049,7 +1051,7 @@ (if (< ,x ,v) (begin (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (values)) + (,(C 'with-sp) ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp (+ ,x 1)))))))) @@ -1079,7 +1081,7 @@ (if (< ,x ,v2) (begin (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (values)) + (,(C 'with-sp) ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp (+ ,x 1))))))) @@ -1109,7 +1111,7 @@ (begin (,(C 'let/ec) continue-ret (,(C 'with-sp) - ((continue (values)) + ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp (+ ,x ,st))))) @@ -1119,7 +1121,7 @@ (begin (,(C 'let/ec) continue-ret (,(C 'with-sp) - ((continue (values)) + ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp (+ ,x ,st))))) @@ -1180,7 +1182,7 @@ (if (,(C 'boolit) ,(exp vs test)) (begin (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (values)) + (,(C 'with-sp) ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp))))) @@ -1203,7 +1205,7 @@ (if (,(C 'boolit) ,(exp vs test)) (begin (,(C 'let/ec) ,(C 'continue-ret) - (,(C 'with-sp) ((continue (values)) + (,(C 'with-sp) ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp)) @@ -1377,7 +1379,7 @@ (#:global ((_ . _) - '(values))) + `(,cvalues))) (#:list ((_ x (and e (#:cfor . _))) @@ -1429,7 +1431,7 @@ (#:stmt ((_ l) (if (> (length l) 1) - (cons 'values (map (g vs exp) l)) + (cons cvalues (map (g vs exp) l)) (exp vs (car l))))) (#:expr-stmt @@ -1460,12 +1462,12 @@ (if (= (length l) 1) `(begin ,(make-set vs op (car l) (exp vs (car u))) - (values)) + (,cvalues)) `(begin ,@(map (lambda (l u) (make-set vs op l u)) l (map (g vs exp) u)) - (values)))) + (,cvalues)))) ((and (= (length u) 1) (not op)) (let ((vars (map (lambda (x) (gensym "v")) l)) @@ -1483,12 +1485,12 @@ ,@(map (lambda (l v) (make-set vs op l v)) l vars))))) ,f)) - (values)))) + (,cvalues)))) ((and (= (length l) 1) (not op)) `(begin ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u))) - (values))))))) + (,cvalues))))))) ((_ ((#:test (#:power #f (#:identifier v . _) () . #f) #f)) @@ -1532,7 +1534,7 @@ ,@(map (lambda (l u) (make-set vs op l u)) l (map (g vs exp) u)) - (values ,@(map (g exp vs) l))))) + (,cvalues ,@(map (g exp vs) l))))) ((and (= (length u) 1) (not op)) (let ((vars (map (lambda (x) (gensym "v")) l)) @@ -1550,12 +1552,12 @@ ,@(map (lambda (l v) (make-set vs op l v)) l vars))))) ,f)) - (values ,@(map (g exp vs) l))))) + (,cvalues ,@(map (g exp vs) l))))) ((and (= (length l) 1) (not op)) `(begin ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u))) - (values ,(exp vs (car l)))))))))) + (,cvalues ,(exp vs (car l)))))))))) (#:return ((_ x) @@ -1624,7 +1626,7 @@ (#:None (E 'None)) (#:null ''()) (#:False #f) - (#:pass `(values)) + (#:pass `(,cvalues)) (#:break (C 'break)) (#:continue @@ -1675,7 +1677,7 @@ (define ,fnm (make-hash-table)) ,@(map (lambda (s) (if (member s (fluid-ref ignore)) - `(values) + `(,cvalues) `(,(C 'var) ,s))) globs) ,@e (,(C 'export-all))))) @@ -1696,7 +1698,7 @@ (fluid-set! (@@ (system base message) %dont-warn-list) '()) ,@(map (lambda (s) (if (member s (fluid-ref ignore)) - `(values) + `(,cvalues) `(,(C 'var) ,s))) globs) ,@e))))) @@ -1854,15 +1856,15 @@ (x #'x))) (define (is-ec ret x tail) - (syntax-case x (let-syntax begin let if define @@) + (syntax-case x (let-syntax begin let let* if define @@) ((cond (p a ... b) ...) (equal? (syntax->datum #'cond) '(@ (guile) cond)) - (or - (or-map (lambda (x) (is-ec ret x #f)) - #'(a ... ...)) - (or-map (lambda (x) (is-ec ret x tail)) - #'(b ...)))) + (or + (or-map (lambda (x) (is-ec ret x #f)) + #'(a ... ...)) + (or-map (lambda (x) (is-ec ret x tail)) + #'(b ...)))) ((with-self u v a ... b) (equal? (syntax->datum #'with-self) @@ -1897,6 +1899,13 @@ (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) (is-ec ret #'b tail))) + ((let* ((y x) ...) a ... b) + #t + (or + (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) @@ -1930,7 +1939,7 @@ ((_ ret l) (let ((code (analyze #'ret #'l))) (if (is-ec #'ret #'l #t) - #`(let/ec ret #,code) + #`(let/ec ret l) code)))))) (define-syntax var @@ -1978,6 +1987,11 @@ (q (apply f q))) f))))))) +(define (gen-temp x) + (syntax-case x () + ((x ...) (map gen-temp #'(x ...))) + (x (car (generate-temporaries (list #'x)))))) + (define-syntax cfor (lambda (x) (syntax-case x () @@ -2048,14 +2062,14 @@ (syntax-case x () ((_ (x ...) (in) code #f #f) (with-syntax ((inv (gentemp #'in)) - ((xx ...) (generate-temporaries #'(x ...)))) + ((xx ...) (gen-temp #'(x ...)))) #'(let ((inv (wrap-in in))) (catch StopIteration (lambda () (let lp () (call-with-values (lambda () (next inv)) (clambda (xx ...) - (set! x xx) ... + (cset! x xx) ... (with-sp ((break (values)) (continue (values))) code @@ -2064,14 +2078,14 @@ ((_ (x ...) (in ...) code #f #f) (with-syntax (((inv ...) (generate-temporaries #'(in ...))) - ((xx ...) (generate-temporaries #'(x ...)))) + ((xx ...) (gen-temp #'(x ...)))) #'(let ((inv (wrap-in in)) ...) (catch StopIteration (lambda () (let lp () (call-with-values (lambda () (values (next inv) ...)) (clambda (xx ...) - (set! x xx) ... + (cset! x xx) ... (with-sp ((break (values)) (continue (values))) code @@ -2080,7 +2094,7 @@ ((_ (x ...) (in) code #f #t) (with-syntax ((inv (gentemp #'in)) - ((xx ...) (generate-temporaries #'(x ...)))) + ((xx ...) (gen-temp #'(x ...)))) #'(let ((inv (wrap-in in))) (let lp () (let/ec break-ret @@ -2088,7 +2102,7 @@ (lambda () (call-with-values (lambda () (next inv)) (clambda (xx ...) - (set! x xx) ... + (cset! x xx) ... (let/ec continue-ret (with-sp ((break (break-ret)) (continue (continue-ret))) @@ -2098,7 +2112,7 @@ ((_ (x ...) (in ...) code #f #t) (with-syntax (((inv ...) (generate-temporaries #'(in ...))) - ((xx ...) (generate-temporaries #'(x ...)))) + ((xx ...) (gen-temp #'(x ...)))) #'(let ((inv (wrap-in in)) ...) (let lp () (let/ec break-ret @@ -2106,7 +2120,7 @@ (lambda () (call-with-values (lambda () (values (next inv) ...)) (clambda (xx ...) - (set! x xx) ... + (cset! x xx) ... (let/ec continue-ret (with-sp ((break (break-ret)) (continue (continue-ret))) @@ -2129,11 +2143,6 @@ ((x ...) #'(values (next x) ...))) (syntax-case x () ((x) #'(next x))))) - - (define (gen-temp x) - (syntax-case x () - ((x ...) (map gen-temp #'(x ...))) - (x (car (generate-temporaries (list #'x)))))) (syntax-case x () ((_ (x ...) (in) code else p) @@ -2379,14 +2388,26 @@ (define-syntax boolit - (syntax-rules (and or not < <= > >=) - ((_ (and x y)) (and (boolit x) (boolit y))) - ((_ (or x y)) (or (boolit x) (boolit y))) - ((_ (not x )) (not (boolit x))) - ((_ (< x y)) (< x y)) - ((_ (<= x y)) (<= x y)) - ((_ (> x y)) (> x y)) - ((_ (>= x y)) (>= x y)) + (syntax-rules (and eq? equal? or not < <= > >=) + ((_ (and x y)) (and (boolit x) (boolit y))) + ((_ (or x y)) (or (boolit x) (boolit y))) + ((_ (not x )) (not (boolit x))) + ((_ (< x y)) (< x y)) + ((_ (<= x y)) (<= x y)) + ((_ (> x y)) (> x y)) + ((_ (>= x y)) (>= x y)) + ((_ (eq? x y)) (eq? x y)) + ((_ (equal? x y)) (equal? x y)) + + ((_ ((@ (guile) eq? ) x y)) (eq? x y)) + ((_ ((@ (guile) equal?) x y)) (equal? x y)) + ((_ ((@ (guile) and ) x y)) (and (boolit x) (boolit y))) + ((_ ((@ (guile) or ) x y)) (or (boolit x) (boolit y))) + ((_ ((@ (guile) not ) x )) (not (boolit x))) + ((_ ((@ (guile) < ) x y)) (< x y)) + ((_ ((@ (guile) <= ) x y)) (<= x y)) + ((_ ((@ (guile) > ) x y)) (> x y)) + ((_ ((@ (guile) >= ) x y)) (>= x y)) ((_ #t) #t) ((_ #f) #f) ((_ x ) (bool x)))) |