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.scm333
1 files changed, 251 insertions, 82 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index d634d1b..7ffe57a 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -3,15 +3,28 @@
#:use-module (ice-9 pretty-print)
#:export (comp))
-(define (p x) (pretty-print (syntax->datum x)) x)
+(define (fold f init l)
+ (if (pair? l)
+ (fold f (f (car l) init) (cdr l))
+ init))
+
+(define (pr . x)
+ (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
+ (with-output-to-port port
+ (lambda ()
+ (pretty-print x)))
+ (close port)
+ (car (reverse x)))
+
(define (pf x)
- (define port (open-file "compile.log" "a"))
+ (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
(with-output-to-port port
(lambda () (pretty-print (syntax->datum x)) x))
(close port)
x)
(define (C x) `(@@ (language python compile) ,x))
+(define (O x) `(@@ (oop pf-objects) ,x))
(define (G x) `(@ (guile) ,x))
(define (union as vs)
@@ -49,7 +62,7 @@
((#:global . l)
(let lp ((l l) (vs vs))
(match l
- (((#:identifier v) . l)
+ (((#:identifier v . _) . l)
(let ((s (string->symbol v)))
(if (member s vs)
(lp l vs)
@@ -62,15 +75,15 @@
(define (scope x vs)
(match x
- ((#:def (#:identifier f) . _)
+ ((#:def (#:identifier f . _) . _)
(union (list (string->symbol f)) vs))
((#:lambdef . _)
vs)
- ((#:class . _)
+ ((#:classdef . _)
vs)
((#:global . _)
vs)
- ((#:identifier v)
+ ((#:identifier v . _)
(let ((s (string->symbol v)))
(if (member s vs)
vs
@@ -81,7 +94,7 @@
(define (defs x vs)
(match x
- ((#:def (#:identifier f) . _)
+ ((#:def (#:identifier f . _) . _)
(union (list (string->symbol f)) vs))
((#:lambdef . _)
vs)
@@ -98,12 +111,50 @@
(define return (make-fluid 'error-return))
+(define (make-set vs x u)
+ (match x
+ ((#:test (#:power (#:identifier v . _) addings . _) . _)
+ (let ((v (string->symbol v)))
+ (if (null? addings)
+ `(set! ,v ,u)
+ (let* ((rev (reverse addings))
+ (las (car rev))
+ (new (reverse (cdr rev))))
+ `(,(O 'set) ,(let lp ((v v) (new new))
+ (match new
+ ((x . new)
+ (lp `(,(O 'ref) ,v ,(exp vs x)) ',new))
+ (() v)))
+ ',(exp vs las) ,u)))))))
+
+
+
(define (exp vs x)
- (match (p x)
- ((#:power (#:identifier x) () . #f)
+ (match (pr x)
+ ((#:power x () . #f)
+ (exp vs x))
+
+ ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
+ ((#:power vf ((and trailer (#:identifier _ . _)) ...
+ (#:arglist (args ...) #f #f)) . #f)
+ (let ((args (map (g vs exp) args)))
+ (match vf
+ ((#:f (#:identifier f . _) e)
+ (let ((obj (gensym "obj"))
+ (l (gensym "l")))
+ '(call-with-values (lambda () (fcall (,(exp vs e)
+ ,@(map (g vd exp) trailer))
+ ,@args))
+ (lambda (,obj . ,l)
+ `(set! ,(string->symbol f) ,obj)
+ (apply 'values ,l)))))
+ (x
+ `(,(C 'call) (,(exp vs x) ,@(map (g vs exp) trailer)) ,@args)))))
+
+ ((#:identifier x . _)
(string->symbol x))
- ((#:power x () . #f)
+ ((#:string x)
x)
(((and x (or #:+ #:- #:* #:/)) . l)
@@ -129,12 +180,18 @@
((#:and . x)
(cons 'and (map (g vs exp) x)))
-
+
((#:test e1 #f)
(exp vs e1))
((#:test e1 e2 e3)
(list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
+
+ ((#:if test a ((tests . as) ...) . else)
+ `(,(G 'cond)
+ (,(exp vs test) ,(exp vs a))
+ ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
+ ,@(if else `((else ,(exp vs else))) '())))
((#:suite . l) (cons 'begin (map (g vs exp) l)))
@@ -152,47 +209,119 @@
,(exp vs code)
(,lp))))))
- ((#:for exp in code #f)
- (match (cons exp in)
- ((((#:power (#:identifier x) #f . #f)) .
- ((#:power (#:identifier 'range) ((arg) #f #f) . #f)))
- (let ((v (gensym "v"))
- (lp (gensym "lp")))
- `(let ((,v ,(exp arg)))
- (let ,lp ((,x 0))
- (if (< ,x ,v)
- (begin
- ,(exp vs code)
- (,lp (+ ,x 1))))))))
-
- ((((#:power (#:identifier x) #f . #f)) .
- ((#:power (#:identifier 'range) ((arg1 arg2) #f #f) . #f)))
- (let ((v1 (gensym "va"))
- (v2 (gensym "vb"))
- (lp (gensym "lp")))
- `(let ((,v1 ,(exp arg1))
- (,v2 ,(exp arg2)))
- (let ,lp ((,x ,v1))
- (if (< ,x ,v2)
- (begin
- ,(exp vs code)
- (,lp (+ ,x 1))))))))
-
- ((((#:power (#:identifier x) #f . #f)) .
- ((#:power (#:identifier 'range) ((arg1 arg2 arg3) #f #f) . #f)))
- (let ((v1 (gensym "va"))
- (v2 (gensym "vb"))
- (st (gensym "vs"))
- (lp (gensym "lp")))
- `(let ((,v1 ,(exp arg1))
- (,st ,(exp arg2))
- (,v2 ,(exp arg3)))
- (let ,lp ((,x ,v1))
- (if (< ,x ,v2)
- (begin
- ,(exp vs code)
- (,lp (+ ,x ,st))))))))))
-
+ ((#:classdef (#:identifier class . _) parents defs)
+ (let ()
+ (define (filt l)
+ (reverse
+ (fold (lambda (x s)
+ (match x
+ (((or 'fast 'functional)) s)
+ (x (cons x s))))
+ '() l)))
+ (define (is-functional l)
+ (fold (lambda (x pred)
+ (if pred
+ pred
+ (match x
+ (('functional) #t)
+ (_ #f)))) #f l))
+ (define (is-fast l)
+ (fold (lambda (x pred)
+ (if pred
+ pred
+ (match x
+ (('fast) #t)
+ (_ #f)))) #f l))
+
+
+ (let* ((class (string->symbol class))
+ (parents (match parents
+ (#f
+ '())
+ ((#:arglist args . _)
+ (map (g vs exp) args))))
+ (is-func (is-functional parents))
+ (is-fast (is-fast parents))
+ (kind (if is-func
+ (if is-fast
+ 'mk-pf-class
+ 'mk-pyf-class)
+ (if is-fast
+ 'mk-p-class
+ 'mk-py-class)))
+ (parents (filt parents)))
+ `(define ,class (,(O 'wrap)
+ (,(O kind)
+ ,class
+ ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
+ #:const
+ ,(match (exp vs defs)
+ ((begin . l)
+ l)
+ (l l))
+ #:dynamic
+ ()))))))
+
+
+
+ ((#:for e in code . #f)
+ (=> next)
+ (match e
+ (((#:power (#:identifier x . _) () . #f))
+ (match in
+ (((#:test power . _))
+ (match power
+ ((#:power
+ (#: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))))
((#:while test code else)
(let ((lp (gensym "lp")))
@@ -201,7 +330,7 @@
(begin
,(exp vs code)
(,lp))
- ,(exp else)))))
+ ,(exp vs else)))))
((#:try x exc else fin)
(define (f x)
@@ -221,27 +350,27 @@
(lp `(catch ,(exp vs e)
(lambda () ,code)
(lambda ,(gensym "x")
- ,(exp c))) l))
+ ,(exp vs c))) l))
((((e . as) c) . l)
(lp `(let ((,as ,(exp vs e)))
(catch ,as
(lambda () ,code)
(lambda ,(gensym "x")
- ,(exp vs c))) l)))
+ ,(exp vs c)))) l))
(()
code))))
(lambda () ,(exp vs fin)))))
- ((#:def (#:identifier f)
+ ((#:def (#:identifier f . _)
(#:types-args-list
args
- #f)
+ #f #f)
#f
code)
(let* ((f (string->symbol f))
(r (gensym "return"))
(as (map (lambda (x) (match x
- ((((#:identifier x) . #f) #f)
+ ((((#:identifier x . _) . #f) #f)
(string->symbol x))))
args))
(vs (union as vs))
@@ -249,11 +378,12 @@
(df (defs code '()))
(ls (diff (diff ns vs) df)))
- `(define (,f ,@as) (,(C 'with-return) ,r
- (let ,(map (lambda (x) (list x #f)) ls)
- ,(with-fluids ((return r))
- (exp ns code)))))))
-
+ `(define ,f (lambda (,@as)
+ (,(C 'with-return) ,r
+ (let ,(map (lambda (x) (list x #f)) ls)
+ ,(with-fluids ((return r))
+ (exp ns code))))))))
+
((#:global . _)
'(values))
@@ -269,21 +399,35 @@
((#:expr-stmt (l) (#:assign))
(exp vs l))
+ ((#:expr-stmt l (#:assign u))
+ (cond
+ ((= (length l) (length u))
+ (cons 'begin (map make-set (map (lambda x vs) l) l (map (g vs exp) u))))
+ ((= (length u) 1)
+ (let ((vars (map (lambda (x) (gensym "v")) l)))
+ `(call-with-values (lambda () (exp vs (car u)))
+ (lambda vars
+ ,@(map make-set l vars)))))))
+
+
+
((#:return . x)
`(,(fluid-ref return) ,@(map (g vs exp) x)))
((#:expr-stmt
- ((#:test (#:power (#:identifier v) () . #f) #f))
+ ((#:test (#:power (#:identifier v . _) () . #f) #f))
(#:assign (l)))
(let ((s (string->symbol v)))
`(set! ,s ,(exp vs l))))
-
- ((#:comp . l)
+ ((#:comp x #f)
+ (exp vs x))
+
+ ((#:comp x (op . y))
(define (tr op x y)
(match op
((or "<" ">" "<=" ">=")
- (list (string->symbol op) x y))
+ (list (G (string->symbol op)) x y))
("!=" (list 'not (list 'equal? x y)))
("==" (list 'equal? x y))
("is" (list 'eq? x y))
@@ -291,19 +435,37 @@
("in" (list 'member x y))
("notin" (list 'not (list 'member x y)))
("<>" (list 'not (list 'equal? x y)))))
- (let lp ((l l))
- (match l
- (()
- '())
- ((x op y)
- (tr op (exp vs x) (exp vs y)))
- ((x op . l)
- (tr op (exp vs x) (lp vs l))))))))
+ (tr op (exp vs x) (exp vs y)))
+
+ (x x)))
(define (comp x)
+ (define start
+ (match (pr 'start x)
+ (((#:stmt
+ ((#:expr-stmt
+ ((#:test
+ (#:power
+ (#:identifier "module" . _)
+ ((#:arglist arglist #f #f))
+ . #f) #f))
+ (#:assign)))) . _)
+ (let ()
+ (define args
+ (map (lambda (x)
+ (exp '() x))
+ arglist))
+
+ `((,(G 'define-module) (language python module ,@args)))))
+ (x '())))
+
+ (if (pair? start)
+ (set! x (cdr x)))
+
(let ((globs (get-globals x)))
`(begin
- ,@(map (lambda (s) `(define ,s (values))) globs)
+ ,@start
+ ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
,@(map (g globs exp) x))))
(define-syntax with-return
@@ -376,10 +538,17 @@
(syntax-case x ()
((_ ret l)
- (pf (let ((code (analyze #'ret #'l)))
- (if (is-ec #'ret #'l #t)
- #`(let/ec ret #,code)
- code)))))))
+ (let ((code (analyze #'ret #'l)))
+ (if (is-ec #'ret #'l #t)
+ #`(let/ec ret #,code)
+ code))))))
+
+(define-syntax call
+ (syntax-rules ()
+ ((_ (f) . l) (f . l))))
+
+(define-syntax-rule (var v)
+ (if (defined? 'v)
+ (values)
+ (define! 'v #f)))
-
-
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-20 10:31:59 +0000