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.scm419
1 files changed, 232 insertions, 187 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index d912587..50eacb6 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -21,7 +21,7 @@
#:use-module ((language python format2) #:select (fnm))
#:use-module ((language python with) #:select ())
#:use-module (ice-9 pretty-print)
- #:export (comp exit-fluid exit-prompt))
+ #:export (comp exit-fluid exit-prompt pks))
(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
@@ -192,7 +192,7 @@
: ,(exp vs in-e))) ()
,(gen-sel vs cont item))))))
((#:cif cif cont)
- `(if ,(exp vs cif)
+ `(,(G 'if) ,(exp vs cif)
,(gen-sel vs cont item)))))
(define (union as vs)
@@ -616,7 +616,7 @@
(if (keyword? x)
(list (G 'cons) `(,(G 'list) ,@(reverse r)) `(,(G 'list) ,@l))
(lp (cdr l) (cons x r))))
- (list (G 'cons) `(,(G 'list) ,@(reverse r)) ''()))))
+ (list (G 'cons) `(,(G 'list) ,@(reverse r)) `(,(G 'quote) ())))))
(define (get-addings vs x fast?)
(match x
@@ -638,15 +638,15 @@
(is-fkn? (aif it (and fast? is-fkn? fast)
`(#:call-obj (lambda (e)
(lambda ,xs
- (apply ,it e ,xs))))
+ (,(G 'apply) ,it e ,xs))))
#f)))
(if is-fkn?
is-fkn?
(if (and fast? fast)
- `(#:fastfkn-ref ,fast ',tag)
+ `(#:fastfkn-ref ,fast (,(G 'quote) ,tag))
(aif it (and fast? (fast-ref tag))
- `(#:fast-id ,it ',tag)
- `(#:identifier ',tag))))))
+ `(#:fast-id ,it (,(G 'quote) ,tag))
+ `(#:identifier (,(G 'quote) ,tag)))))))
((#:arglist args)
`(#:apply ,@(get-kwarg vs args)))
@@ -687,14 +687,14 @@
("-=" '-)
("*=" '*)
("/=" '/)
- ("%=" 'modulo)
- ("&=" 'logand)
- ("|=" 'logior)
- ("^=" 'logxor)
- ("**=" 'expt)
+ ("%=" (G 'modulo))
+ ("&=" (G 'logand))
+ ("|=" (G 'logior))
+ ("^=" (G 'logxor))
+ ("**=" (G 'expt))
("<<=" (C '<<))
(">>=" (C '>>))
- ("//=" 'floor-quotient)))
+ ("//=" (G 'floor-quotient))))
(match x
((#:verb x) x)
@@ -765,7 +765,7 @@
(define is-class? (make-fluid #f))
(define (gen-yargs vs x)
- (match (pr 'yarg x) ((#:list args)
+ (match x ((#:list args)
(map (g vs exp) args))))
(define inhibit-finally #f)
@@ -872,6 +872,7 @@
(#:+
(x
(lr+ vs x)))
+
(#:-
(x
(lr+ vs x)))
@@ -926,30 +927,30 @@
(#:not
((_ x)
- (list 'not (list (C 'boolit) (exp vs x)))))
+ (list (G 'not) (list (C 'boolit) (exp vs x)))))
(#:or
((_ . x)
- (cons 'or (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
+ (cons (G 'or) (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
(#:and
((_ . x)
- (cons 'and (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
+ (cons (G 'and) (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
(#:test
((_ e1 #f)
(exp vs e1))
((_ e1 (e2 #f))
- (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (C 'None)))
+ (list (G 'if) (list (C 'boolit) (exp vs e2)) (exp vs e1) (C 'None)))
((_ e1 (e2 e3))
- (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (exp vs e3))))
+ (list (G 'if) (list (C 'boolit) (exp vs e2)) (exp vs e1) (exp vs e3))))
(#:del
;;We don't delete variables
((_ . l)
- `(begin
+ `(,(G 'begin)
,@(let lp ((l l))
(match l
(((#:power #f base () . #f) . l)
@@ -1004,7 +1005,7 @@
,@(if else `((else ,(exp vs else))) '()))))
(#:suite
- ((_ . l) (cons 'begin (map (g vs exp) l))))
+ ((_ . l) (cons (G 'begin) (map (g vs exp) l))))
(#:classdef
((_ class parents code)
@@ -1037,7 +1038,7 @@
,class
,(if parents
(arglist->pkw (clean parents))
- `(,(G 'cons) '() '()))
+ `(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ())))
,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls)
,(wth (exp vs code)))))))))))
(#:verb
@@ -1063,7 +1064,7 @@
(let* ((xl (map (lambda (nm) (exp vs nm)) nm))
(ll `(language python module ,@xl)))
- `(,(C 'use) #t '()
+ `(,(C 'use) #t (,(G 'quote) ())
(,ll
#:select
,(map (lambda (x)
@@ -1087,10 +1088,10 @@
((_ (#:name ((ids ...) . as) ...) ...)
- `(begin
+ `(,(G 'begin)
,@(map
(lambda (ids as)
- `(begin
+ `(,(G 'begin)
,@(map (lambda (ids as)
(let ((path (map (g vs exp) ids)))
(if as
@@ -1102,10 +1103,11 @@
((#:verb
((@ (language python module) import)
((@ (language python module) Module)
- ',(reverse (append
+ (,(G 'quote)
+ ,(reverse (append
'(language python module)
- path))
- ',(reverse path))
+ path)))
+ (,(G 'quote) ,(reverse path)))
,(exp vs as)))))))
(exp
vs
@@ -1115,8 +1117,9 @@
((#:verb
((@ (language python module) import)
((@ (language python module) Module)
- ',(append '(language python module)
- path))
+ (,(G 'quote)
+ ,(append '(language python module)
+ path)))
,(exp vs (car ids)))))))))))
ids as)))
ids as))))
@@ -1147,10 +1150,10 @@
(x (string->symbol x))
(lp (gensym "lp")))
`(,(C 'let/ec) break-ret
- (let ((,v ,(exp vs arg)))
- (let ,lp ((,x 0))
- (if (< ,x ,v)
- (begin
+ (,(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))
(break (break-ret)))
@@ -1161,10 +1164,10 @@
(x (string->symbol x))
(lp (gensym "lp")))
`(,(C 'let/ec) break-ret
- (let ((,v ,(exp vs arg)))
- (let ,lp ((,x 0))
- (if (< ,x ,v)
- (begin
+ (,(G 'let) ((,v ,(exp vs arg)))
+ (,(G 'let) ,lp ((,x 0))
+ (,(G 'if) (< ,x ,v)
+ (,(G 'begin)
(,(C 'with-sp) ((break (break-ret)))
,code2)
(,lp (+ ,x 1))))))))))
@@ -1176,22 +1179,22 @@
(lp (gensym "lp")))
(if p
`(,(C 'let/ec) break-ret
- (let ((,v1 ,(exp vs arg1))
- (,v2 ,(exp vs arg2)))
- (let ,lp ((,x ,v1))
- (if (< ,x ,v2)
- (begin
+ (,(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))
(break (break-ret)))
,code2))
(,lp (+ ,x 1)))))))
`(,(C 'let/ec) break-ret
- (let ((,v1 ,(exp vs arg1))
- (,v2 ,(exp vs arg2)))
- (let ,lp ((,x ,v1))
- (if (< ,x ,v2)
- (begin
+ (,(G 'let) ((,v1 ,(exp vs arg1))
+ (,v2 ,(exp vs arg2)))
+ (,(G 'let) ,lp ((,x ,v1))
+ (,(G 'if) (< ,x ,v2)
+ (,(G 'begin)
(,(C 'with-sp) ((break (break-ret)))
,code2)
(,lp (+ ,x 1))))))))))
@@ -1203,51 +1206,52 @@
(lp (gensym "lp")))
(if p
`(,(C 'let/ec) break-ret
- (let ((,v1 ,(exp vs arg1))
- (,st ,(exp vs arg3))
- (,v2 ,(exp vs arg2)))
- (if (> ,st 0)
- (let ,lp ((,x ,v1))
- (if (< ,x ,v2)
- (begin
+ (,(G 'let) ((,v1 ,(exp vs arg1))
+ (,st ,(exp vs arg3))
+ (,v2 ,(exp vs arg2)))
+ (,(G 'if) (> ,st 0)
+ (,(G 'let) ,lp ((,x ,v1))
+ (,(G 'if) (< ,x ,v2)
+ (,(G 'begin)
(,(C 'let/ec) continue-ret
(,(C 'with-sp)
((continue (,cvalues))
(break (break-ret)))
,code2))
(,lp (+ ,x ,st)))))
- (if (< ,st 0)
- (let ,lp ((,x ,v1))
- (if (> ,x ,v2)
- (begin
+ (,(G 'if) (< ,st 0)
+ (,(G 'let) ,lp ((,x ,v1))
+ (,(G 'if) (> ,x ,v2)
+ (,(G 'begin)
(,(C 'let/ec) continue-ret
(,(C 'with-sp)
((continue (,cvalues))
(break (break-ret)))
,code2))
(,lp (+ ,x ,st)))))
- (error "range with step 0 not allowed")))))
+ (,(G 'error)
+ "range with step 0 not allowed")))))
`(,(C 'let/ec) break-ret
- (let ((,v1 ,(exp vs arg1))
- (,st ,(exp vs arg3))
- (,v2 ,(exp vs arg2)))
- (if (> ,st 0)
- (let ,lp ((,x ,v1))
- (if (< ,x ,v2)
- (begin
+ (,(G 'let) ((,v1 ,(exp vs arg1))
+ (,st ,(exp vs arg3))
+ (,v2 ,(exp vs arg2)))
+ (,(G 'if) (> ,st 0)
+ (,(G 'let) ,lp ((,x ,v1))
+ (,(G 'if) (< ,x ,v2)
+ (,(G 'begin)
(,(C 'with-sp)
((break (break-ret)))
,code2)
(,lp (+ ,x ,st)))))
- (if (< ,st 0)
- (let ,lp ((,x ,v1))
- (if (> ,x ,v2)
- (begin
- (,(C 'with-sp)
- ((break (break-ret)))
- ,code2)
- (,lp (+ ,x ,st)))))
- (error
+ (,(G 'if) (< ,st 0)
+ (,(G 'let) ,lp ((,x ,v1))
+ (,(G 'if) (> ,x ,v2)
+ (,(G 'begin)
+ (,(C 'with-sp)
+ ((break (break-ret)))
+ ,code2)
+ (,lp (+ ,x ,st)))))
+ (,(G 'error)
"range with step 0 not allowed"))))))))
(_ (next)))))
(_ (next))))
@@ -1279,9 +1283,9 @@
(p (is-ec #t code2 #t (list (C 'continue)))))
(if p
`(,(C 'let/ec) break-ret
- (let ,lp ()
- (if (,(C 'boolit) ,(exp vs test))
- (begin
+ (,(G 'let) ,lp ()
+ (,(G 'if) (,(C 'boolit) ,(exp vs test))
+ (,(G 'begin)
(,(C 'let/ec) continue-ret
(,(C 'with-sp) ((continue (,cvalues))
(break (break-ret)))
@@ -1289,9 +1293,9 @@
(,lp)))))
`(,(C 'let/ec) break-ret
- (let ,lp ()
- (if (,(C 'boolit) ,(exp vs test))
- (begin
+ (,(G 'let) ,lp ()
+ (,(G 'if) (,(C 'boolit) ,(exp vs test))
+ (,(G 'begin)
(,(C 'with-sp) ((break (break-ret)))
,code2)
(,lp))))))))
@@ -1302,9 +1306,9 @@
(p (is-ec #t code2 #t (list (C 'continue)))))
(if p
`(,(C 'let/ec) break-ret
- (let ,lp ()
- (if (,(C 'boolit) ,(exp vs test))
- (begin
+ (,(G 'let) ,lp ()
+ (,(G 'if) (,(C 'boolit) ,(exp vs test))
+ (,(G 'begin)
(,(C 'let/ec) ,(C 'continue-ret)
(,(C 'with-sp) ((continue (,cvalues))
(break (break-ret)))
@@ -1312,9 +1316,9 @@
(,lp))
,(exp vs else))))
`(,(C 'let/ec) break-ret
- (let ,lp ()
- (if (,(C 'boolit) ,(exp vs test))
- (begin
+ (,(G 'let) ,lp ()
+ (,(G 'if) (,(C 'boolit) ,(exp vs test))
+ (,(G 'begin)
(,(C 'with-sp) ((break (break-ret)))
,code2)
(,lp))
@@ -1364,8 +1368,8 @@
(let ((o (gensym "o"))
(c (gensym "c")))
`(,(T 'raise)
- (let ((,c ,(exp vs code)))
- (let ((,o (if (,(O 'pyclass?) ,c)
+ (,(G 'let) ((,c ,(exp vs code)))
+ (,(G 'let) ((,o (,(G 'if) (,(O 'pyclass?) ,c)
(,c)
,c)))
(,(O 'set) ,o '__cause__ ,(exp vs from))
@@ -1376,26 +1380,26 @@
((_ (#:from x))
(let ((y (gensym "y"))
(f (gensym "f")))
- `(begin
+ `(,(G 'begin)
(fluid-set! ,(Y 'in-yield) #t)
(,(F 'for) ((,y : ,(exp vs x))) ()
- (let ((,f (scm.yield ,y)))
+ (,(G 'let) ((,f (scm.yield ,y)))
(,f))))))
((_ args)
(let ((f (gensym "f")))
- `(begin
- (fluid-set! ,(Y 'in-yield) #t)
- (let ((,f (scm.yield ,@(gen-yargs vs args))))
+ `(,(G 'begin)
+ (,(G 'fluid-set!) ,(Y 'in-yield) #t)
+ (,(G 'let) ((,f (scm.yield ,@(gen-yargs vs args))))
(,f)))))
((_ f args)
(let ((f (gen-yield (exp vs f)))
(g (gensym "f")))
- `(begin
+ `(,(G 'begin)
(set! ,(C 'inhibit-finally) #t)
- (let ((,g (,f ,@(gen-yargs vs args))))
+ (,(G 'let) ((,g (,f ,@(gen-yargs vs args))))
(,g))))))
(#:def
@@ -1444,7 +1448,7 @@
(,(C 'def-wrap) ,y? ,f ,ab
(,(D 'lam) ,aa
(,(C 'with-return) ,r
- ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
+ ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(with-fluids ((return r))
(wth (exp ns code)))))))))))
@@ -1453,7 +1457,7 @@
(,(C 'def-decor) ,decor
(,(D 'lam) ,aa
(,(C 'with-return) ,r
- ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
+ ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(with-fluids ((return r))
(wth (exp ns code)))))))))))
@@ -1464,7 +1468,7 @@
(,(C 'def-wrap) ,y? ,f ,ab
(,(D 'lam) ,aa
(,(C 'with-return) ,r
- (let ,(map (lambda (x) (list x #f)) ls)
+ (,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(with-fluids ((return r))
(mk
@@ -1473,7 +1477,7 @@
(,(C 'def-decor) ,decor
(,(D 'lam) ,aa
(,(C 'with-return) ,r
- (let ,(map (lambda (x) (list x #f)) ls)
+ (,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(with-fluids ((return r))
(wth (exp ns code)))))))))))))))
@@ -1485,14 +1489,14 @@
(#:list
((_ x (and e (#:cfor . _)))
(let ((l (gensym "l")))
- `(let ((,l (,(L 'to-pylist) '())))
+ `(,(G 'let) ((,l (,(L 'to-pylist) (,(G 'quote) ()))))
,(gen-sel vs e `(,(L 'pylist-append!) ,l ,(exp vs x)))
,l)))
((_ . l)
(list (L 'to-pylist) (let lp ((l l))
(match l
- ((or () #f) ''())
+ ((or () #f) `(,(G 'quote) ()))
(((#:starexpr #:power #f (#:list . l) . _) . _)
(lp l))
(((#:starexpr #:power #f (#:tuple . l) . _) . _)
@@ -1500,18 +1504,18 @@
(((#:starexpr . l) . _)
`(,(L 'to-list) ,(exp vs l)))
((x . l)
- `(cons ,(exp vs x) ,(lp l))))))))
+ `(,(G 'cons) ,(exp vs x) ,(lp l))))))))
(#:tuple
((_ x (and e (#:cfor . _)))
(let ((l (gensym "l")))
- `(let ((,l '()))
- ,(gen-sel vs e `(set! ,l (cons ,(exp vs x) ,l)))
- (reverse ,l))))
+ `(,(G 'let) ((,l (,(G 'quote) ())))
+ ,(gen-sel vs e `(set! ,l (,(G 'cons) ,(exp vs x) ,l)))
+ (,(G 'reverse) ,l))))
((_ . l)
(let lp ((l l))
(match l
- (() ''())
+ (() `(,(G 'quote) ()))
(((#:starexpr #:power #f (#:list . l) . _) . _)
(lp l))
(((#:starexpr #:power #f (#:tuple . l) . _) . _)
@@ -1519,7 +1523,7 @@
(((#:starexpr . l) . _)
`(,(L 'to-list) ,(exp vs l)))
((x . l)
- `(cons ,(exp vs x) ,(lp l)))))))
+ `(,(G 'cons) ,(exp vs x) ,(lp l)))))))
(#:lambdef
((_ (#:var-args-list . v) e)
@@ -1544,7 +1548,7 @@
((_ a (#:assign b c . u))
(let ((z (gensym "x")))
- `(let ((,z ,(exp vs `(#:expr-stmt1 ,b (#:assign ,c . ,u)))))
+ `(,(G 'let) ((,z ,(exp vs `(#:expr-stmt1 ,b (#:assign ,c . ,u)))))
,(exp vs `(#:expr-stmt ,a (#:assign ((#:verb ,z))))))))
((_ l type)
@@ -1561,10 +1565,10 @@
(cond
((= (length l) (length u))
(if (= (length l) 1)
- `(begin
+ `(,(G 'begin)
,(make-set vs op (car l) (exp vs (car u)))
(,cvalues))
- `(begin
+ `(,(G 'begin)
,@(map (lambda (l u) (make-set vs op l u))
l
(map (g vs exp) u))
@@ -1574,22 +1578,22 @@
(let ((vars (map (lambda (x) (gensym "v")) l))
(q (gensym "q"))
(f (gensym "f")))
- `(begin
+ `(,(G 'begin)
(call-with-values (lambda () ,(exp vs (car u)))
- (letrec ((,f
- (case-lambda
- ((,q)
- (if (pair? ,q)
- (apply ,f ,q)
- (apply ,f (,(L 'to-list) ,q))))
- (,vars
- ,@(map (lambda (l v) (make-set vs op l v))
- l vars)))))
- ,f))
+ (,(G 'letrec) ((,f
+ (case-lambda
+ ((,q)
+ (,(G 'if) (pair? ,q)
+ (,(G 'apply) ,f ,q)
+ (,(G 'apply) ,f (,(L 'to-list) ,q))))
+ (,vars
+ ,@(map (lambda (l v) (make-set vs op l v))
+ l vars)))))
+ ,f))
(,cvalues))))
((and (= (length l) 1) (not op))
- `(begin
+ `(,(G 'begin)
,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
(,cvalues)))))))
@@ -1601,16 +1605,17 @@
(#:assert
((_ x f n m)
- `(if (,(G 'not) (,(G 'and) ,@(map (lambda (x) `(,(C 'boolit) ,(exp vs x)))
+ `(,(G 'if)
+ (,(G 'not) (,(G 'and) ,@(map (lambda (x) `(,(C 'boolit) ,(exp vs x)))
x)))
- (,(C 'raise) ,(C 'AssertionError) ',f ,n ,m))))
+ (,(C 'raise) ,(C 'AssertionError) ',f ,n ,m))))
(#:expr-stmt1
((_ a (#:assign b c . u))
(let ((z (gensym "x")))
- `(let ((,z ,(exp vs `(#:expr-stmt1 ,b
+ `(,(G 'let) ((,z ,(exp vs `(#:expr-stmt1 ,b
(#:assign ,c . ,u)))))
,(exp vs `(#:expr-stmt1 ,a (#:assign ((#:verb ,z))))))))
@@ -1628,10 +1633,10 @@
(cond
((= (length l) (length u))
(if (= (length l) 1)
- `(begin
+ `(,(G 'begin)
,(make-set vs op (car l) (exp vs (car u)))
,(exp vs (car l)))
- `(begin
+ `(,(G 'begin)
,@(map (lambda (l u) (make-set vs op l u))
l
(map (g vs exp) u))
@@ -1641,14 +1646,14 @@
(let ((vars (map (lambda (x) (gensym "v")) l))
(q (gensym "q"))
(f (gensym "f")))
- `(begin
+ `(,(G 'begin)
(call-with-values (lambda () ,(exp vs (car u)))
- (letrec ((,f
+ (,(G 'letrec) ((,f
(case-lambda
((,q)
- (if (pair? ,q)
- (apply ,f ,q)
- (apply ,f (,(L 'to-list) ,q))))
+ (,(G 'if) (pair? ,q)
+ (,(G 'apply) ,f ,q)
+ (,(G 'apply) ,f (,(L 'to-list) ,q))))
(,vars
,@(map (lambda (l v) (make-set vs op l v))
l vars)))))
@@ -1656,7 +1661,7 @@
(,cvalues ,@(map (g exp vs) l)))))
((and (= (length l) 1) (not op))
- `(begin
+ `(,(G 'begin)
,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
(,cvalues ,(exp vs (car l))))))))))
@@ -1673,13 +1678,13 @@
((_ (#:e k . v) (and e (#:cfor . _)))
(let ((dict (gensym "dict")))
- `(let ((,dict (,(Di 'make-py-hashtable))))
+ `(,(G 'let) ((,dict (,(Di 'make-py-hashtable))))
,(gen-sel vs e `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
,dict)))
((_ (#:e k . v) ...)
(let ((dict (gensym "dict")))
- `(let ((,dict (,(Di 'make-py-hashtable))))
+ `(,(G 'let) ((,dict (,(Di 'make-py-hashtable))))
,@(map (lambda (k v)
`(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
k v)
@@ -1687,13 +1692,13 @@
((_ k (and e (#:cfor . _)))
(let ((dict (gensym "dict")))
- `(let ((,dict (,(Se 'set))))
+ `(,(G 'let) ((,dict (,(Se 'set))))
,(gen-sel vs e `((,(O 'ref) ,dict 'add) ,(exp vs k)))
,dict)))
((_ k ...)
(let ((set (gensym "dict")))
- `(let ((,set (,(Se 'set))))
+ `(,(G 'let) ((,set (,(Se 'set))))
,@(map (lambda (k)
`((,(O 'ref) ,set 'add) ,(exp vs k)))
k)
@@ -1709,13 +1714,13 @@
((_ x (op . y) . l)
(let ((m (gensym "op")))
- `(let ((,m ,(exp vs y)))
- (and ,(tr-comp op (exp vs x) m)
- ,(exp vs `(#:comp (#:verb ,m) . ,l))))))))
+ `(,(G 'let) ((,m ,(exp vs y)))
+ (,(G 'and) ,(tr-comp op (exp vs x) m)
+ ,(exp vs `(#:comp (#:verb ,m) . ,l))))))))
(define (exp vs x)
- (match (pr x)
+ (match x
((e)
(exp vs e))
((tag . l)
@@ -1725,7 +1730,7 @@
(#:True #t)
(#:None (E 'None))
- (#:null ''())
+ (#:null `(,(G 'quote) ()))
(#:False #f)
(#:pass `(,cvalues))
(#:break
@@ -1753,10 +1758,17 @@
arglist))
`((,(G 'define-module) (language python module ,@args)
+ #:pure
+ #:use-module ((guile) #:select
+ (@ @@ pk let* lambda call-with-values case-lambda
+ set! = * + - < <= > >= / pair?
+ syntax-rules let-syntax))
#:use-module (language python module python)
+ #:use-module ((language python compile) #:select (pks))
#:use-module (language python exceptions))
- (define __doc__ #f)
- (define __module__ '(language python module ,@args)))))
+ (,(G 'define) __doc__ #f)
+ (,(G 'define) __module__ (,(G 'quote)
+ (language python module ,@args))))))
(x '())))
(fluid-set! ignore '())
@@ -1771,9 +1783,9 @@
(let* ((globs (get-globals x))
(e (map (g globs exp) x)))
- `(begin
+ `(,(G 'begin)
,@start
- (define ,fnm (make-hash-table))
+ (,(G 'define) ,fnm (,(G 'make-hash-table)))
,@(map (lambda (s)
(if (member s (fluid-ref ignore))
`(,cvalues)
@@ -1792,7 +1804,7 @@
(let* ((globs (get-globals x))
(res (gensym "res"))
(e (map (g globs exp) x)))
- `(begin
+ `(,(G 'begin)
,@start
,@(map (lambda (s)
(if (member s (fluid-ref ignore))
@@ -1849,15 +1861,15 @@
(define (is-ec ret x tail tags)
- (match (pr 'is-ec x)
- (('cond (p a ... b) ...)
+ (match x
+ (((@ (guile) 'cond) (p a ... b) ...)
(or
(or-map (lambda (x) (or-map (lambda (x) (is-ec ret x #f tags)) x))
a)
(or-map (lambda (x) (is-ec ret x tail tags))
b)))
- (('with-self u v a ... b)
+ (((_ _ 'with-self) u v a ... b)
(or
(or-map (lambda (x) (is-ec ret x #f tags)) a)
(is-ec ret b tail tags)))
@@ -1867,12 +1879,12 @@
(or-map (lambda (x) (is-ec ret x #f tags)) a)
(is-ec ret b tail tags)))
- (('begin a ... b)
+ (((@ (guile) 'begin) a ... b)
(or
(or-map (lambda (x) (is-ec ret x #f tags)) a)
(is-ec ret b tail tags)))
- (('let lp ((y x) ...) a ... b) (=> next)
+ (((@ (guile) 'let) lp ((y x) ...) a ... b) (=> next)
(if (symbol? lp)
(or
(or-map (lambda (x) (is-ec ret x #f tags)) x)
@@ -1880,7 +1892,7 @@
(is-ec ret b tail tags))
(next)))
- (('let ((y x) ...) a ... b)
+ (((@ (guile) 'let) ((y x) ...) a ... b)
(or
(or-map (lambda (x) (is-ec ret x #f tags)) x)
(or-map (lambda (x) (is-ec ret x #f tags)) a)
@@ -1892,16 +1904,16 @@
(or-map (lambda (x) (is-ec ret x #f tags)) a)
(is-ec ret b tail tags)))
- (('define . _)
+ (((@ (guile) 'define) . _)
#f)
- (('if p a b)
+ (((@ (guile) 'if) p a b)
(or
(is-ec ret p #f tags)
(is-ec ret a tail tags)
(is-ec ret b tail tags)))
- (('if p a)
+ (((@ (guile) 'if) p a)
(or
(is-ec ret #'p #f tags)
(is-ec ret #'a tail tags)))
@@ -1920,42 +1932,63 @@
(define-syntax with-return
(lambda (x)
(define (analyze ret x)
- (syntax-case x (begin let if let-syntax)
- ((cond (p a ... b) ...)
- (equal? (syntax->datum #'cond)
+ (syntax-case x (let-syntax @)
+ ((cond- (p a ... b) ...)
+ (equal? (syntax->datum #'cond-)
'(@ (guile) cond))
(with-syntax (((bb ...) (map (lambda (x) (analyze ret x)) #'(b ...))))
#'(cond (p a ... bb) ...)))
- ((with-self u v a ... b)
- (equal? (syntax->datum #'with-self)
+
+ (((_ _ with-self-) u v a ... b)
+ (equal? (syntax->datum #'with-self-)
'(@@ (language python compile) with-self))
#`(with-self u v a ... #,(analyze ret #'b)))
+
((let-syntax v a ... b)
#`(let-syntax v a ... #,(analyze ret #'b)))
- ((begin a ... b)
+
+ (((@ (guile) begin-) a ... b)
+ (equal? (syntax->datum #'begin-)
+ 'begin)
#`(begin a ... #,(analyze ret #'b)))
- ((let lp v a ... b)
- (symbol? (syntax->datum #'lp))
+
+ (((@ (guile) let-) lp v a ... b)
+ (and
+ (equal? (syntax->datum #'let-)
+ 'let)
+ (symbol? (syntax->datum #'lp)))
#`(let lp v a ... #,(analyze ret #'b)))
- ((let v a ... b)
+
+ (((@ (guile) let-) v a ... b)
+ (equal? (syntax->datum #'let-)
+ 'let)
#`(let v a ... #,(analyze ret #'b)))
- ((if p a b)
+
+ (((@ (guile) if-) p a b)
+ (equal? (syntax->datum #'if-)
+ 'if)
#`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
- ((if p a)
+
+ (((@ (guile) if-) p a)
+ (equal? (syntax->datum #'if-)
+ 'if)
#`(if p #,(analyze ret #'a)))
+
((return a b ...)
(equal? (syntax->datum #'return) (syntax->datum ret))
(if (eq? #'(b ...) '())
#'a
#`(values a b ...)))
+
((return)
(equal? (syntax->datum #'return) (syntax->datum ret))
- #`(values))
+ #`(values))
+
(x #'x)))
(define (is-ec ret x tail)
- (syntax-case x (let-syntax begin let let* if define @@)
- ((cond (p a ... b) ...)
+ (syntax-case x (let-syntax with-self let* @@ @)
+ (((@ (guile) cond) (p a ... b) ...)
(equal? (syntax->datum #'cond)
'(@ (guile) cond))
(or
@@ -1964,7 +1997,7 @@
(or-map (lambda (x) (is-ec ret x tail))
#'(b ...))))
- ((with-self u v a ... b)
+ (((_ _ with-self) u v a ... b)
(equal? (syntax->datum #'with-self)
'(@@ (language python compile) with-self))
(or
@@ -1977,21 +2010,27 @@
(or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
(is-ec ret #'b tail)))
- ((begin a ... b)
- #t
+ (((@ (guile) begin) a ... b)
+ (equal? (syntax->datum #'begin)
+ 'begin)
(or
(or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
(is-ec ret #'b tail)))
- ((let lp ((y x) ...) a ... b)
- (symbol? (syntax->datum #'lp))
+ (((@ (guile) let) lp ((y x) ...) a ... b)
+ (and
+ (equal? (syntax->datum #'let)
+ 'let)
+ (symbol? (syntax->datum #'lp)))
(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)))
- ((let ((y x) ...) a ... b)
- #t
+ (((@ (guile) let) ((y x) ...) a ... b)
+ (equal? (syntax->datum #'let)
+ 'let)
+
(or
(or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
(or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
@@ -2004,19 +2043,22 @@
(or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
(is-ec ret #'b tail)))
- ((define . _)
- #t
+ (((@ (guile) define) . _)
+ (equal? (syntax->datum #'define)
+ 'define)
#f)
- ((if p a b)
- #t
+ (((@ (guile) if) p a b)
+ (equal? (syntax->datum #'if)
+ 'if)
(or
(is-ec ret #'p #f)
(is-ec ret #'a tail)
(is-ec ret #'b tail)))
- ((if p a)
- #t
+ (((@ (guile) if) p a)
+ (equal? (syntax->datum #'if)
+ 'if)
(or
(is-ec ret #'p #f)
(is-ec ret #'a tail)))
@@ -2376,11 +2418,9 @@
(lambda (x)
(syntax-case x ()
((_ #f f ab x)
- (pr 'def-wrap #'f 'false)
#'x)
((_ #t f ab code)
- (pr 'def-wrap #'f 'true)
#'(lambda x
(define obj (make <yield>))
(define ab (make-prompt-tag))
@@ -2585,3 +2625,8 @@
((_ '() v) (values))
((_ x v)
(define! 'x v))))
+
+(define-syntax pks
+ (lambda (x)
+ (pk (syntax->datum x))
+ #f))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-20 05:30:45 +0000