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.scm233
1 files changed, 128 insertions, 105 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 06e529b..973ae3a 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -43,6 +43,19 @@
(define-inlinable (H x) `(@ (language python hash) ,x))
(define-inlinable (W x) `(@ (language python with) ,x))
+(define (mk/ec x) x)
+
+(define-syntax-rule (let/ecx c a ...)
+ (let/ec c a ...))
+
+(define-syntax-rule (let/ect c a ...)
+ (let/ec c ((mk/ec (lambda (c) a ...)) c)))
+
+(eval-when (compile eval load)
+ (if (equal? (effective-version) "3.0")
+ (module-set! (current-module) 'let/ecx
+ (module-ref (current-module) 'let/ect))))
+
(define exit-prompt (make-prompt-tag))
(define exit-fluid (make-fluid #f))
@@ -1454,13 +1467,13 @@
(let ((v (gensym "v"))
(x (string->symbol x))
(lp (gensym "lp")))
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(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))
+ (,(C 'let/ecx) continue-ret
+ (,(C 'with-sp) ((continue (continue-ret))
(break (break-ret)))
,code2))
(,lp (+ ,x 1))))))))
@@ -1468,7 +1481,7 @@
(let ((v (gensym "v"))
(x (string->symbol x))
(lp (gensym "lp")))
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(G 'let) ((,v ,(exp vs arg)))
(,(G 'let) ,lp ((,x 0))
(,(G 'if) (< ,x ,v)
@@ -1483,18 +1496,18 @@
(x (string->symbol x))
(lp (gensym "lp")))
(if p
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(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))
+ (,(C 'let/ecx) continue-ret
+ (,(C 'with-sp) ((continue (continue-ret))
(break (break-ret)))
,code2))
(,lp (+ ,x 1)))))))
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(G 'let) ((,v1 ,(exp vs arg1))
(,v2 ,(exp vs arg2)))
(,(G 'let) ,lp ((,x ,v1))
@@ -1510,7 +1523,7 @@
(x (string->symbol x))
(lp (gensym "lp")))
(if p
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(G 'let) ((,v1 ,(exp vs arg1))
(,st ,(exp vs arg3))
(,v2 ,(exp vs arg2)))
@@ -1518,9 +1531,9 @@
(,(G 'let) ,lp ((,x ,v1))
(,(G 'if) (< ,x ,v2)
(,(G 'begin)
- (,(C 'let/ec) continue-ret
+ (,(C 'let/ecx) continue-ret
(,(C 'with-sp)
- ((continue (,cvalues))
+ ((continue (continue-ret))
(break (break-ret)))
,code2))
(,lp (+ ,x ,st)))))
@@ -1528,15 +1541,15 @@
(,(G 'let) ,lp ((,x ,v1))
(,(G 'if) (> ,x ,v2)
(,(G 'begin)
- (,(C 'let/ec) continue-ret
+ (,(C 'let/ecx) continue-ret
(,(C 'with-sp)
- ((continue (,cvalues))
+ ((continue (continue-ret))
(break (break-ret)))
,code2))
(,lp (+ ,x ,st)))))
(,(G 'error)
"range with step 0 not allowed")))))
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(G 'let) ((,v1 ,(exp vs arg1))
(,st ,(exp vs arg3))
(,v2 ,(exp vs arg2)))
@@ -1590,17 +1603,17 @@
(code2 (exp vs code))
(p (is-ec #t code2 #t (list (C 'continue)))))
(if p
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(G 'let) ,lp ()
(,(G 'if) (,(C 'boolit) ,(exp vs test))
(,(G 'begin)
- (,(C 'let/ec) continue-ret
- (,(C 'with-sp) ((continue (,cvalues))
+ (,(C 'let/ecx) continue-ret
+ (,(C 'with-sp) ((continue (continue-ret))
(break (break-ret)))
,code2))
(,lp)))))
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(G 'let) ,lp ()
(,(G 'if) (,(C 'boolit) ,(exp vs test))
(,(G 'begin)
@@ -1613,21 +1626,22 @@
(code2 (exp vs code))
(p (is-ec #t code2 #t (list (C 'continue)))))
(if p
- `(,(C 'let/ec) break-ret
+ `(,(C 'let/ecx) break-ret
(,(G 'let) ,lp ()
(,(G 'if) (,(C 'boolit) ,(exp vs test))
(,(G 'begin)
- (,(C 'let/ec) ,(C 'continue-ret)
- (,(C 'with-sp) ((continue (,cvalues))
+ (,(C 'let/ecx) ,(C 'continue-ret)
+ (,(C 'with-sp) ((continue (continue-ret))
(break (break-ret)))
,code2))
(,lp))
,(exp vs else))))
- `(,(C 'let/ec) break-ret
+
+ `(,(C 'let/ecx) break-ret
(,(G 'let) ,lp ()
(,(G 'if) (,(C 'boolit) ,(exp vs test))
(,(G 'begin)
- (,(C 'with-sp) ((break (break-ret)))
+ (,(C 'with-sp) ((break (break-ret)))
,code2)
(,lp))
,(exp vs else))))))))
@@ -2081,7 +2095,18 @@
(C 'continue))
(x x)))
-(define (comp x)
+(define (comp in x)
+ (define (strit x)
+ (if in
+ x
+ (with-output-to-string
+ (lambda ()
+ (let lp ((x x))
+ (if (pair? x)
+ (begin
+ (format #t "~s~%" (car x))
+ (lp (cdr x)))))))))
+
(define start
(match x
(((#:stmt
@@ -2103,16 +2128,16 @@
(define name (string-join (map symbol->string args) "."))
`((define-module (language python module ,@args)
- #:pure
- #:use-module ((guile) #:select
- (@ @@ pk let* lambda call-with-values case-lambda
- set! = * + - < <= > >= / pair? fluid-set!
- fluid-ref
- syntax-rules let-syntax abort-to-prompt))
- #:use-module (language python module python)
- #:use-module ((language python compile) #:select (pks))
- #:use-module (language python exceptions)
- #:use-module ((oop goops) #:select (<complex> <real> <fraction> <integer> <number>)))
+ #:pure
+ #:use-module ((guile) #:select
+ (@ @@ pk let* lambda call-with-values case-lambda
+ set! = * + - < <= > >= / pair? fluid-set!
+ fluid-ref
+ syntax-rules let-syntax abort-to-prompt))
+ #:use-module (language python module python)
+ #:use-module ((language python compile) #:select (pks))
+ #:use-module (language python exceptions)
+ #:use-module ((oop goops) #:select (<complex> <real> <fraction> <integer> <number>)))
(,(G 'define) __doc__ #f)
(,(G 'define) __name__ ,name)
(,(G 'define) __module__ (,(G 'quote)
@@ -2120,57 +2145,55 @@
(x '())))
(fluid-set! ignore '())
- (pr
- (if (fluid-ref (@@ (system base compile) %in-compile))
- (begin
- (if (fluid-ref (@@ (system base compile) %in-compile))
- (set! s/d (C 'qset!))
- (set! s/d (C 'define-)))
-
- (if (pair? start)
- (set! x (cdr x)))
-
- (let* ((globs (get-globals x))
- (e.doc (with-fluids ((*doc* #f))
- (let ((r (map (g globs exp) x)))
- (cons r (get-doc)))))
- (e (car e.doc))
- (doc (cdr e.doc)))
-
- `(begin
- ,@start
- (,(G 'define) ,fnm (,(G 'make-hash-table)))
- ,@(map (lambda (s)
- (if (member s (fluid-ref ignore))
- `(,cvalues)
- `(,(C 'var) ,s)))
- (cons '__doc__ globs))
- (,(G 'set!) __doc__ ,doc)
- ,@e
- (,(C 'export-all)))))
- (begin
- (if (fluid-ref (@@ (system base compile) %in-compile))
- (set! s/d 'set!)
- (set! s/d (C 'define-)))
+ (strit
+ (pr
+ (if (fluid-ref (@@ (system base compile) %in-compile))
+ (begin
+ (if (fluid-ref (@@ (system base compile) %in-compile))
+ (set! s/d (C 'qset!))
+ (set! s/d (C 'define-)))
+
+ (if (pair? start)
+ (set! x (cdr x)))
+
+ (let* ((globs (get-globals x))
+ (e.doc (with-fluids ((*doc* #f))
+ (let ((r (map (g globs exp) x)))
+ (cons r (get-doc)))))
+ (e (car e.doc))
+ (doc (cdr e.doc)))
+
+ `(,@start
+ (,(G 'define) ,fnm (,(G 'make-hash-table)))
+ ,@(map (lambda (s)
+ (if (member s (fluid-ref ignore))
+ `(,cvalues)
+ `(,(C 'var) ,s)))
+ (cons '__doc__ globs))
+ (,(G 'set!) __doc__ ,doc)
+ ,@e
+ (,(C 'export-all)))))
+
+ (begin
+ (if (fluid-ref (@@ (system base compile) %in-compile))
+ (set! s/d 'set!)
+ (set! s/d (C 'define-)))
- (if (pair? start)
- (set! x (cdr x)))
+ (if (pair? start)
+ (set! x (cdr x)))
- (let* ((globs (get-globals x))
- (res (gensym "res"))
- (e (map (g globs exp) x)))
- `(,(G 'begin)
- ,@start
- ,@(map (lambda (s)
- (if (member s (fluid-ref ignore))
- `(,cvalues)
- `(,(C 'var) ,s))) globs)
- (,(C 'with-exit) ,@e)))))))
-
-
-
-
+ (let* ((globs (get-globals x))
+ (res (gensym "res"))
+ (e (map (g globs exp) x)))
+ `(begin
+ ,@start
+ ,@(map (lambda (s)
+ (if (member s (fluid-ref ignore))
+ `(,cvalues)
+ `(,(C 'var) ,s))) globs)
+ (,(C 'with-exit) ,@e))))))))
+
(define-syntax-parameter break
(lambda (x) #'(values)))
@@ -2435,7 +2458,7 @@
((_ ret l)
(let ((code (analyze #'ret #'l)))
(if (is-ec #'ret #'l #t)
- #`(let/ec ret l)
+ #`(let/ecx ret l)
code))))))
(define void (list 'void))
@@ -2518,7 +2541,7 @@
((_ (x) (a) code #f #f)
(with-syntax ((x (replace_ xx #'x)))
#'(if (pair? a)
- (let/ec break-ret
+ (let/ecx break-ret
(let lp ((l a))
(if (pair? l)
(begin
@@ -2532,11 +2555,11 @@
((_ (x) (a) code #f #t)
(with-syntax ((x (replace_ xx #'x)))
#'(if (pair? a)
- (let/ec break-ret
+ (let/ecx break-ret
(let lp ((l a))
(if (pair? l)
(begin
- (let/ec continue-ret
+ (let/ecx continue-ret
(set! x (car l))
(with-sp ((continue (continue-ret))
(break (break-ret)))
@@ -2547,7 +2570,7 @@
((_ (x) (a) code next #f)
(with-syntax ((x (replace_ xx #'x)))
#'(if (pair? a)
- (let/ec break-ret
+ (let/ecx break-ret
(let lp ((l a))
(if (pair? l)
(begin
@@ -2562,10 +2585,10 @@
((_ (x) (a) code next #t)
(with-syntax ((x (replace_ xx #'x)))
#'(if (pair? a)
- (let/ec break-ret
+ (let/ecx break-ret
(let lp ((l a))
(if (pair? l)
- (let/ec continue-ret
+ (let/ecx continue-ret
(set! x (car l))
(with-sp ((continue (continue-ret))
(break (break-ret)))
@@ -2623,13 +2646,13 @@
#'(let ((inv (wrap-in in)))
(clet (yy ...)
(let lp ()
- (let/ec break-ret
+ (let/ecx break-ret
(catch StopIteration
(lambda ()
(call-with-values (lambda () (next inv))
(clambda (xx ...)
(cset! yy xx) ...
- (let/ec continue-ret
+ (let/ecx continue-ret
(with-sp ((break (break-ret))
(continue (continue-ret)))
code))
@@ -2643,13 +2666,13 @@
#'(let ((inv (wrap-in in)) ...)
(clet (yy ...)
(let lp ()
- (let/ec break-ret
+ (let/ecx break-ret
(catch StopIteration
(lambda ()
(call-with-values (lambda () (values (next inv) ...))
(clambda (xx ...)
(cset! yy xx) ...
- (let/ec continue-ret
+ (let/ecx continue-ret
(with-sp ((break (break-ret))
(continue (continue-ret)))
code))
@@ -2681,14 +2704,14 @@
(if (syntax->datum #'p)
#'(let ((inv (wrap-in in)))
(clet (yy ...)
- (let/ec break-ret
+ (let/ecx break-ret
(catch StopIteration
(lambda ()
(let lp ()
(call-with-values (lambda () (next inv))
(clambda (xx ...)
(cset! yy xx) ...
- (let/ec continue-ret
+ (let/ecx continue-ret
(with-sp ((break (break-ret))
(continue (continue-ret)))
code))
@@ -2697,7 +2720,7 @@
#'(let ((inv (wrap-in in)))
(clet (yy ...)
- (let/ec break-ret
+ (let/ecx break-ret
(catch StopIteration
(lambda ()
(let lp ()
@@ -2718,14 +2741,14 @@
(if (syntax->datum #'p)
#'(clet (yy ...)
(let ((inv (wrap-in in)) ...)
- (let/ec break-ret
+ (let/ecz break-ret
(catch StopIteration
(lambda ()
(let lp ()
(call-with-values (lambda () get)
(clambda (xx ...)
(cset! yy xx) ...
- (let/ec continue-ret
+ (let/ecx continue-ret
(with-sp ((break (break-ret))
(continue (continue-ret)))
code))
@@ -2734,7 +2757,7 @@
#'(clet (yy ...)
(let ((inv (wrap-in in)) ...)
- (let/ec break-ret
+ (let/ecx break-ret
(catch StopIteration
(lambda ()
(let lp ()
@@ -2787,7 +2810,7 @@
(call-with-prompt
ab
(lambda ()
- (let/ec return
+ (let/ecx return
(apply code x))
(slot-set! obj 'closed #t)
(throw StopIteration))
@@ -2960,11 +2983,11 @@
(if (module-defined? mod '__all__)
(begin
(module-export! mod
- (for ((x : (module-ref mod '__all__))) ((l '()))
- (let ((x (string->symbol (scm-str x))))
- (if (module-locally-bound? mod x)
- (cons x l)
- l))
+ (for ((x : (module-ref mod '__all__))) ((l '()))
+ (let ((x (string->symbol (scm-str x))))
+ (if (module-locally-bound? mod x)
+ (cons x l)
+ l))
#:final l))
(module-re-export! mod
(for ((x : (module-ref mod '__all__))) ((l '()))
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-18 20:23:45 +0000