summaryrefslogtreecommitdiff
path: root/modules/language/python/compile.scm
diff options
context:
space:
mode:
Diffstat (limited to 'modules/language/python/compile.scm')
-rw-r--r--modules/language/python/compile.scm117
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))))
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-18 20:33:27 +0000