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.scm320
1 files changed, 219 insertions, 101 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 170cb11..0b3b872 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -41,6 +41,11 @@
(define-inlinable (H x) `(@ (language python hash) ,x))
(define-inlinable (W x) `(@ (language python with) ,x))
+(define-syntax-rule (use a ...)
+ (catch #t
+ (lambda () (use-modules a ...))
+ (lambda x (raise (ImportError '(a ...))))))
+
(define s/d 'set!)
(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))"))
@@ -119,8 +124,13 @@
(match e
(#f item)
((#:cfor for-e in-e cont)
- `(,(F 'for) ((,@(map (g vs exp) for-e) : ,(exp vs in-e))) ()
- ,(gen-sel vs cont item)))
+ (let lp ((for-e for-e))
+ (match for-e
+ (((#:power #f (#:tuple . l) . _))
+ (lp l))
+ (_
+ `(,(F 'for) ((,@(map (g vs exp) for-e) : ,(exp vs in-e))) ()
+ ,(gen-sel vs cont item))))))
((#:cif cif cont)
`(if ,(exp vs cif)
,(gen-sel vs cont item)))))
@@ -217,6 +227,23 @@
'()
l)
vs))
+
+ ((#:expr-stmt l (#:assign k . u))
+ (union
+ (union (fold (lambda (x s)
+ (match x
+ ((#:test (#:power v2 v1 () . _) . _)
+ (if v2
+ (union
+ (union (list (exp '() v1))
+ (list (exp '() v2)))
+ s)
+ (union (list (exp '() v1)) s)))
+ (_ s)))
+ '()
+ l)
+ vs)
+ (scope `(#:expr-stmt ,k (#:asignvs . ,u)) vs)))
((x . y)
(scope y (scope x vs)))
@@ -425,11 +452,17 @@
(()
'()))))
-(define (get-args_ vs arg)
+(define (getarg x)
+ (match x
+ ((#:tp x . l)
+ x)
+ (x x)))
+
+(define (get-args_ vs arg)
(let lp ((arg arg))
(match arg
(((#:arg x) . arg)
- (cons (exp vs (car x))
+ (cons (exp vs (getarg x))
(lp arg)))
((x . args)
(lp args))
@@ -441,7 +474,7 @@
(let lp ((arg arg))
(match arg
(((#:= x v) . arg)
- (cons (list '= (exp vs (car x)) (exp vs v))
+ (cons (list '= (exp vs (getarg x)) (exp vs v))
(lp arg)))
((x . args)
@@ -454,7 +487,7 @@
(let lp ((arg arg))
(match arg
(((#:* x) . arg)
- (cons (list '* (exp vs (car x)))
+ (cons (list '* (exp vs (getarg x)))
(lp arg)))
((x . args)
@@ -467,7 +500,7 @@
(let lp ((arg arg))
(match arg
(((#:** x) . arg)
- (cons (list '** (exp vs (car x)))
+ (cons (list '** (exp vs (getarg x)))
(lp arg)))
((x . args)
@@ -570,6 +603,7 @@
("//=" 'floor-quotient)))
(match x
+ ((#:verb x) x)
((#:test (#:power kind v addings . _) . _)
(let* ((v (exp vs v))
(v.add (if (is-prefix? v)
@@ -661,6 +695,18 @@
...))
+(define (tr-comp op x y)
+ (match op
+ ((or "<" ">" "<=" ">=")
+ (list (G (string->symbol op)) x y))
+ ("!=" (list (G 'not) (list (O 'equal?) x y)))
+ ("==" (list (O 'equal?) x y))
+ ("is" (list (G 'eq?) x y))
+ ("isnot" (list (G 'not) (list (G 'eq?) x y)))
+ ("in" (list (L 'in) x y))
+ ("notin" (list (G 'not) (list (L 'in) x y)))
+ ("<>" (list (G 'not) (list (O 'equal?) x y)))))
+
(gen-table x vs
(#:power
((_ _ (x) () . #f)
@@ -869,7 +915,7 @@
`(,(G 'cons) '() '()))
,(map (lambda (x) `(define ,x #f)) ls)
,(exp vs code))))))))))
-(#:verb
+ (#:verb
((_ x) x))
(#:scm
@@ -877,17 +923,17 @@
(#:import
((_ (#:from (() . nm) . #f))
- `(use-modules (language python module ,@(map (lambda (nm) (exp vs nm))
+ `(,(C 'use) (language python module ,@(map (lambda (nm) (exp vs nm))
nm))))
- ((_ (#:from (() . nm) . l))
- `(use-modules ((language python module ,@(map (lambda (nm) (exp vs nm))
+ ((_ (#:from (() . nm) l))
+ `(,(C 'use) ((language python module ,@(map (lambda (nm) (exp vs nm))
nm))
- #:select ,(map (lambda (x)
- (match x
- ((a . #f)
- (exp vs a))
- ((a . b)
- (cons (exp vs a) (exp vs b)))))
+ #:select ,(map (lambda (x)
+ (match x
+ ((a . #f)
+ (exp vs a))
+ ((a . b)
+ (cons (exp vs a) (exp vs b)))))
l))))
@@ -923,71 +969,80 @@
(#:for
((_ e in code . #f)
(=> next)
- (match e
- (((#:power #f (#:identifier x . _) () . #f))
- (match in
- (((#:test power . _))
- (match power
- ((#:power #f
- (#:identifier "range" . _)
- ((#:arglist arglist . _))
- . _)
- (match arglist
- ((arg)
- (let ((v (gensym "v"))
- (x (string->symbol x))
- (lp (gensym "lp")))
- `(let ((,v ,(exp vs arg)))
- (let ,lp ((,x 0))
- (if (< ,x ,v)
- (begin
- ,(exp vs code)
- (,lp (+ ,x 1))))))))
- ((arg1 arg2)
- (let ((v1 (gensym "va"))
- (v2 (gensym "vb"))
- (lp (gensym "lp")))
- `(let ((,v1 ,(exp vs arg1))
- (,v2 ,(exp vs arg2)))
- (let ,lp ((,x ,v1))
- (if (< ,x ,v2)
- (begin
- ,(exp vs code)
- (,lp (+ ,x 1))))))))
- ((arg1 arg2 arg3)
- (let ((v1 (gensym "va"))
- (v2 (gensym "vb"))
- (st (gensym "vs"))
- (lp (gensym "lp")))
- `(let ((,v1 ,(exp vs arg1))
- (,st ,(exp vs arg2))
- (,v2 ,(exp vs arg3)))
- (if (> st 0)
- (let ,lp ((,x ,v1))
- (if (< ,x ,v2)
- (begin
- ,(exp vs code)
- (,lp (+ ,x ,st)))))
- (if (< st 0)
- (let ,lp ((,x ,v1))
- (if (> ,x ,v2)
- (begin
- ,(exp vs code)
- (,lp (+ ,x ,st)))))
- (error "range with step 0 not allowed"))))))
- (_ (next))))
- (_ (next))))
- (_ (next))))
- (_ (next))))
+ (let lp ((e e))
+ (match e
+ (((#:power #f (#:tuple . l) . _))
+ (lp l))
+
+ (((#:power #f (#:identifier x . _) () . #f))
+ (match in
+ (((#:test power . _))
+ (match power
+ ((#:power #f
+ (#:identifier "range" . _)
+ ((#:arglist arglist . _))
+ . _)
+ (match arglist
+ ((arg)
+ (let ((v (gensym "v"))
+ (x (string->symbol x))
+ (lp (gensym "lp")))
+ `(let ((,v ,(exp vs arg)))
+ (let ,lp ((,x 0))
+ (if (< ,x ,v)
+ (begin
+ ,(exp vs code)
+ (,lp (+ ,x 1))))))))
+ ((arg1 arg2)
+ (let ((v1 (gensym "va"))
+ (v2 (gensym "vb"))
+ (lp (gensym "lp")))
+ `(let ((,v1 ,(exp vs arg1))
+ (,v2 ,(exp vs arg2)))
+ (let ,lp ((,x ,v1))
+ (if (< ,x ,v2)
+ (begin
+ ,(exp vs code)
+ (,lp (+ ,x 1))))))))
+ ((arg1 arg2 arg3)
+ (let ((v1 (gensym "va"))
+ (v2 (gensym "vb"))
+ (st (gensym "vs"))
+ (lp (gensym "lp")))
+ `(let ((,v1 ,(exp vs arg1))
+ (,st ,(exp vs arg2))
+ (,v2 ,(exp vs arg3)))
+ (if (> st 0)
+ (let ,lp ((,x ,v1))
+ (if (< ,x ,v2)
+ (begin
+ ,(exp vs code)
+ (,lp (+ ,x ,st)))))
+ (if (< st 0)
+ (let ,lp ((,x ,v1))
+ (if (> ,x ,v2)
+ (begin
+ ,(exp vs code)
+ (,lp (+ ,x ,st)))))
+ (error "range with step 0 not allowed"))))))
+ (_ (next))))
+ (_ (next))))
+ (_ (next))))
+ (_ (next)))))
((_ es in code . else)
- (let* ((es2 (map (g vs exp) es))
- (vs2 (union es2 vs))
- (code2 (exp vs2 code))
- (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
- (else2 (if else (exp vs2 else) #f))
- (in2 (map (g vs exp) in)))
- (list (C 'cfor) es2 in2 code2 else2 p))))
+ (let lp ((es es))
+ (match es
+ (((#:power #f (#:tuple . l) . _))
+ (lp l))
+ (_
+ (let* ((es2 (map (g vs exp) es))
+ (vs2 (union es2 vs))
+ (code2 (exp vs2 code))
+ (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
+ (else2 (if else (exp vs2 else) #f))
+ (in2 (map (g vs exp) in)))
+ (list (C 'cfor) es2 in2 code2 else2 p)))))))
(#:while
@@ -1016,11 +1071,11 @@
((_ x exc else . fin)
- `(,(T 'try) ,(exp vs x)
+ `(,(T 'try) (lambda () ,(exp vs x))
,@(let lp ((exc exc) (r (if else (exp vs else) '())))
(match exc
((((test . #f) code) . exc)
- (lp exc (cons `(#:except ,(exp vs code)) r)))
+ (lp exc (cons `(#:except ,(exp vs test) ,(exp vs code)) r)))
(((#f code) . exc)
(lp exc (cons `(#:except ,(exp vs code)) r)))
@@ -1075,7 +1130,7 @@
(set! ,(C 'inhibit-finally) #t)
(let ((,g (,f ,@(gen-yargs vs args))))
(,g))))))
-
+
(#:def
((_ f
(#:types-args-list . args)
@@ -1199,8 +1254,12 @@
`(cons ,(exp vs x) ,(lp l)))))))
(#:lambdef
- ((_ v e)
- (list `lambda v (exp vs e))))
+ ((_ (#:var-args-list . v) e)
+ (let ((as (get-args_ vs v))
+ (a= (get-args= vs v))
+ (a* (get-args* vs v))
+ (** (get-args** vs v)))
+ (list (C `lam) `(,@as ,@a* ,@a= ,@**) (exp vs e)))))
(#:stmt
((_ l)
@@ -1214,7 +1273,12 @@
(if (= (length l) 1)
(car l)
`(,(G 'values) ,@l))))
-
+
+ ((_ l (#:assign x y . u))
+ (let ((z (gensym "x")))
+ `(let ((,x ,(exp vs `(#:expr-stmt1 ((#:verb ,z)) (#:assign ,y . ,u)))))
+ ,(exp vs `(#:expr-stmt ,x (#:assign ((#:verb ,z))))))))
+
((_ l type)
(=> fail)
(call-with-values
@@ -1273,6 +1337,61 @@
x)))
(,(C 'raise) ,(C 'AssertionError) ',f ,n ,m))))
+
+
+ (#:expr-stmt1
+ ((_ l (#:assign x y . u))
+ (let ((z (gensym "x")))
+ `(let ((,x ,(exp vs `(#:expr-stmt1 ((#:verb ,z))
+ (#:assign ,y . ,u)))))
+ ,(exp vs `(#:expr-stmt ,x (#:assign ((#:verb ,z))))))))
+
+ ((_ l type)
+ (=> fail)
+ (call-with-values
+ (lambda () (match type
+ ((#:assign u)
+ (values #f u))
+ ((#:augassign op u)
+ (values op u))
+ (_ (fail))))
+
+ (lambda (op u)
+ (cond
+ ((= (length l) (length u))
+ (if (= (length l) 1)
+ `(begin
+ ,(make-set vs op (car l) (exp vs (car u)))
+ ,(exp vs (car l)))
+ `(begin
+ @,(map (lambda (l u) (make-set vs op l u))
+ l
+ (map (g vs exp) u))
+ (values ,@(map (g exp vs) l)))))
+
+ ((and (= (length u) 1) (not op))
+ (let ((vars (map (lambda (x) (gensym "v")) l))
+ (q (gensym "q"))
+ (f (gensym "f")))
+ `(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))
+ (values ,@(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))))))))))
+
(#:return
((_ x)
(if x
@@ -1318,18 +1437,14 @@
(exp vs x))
((_ x (op . y))
- (define (tr op x y)
- (match op
- ((or "<" ">" "<=" ">=")
- (list (G (string->symbol op)) x y))
- ("!=" (list (G 'not) (list (O 'equal?) x y)))
- ("==" (list (O 'equal?) x y))
- ("is" (list (G 'eq?) x y))
- ("isnot" (list (G 'not) (list (G 'eq?) x y)))
- ("in" (list (L 'in) x y))
- ("notin" (list (G 'not) (list (L 'in) x y)))
- ("<>" (list (G 'not) (list (O 'equal?) x y)))))
- (tr op (exp vs x) (exp vs y)))))
+ (tr-comp op (exp vs x) (exp vs y)))
+
+ ((_ 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))))))))
+
(define (exp vs x)
(match (pr x)
@@ -1372,7 +1487,8 @@
arglist))
`((,(G 'define-module) (language python module ,@args)
- #:use-module (language python module python))
+ #:use-module (language python module python)
+ #:use-module (language python exceptions))
(define __doc__ #f)
(define __module__ '(language python module ,@args)))))
(x '())))
@@ -1936,6 +2052,8 @@
(define (export-all)
(define mod (current-module))
(if (module-defined? mod '__all__)
- (for ((x : (module-ref mod '__all__))) ()
- (module-export! mod (string->symbol (scm-str x))))))
+ (module-export! mod
+ (for ((x : (module-ref mod '__all__))) ((l '()))
+ (cons (string->symbol (scm-str x)) l)
+ #:final l))))
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-19 03:35:39 +0000