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.scm150
1 files changed, 121 insertions, 29 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 5f27706..300985e 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -43,6 +43,14 @@
(define-inlinable (H x) `(@ (language python hash) ,x))
(define-inlinable (W x) `(@ (language python with) ,x))
+(define-syntax-rule (wth code)
+ (let ((old s/d))
+ (set! s/d (C 'qset!))
+ (let ((r code))
+ (set! s/d old)
+ r)))
+
+
(define-syntax-rule (use a ...)
(catch #t
(lambda () (use-modules a ...))
@@ -52,7 +60,23 @@
(define level (make-fluid 0))
-(define s/d 'set!)
+(define (flat x)
+ (let lp ((x (list x)))
+ (if (pair? x)
+ (let ((e (car x)))
+ (if (pair? e)
+ (let ((ee (car e)))
+ (if (equal? ee 'cons)
+ (append (lp (list (cadr e)))
+ (lp (list (caddr e)))
+ (lp (cdr x)))
+ (lp (cdr x))))
+ (if (symbol? e)
+ (cons e (lp (cdr x)))
+ '())))
+ '())))
+
+(define s/d (C 'qset!))
(define (pre) (warn "Patching guile will lead to way better experience use 'python.patch' on guile-2.2 e.g. (use-modules (language python guilemod))"))
@@ -206,10 +230,10 @@
((#:test (#:power v2 v1 () . _) . _)
(if v2
(union
- (union (list (exp '() v1))
- (list (exp '() v2)))
+ (union (flat (exp '() v1))
+ (flat (exp '() v2)))
s)
- (union (list (exp '() v1)) s)))
+ (union (flat (exp '() v1)) s)))
(_ s)))
'()
l)))
@@ -241,10 +265,10 @@
((#:test (#:power v2 v1 () . _) . _)
(if v2
(union
- (union (list (exp '() v1))
- (list (exp '() v2)))
+ (union (flat (exp '() v1))
+ (flat (exp '() v2)))
s)
- (union (list (exp '() v1)) s)))
+ (union (flat (exp '() v1)) s)))
(_ s)))
'()
l)
@@ -254,7 +278,9 @@
((x . y)
(scope y (scope x vs)))
(_ vs)))
-
+
+(define ignore (make-fluid '()))
+
(define (defs x vs)
(match x
((#:def (#:identifier f) . _)
@@ -926,7 +952,7 @@
(arglist->pkw (clean parents))
`(,(G 'cons) '() '()))
,(map (lambda (x) `(define ,x #f)) ls)
- ,(exp vs code))))))))))
+ ,(wth (exp vs code)))))))))))
(#:verb
((_ x) x))
@@ -944,10 +970,15 @@
(match x
((a . #f)
(let ((s (exp vs a)))
+ (fluid-set! ignore
+ (cons s (fluid-ref ignore)))
s))
((a . b)
(let ((s (exp vs a)))
+ (fluid-set! ignore
+ (cons (exp vs b)
+ (fluid-ref ignore)))
(cons s (exp vs b))))))
l))))
@@ -1206,7 +1237,7 @@
,(mk `(let ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(with-fluids ((return r))
- (exp ns code))))))))))
+ (wth (exp ns code)))))))))))
`(set! ,f
(,(C 'def-decor) ,decor
@@ -1215,7 +1246,7 @@
,(mk `(let ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(with-fluids ((return r))
- (exp ns code))))))))))
+ (wth (exp ns code)))))))))))
(if y?
`(set! ,f
@@ -1227,7 +1258,7 @@
(,(C 'with-self) ,c? ,aa
,(with-fluids ((return r))
(mk
- (exp ns code))))))))))
+ (wth (exp ns code)))))))))))
`(set! ,f
(,(C 'def-decor) ,decor
(,(D 'lam) ,aa
@@ -1235,7 +1266,7 @@
(let ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(with-fluids ((return r))
- (exp ns code))))))))))))))
+ (wth (exp ns code)))))))))))))))
(#:global
((_ . _)
@@ -1493,8 +1524,6 @@
(C 'continue))
(x x)))
-(define-syntax-rule (define- n x) (define! 'n x))
-
(define (comp x)
(define start
(match x
@@ -1519,24 +1548,29 @@
(define __doc__ #f)
(define __module__ '(language python module ,@args)))))
(x '())))
-
+
+ (fluid-set! ignore '())
(if (fluid-ref (@@ (system base compile) %in-compile))
(begin
(if (fluid-ref (@@ (system base compile) %in-compile))
- (set! s/d 'set!)
+ (set! s/d (C 'qset!))
(set! s/d (C 'define-)))
(if (pair? start)
(set! x (cdr x)))
- (let ((globs (get-globals x)))
+ (let* ((globs (get-globals x))
+ (e (map (g globs exp) x)))
`(begin
,@start
,(C 'clear-warning-data)
(fluid-set! (@@ (system base message) %dont-warn-list) '())
(define ,fnm (make-hash-table))
- ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
- ,@(map (g globs exp) x)
+ ,@(map (lambda (s)
+ (if (member s (fluid-ref ignore))
+ `(values)
+ `(,(C 'var) ,s))) globs)
+ ,@e
(,(C 'export-all)))))
(begin
(if (fluid-ref (@@ (system base compile) %in-compile))
@@ -1546,14 +1580,18 @@
(if (pair? start)
(set! x (cdr x)))
- (let ((globs (get-globals x))
- (res (gensym "res")))
+ (let* ((globs (get-globals x))
+ (res (gensym "res"))
+ (e (map (g globs exp) x)))
`(begin
,@start
,(C 'clear-warning-data)
(fluid-set! (@@ (system base message) %dont-warn-list) '())
- ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
- ,@(map (g globs exp) x))))))
+ ,@(map (lambda (s)
+ (if (member s (fluid-ref ignore))
+ `(values)
+ `(,(C 'var) ,s))) globs)
+ ,@e)))))
@@ -1644,7 +1682,16 @@
(define-syntax with-return
(lambda (x)
(define (analyze ret x)
- (syntax-case x (begin let if)
+ (syntax-case x (begin let if let-syntax cond)
+ ((cond (p a ... b) ...)
+ (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)
+ '(@@ (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)
#`(begin a ... #,(analyze ret #'b)))
((let lp v a ... b)
@@ -1664,7 +1711,30 @@
(x #'x)))
(define (is-ec ret x tail)
- (syntax-case x (begin let if define @@)
+ (syntax-case x (let-syntax begin let if define @@ cond)
+ ((cond (p a ... b) ...)
+ (pk 'cond)
+ (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)
+ '(@@ (language python compile) with-self))
+ (begin
+ (pk 'with-self)
+ (or
+ (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
+ (is-ec ret #'b tail))))
+
+ ((let-syntax v a ... b)
+ (pk 'let-syntax)
+ (or
+ (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
+ (is-ec ret #'b tail)))
+
((begin a ... b)
#t
(or
@@ -1723,7 +1793,11 @@
(define-syntax var
(lambda (x)
- (syntax-case x ()
+ (syntax-case x (cons quote)
+ ((_ '())
+ #'(values))
+ ((_ (cons x v))
+ #'(begin (var x) (var v)))
((_ v)
(begin
(dont-warn (syntax->datum #'v))
@@ -1773,11 +1847,9 @@
#'(if (pair? a)
(let/ec break-ret
(let lp ((l a))
- (pk 'l l)
(if (pair? l)
(begin
(set! x (car l))
- (pk 'x x)
(with-sp ((continue (values))
(break (break-ret)))
code)
@@ -2185,3 +2257,23 @@
(cons (string->symbol (scm-str x)) l)
#:final l))))
+(define-syntax qset!
+ (syntax-rules (cons quote)
+ ((_ (cons x y) v)
+ (let ((w v))
+ (qset! x (car w))
+ (qset! y (cdr w))))
+ ((_ '() v) (values))
+ ((_ x v)
+ (set! x v))))
+
+(define-syntax define-
+ (syntax-rules (cons quote)
+ ((_ (cons x y) v)
+ (let ((w v))
+ (define- x (car w))
+ (define- y (cdr w))))
+ ((_ '() v) (values))
+ ((_ x v)
+ (define! 'x v))))
+
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-18 18:26:23 +0000