From 1753337bd7acdf5c0290b082a115df5f560a0e3b Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Sun, 8 Apr 2018 21:30:12 +0200 Subject: compiles to bytecode, fails to load --- modules/language/python/compile.scm | 171 +++++++++++++++++++----------------- 1 file changed, 92 insertions(+), 79 deletions(-) (limited to 'modules/language/python/compile.scm') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index a039ee1..e5bc219 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -178,13 +178,22 @@ ((#:lambdef . _) vs) + + ((#:with (l ...) code) + (scope code (union vs + (let lp ((l l)) + (match l + (((a b) . l) + (cons (exp '() b) (lp l))) + ((x . l) (lp l)) + (() '())))))) ((#:classdef f . _) (union (list (exp '() f)) vs)) ((#:global . _) vs) - + ((#:import (#:name ((ids ...) . as)) ...) (let lp ((ids ids) (as as) (vs vs)) (if (pair? as) @@ -445,7 +454,7 @@ (let lp ((arg arg)) (match arg (((#:* x) . arg) - (cons (exp vs (car x)) + (cons (list '* (exp vs (car x))) (lp arg))) ((x . args) @@ -458,7 +467,7 @@ (let lp ((arg arg)) (match arg (((#:** x) . arg) - (cons (exp vs (car x)) + (cons (list '** (exp vs (car x))) (lp arg))) ((x . args) @@ -635,23 +644,6 @@ ,(if op `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u) u))))))))) - -(define (filter-defs x) - (match (let lp ((x x)) - (match x - ((('begin . l)) - (lp (cons 'begin l))) - (('begin . l) - (let lp ((l l)) - (match l - ((('values) . l) - (lp l)) - ((x . l) - (cons x (lp l))) - (x x)))))) - (('begin) - '()) - (x x))) (define is-class? (make-fluid #f)) (define (gen-yargs vs x) @@ -813,12 +805,31 @@ (#:with ((_ (l ...) code) - (let ((l (map (lambda (x) - (match x - ((a b) (list (exp vs a) (exp vs b))) - ((b) (list (exp vs b))))) - l))) - `(,(W 'with) ,l ,(exp vs code))))) + (let* ((l (map (lambda (x) + (match x + ((a b) (list (exp vs b) (gensym "as") (exp vs a))) + ((b) (list (exp vs b))))) + l)) + (vs (union vs (let lp ((l l)) + (match l + (((x) . l) (lp l)) + (((a b c) . l) (cons a (lp l))) + (() '())))))) + + (define (f x) + (match x + ((a b c) (list 'set! a b)) + ((a) (list (G 'values))))) + + (define (g x) + (match x + ((a b c) (list b c)) + ((a) (list a)))) + + `(,(W 'with) ,(map g l) + (,(G 'begin) + ,@(map f l) + ,(exp vs code)))))) (#:if ((_ test a ((tests . as) ...) . else) @@ -832,34 +843,33 @@ ((_ . l) (cons 'begin (map (g vs exp) l)))) (#:classdef - ((_ class parents defs) + ((_ class parents code) (with-fluids ((is-class? #t)) (let () (let* ((decor (let ((r (fluid-ref decorations))) (fluid-set! decorations '()) - r)) + r)) (class (exp vs class)) + (vs (union (list class) vs)) + (ns (scope code vs)) + (ls (diff ns vs)) + (parents (match parents (() #f) (#f #f) ((#:arglist . _) (get-addings vs (list parents)))))) - `(define ,class + `(set! ,class (,(C 'class-decor) ,decor (,(C 'with-class) ,class - (,(C 'mk-p-class) + (,(C 'mk-p-class2) ,class ,(if parents `(,(C 'ref-x) ,(C 'arglist->pkw) ,@parents) `(,(G 'cons) '() '())) - ,@(match (filter-defs (exp vs defs)) - (('begin . l) - l) - ((('begin . l)) - l) - (l l))))))))))) - - (#:verb + ,(map (lambda (x) `(define ,x #f)) ls) + ,(exp vs code)))))))))) +(#:verb ((_ x) x)) (#:scm @@ -977,7 +987,7 @@ (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 'for) es2 in2 code2 else2 p)))) + (list (C 'cfor) es2 in2 code2 else2 p)))) (#:while @@ -1074,7 +1084,7 @@ (let* ((decor (let ((r (fluid-ref decorations))) (fluid-set! decorations '()) r)) - (args (get-args_ vs args)) + (arg_ (get-args_ vs args)) (arg= (get-args= vs args)) (dd= (map cadr arg=)) (c? (fluid-ref is-class?)) @@ -1093,7 +1103,7 @@ (y 'scm.yield) (y.f (gen-yield f)) (ls (diff (diff ns vs) df))) - + (define (mk code) `(let-syntax ((,y (syntax-rules () ((_ . args) @@ -1106,19 +1116,19 @@ (with-fluids ((is-class? #f)) (if c? (if y? - `(define ,f + `(set! ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) + (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args ,(with-fluids ((return r)) (exp ns code)))))))))) - `(define ,f + `(set! ,f (,(C 'def-decor) ,decor - (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) + (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1126,19 +1136,19 @@ (exp ns code)))))))))) (if y? - `(define ,f + `(set! ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) + (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args ,(with-fluids ((return r)) (mk (exp ns code)))))))))) - `(define ,f + `(set! ,f (,(C 'def-decor) ,decor - (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) + (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1345,24 +1355,26 @@ (define (comp x) (define start - (match (pr 'start x) + (match x (((#:stmt ((#:expr-stmt ((#:test (#:power #f (#:identifier "module" . _) - ((#:arglist arglist #f #f)) + ((#:arglist arglist)) . #f) #f)) - (#:assign)))) . _) + (#:assign)))) . rest) + (let () (define args (map (lambda (x) (exp '() x)) arglist)) - `((,(G 'define-module) - (language python module ,@args) - #:use-module (language python module python))))) + `((,(G 'define-module) (language python module ,@args) + #:use-module (language python module python)) + (define __doc__ #f) + (define __module__ '(language python module ,@args))))) (x '()))) (if (fluid-ref (@@ (system base compile) %in-compile)) @@ -1570,7 +1582,7 @@ (define (gentemp stx) (datum->syntax stx (gensym "x"))) -(define-syntax for +(define-syntax cfor (syntax-rules () ((_ (x) (a) code #f #f) (if (pair? a) @@ -1804,29 +1816,30 @@ obj))))) (define-syntax ref-x - (syntax-rules () - ((_ v) - v) - ((_ v (#:fastfkn-ref f _) . l) - (ref-x (lambda x (if (py-class? v) (apply f x) (apply f v x))) . l)) - ((_ v (#:fast-id f _) . l) - (ref-x (f v) . l)) - ((_ v (#:identifier x) . l) - (ref-x (ref v x) . l)) - ((_ v (#:identifier x) . l) - (ref-x (ref v x) . l)) - ((_ v (#:call-obj x) . l) - (ref-x (x v) . l)) - ((_ v (#:call x ...) . l) - (ref-x (v x ...) . l)) - ((_ v (#:apply x ...) . l) - (ref-x (py-apply v x ...) . l)) - ((_ v (#:apply x ...) . l) - (ref-x (py-apply v x ...) . l)) - ((_ v (#:vecref x) . l) - (ref-x (pylist-ref v x) . l)) - ((_ v (#:vecsub . x) . l) - (ref-x (pylist-slice v . x) . l)))) + (lambda (x) + (syntax-case x () + ((_ v) + #'v) + ((_ v (#:fastfkn-ref f _) . l) + #'(ref-x (lambda x (if (py-class? v) (apply f x) (apply f v x))) . l)) + ((_ v (#:fast-id f _) . l) + #'(ref-x (f v) . l)) + ((_ v (#:identifier x) . l) + #'(ref-x (ref v x) . l)) + ((_ v (#:identifier x) . l) + #'(ref-x (ref v x) . l)) + ((_ v (#:call-obj x) . l) + #'(ref-x (x v) . l)) + ((_ v (#:call x ...) . l) + #'(ref-x (v x ...) . l)) + ((_ v (#:apply x ...) . l) + #'(ref-x (py-apply v x ...) . l)) + ((_ v (#:apply x ...) . l) + #'(ref-x (py-apply v x ...) . l)) + ((_ v (#:vecref x) . l) + #'(ref-x (pylist-ref v x) . l)) + ((_ v (#:vecsub . x) . l) + #'(ref-x (pylist-slice v . x) . l))))) (define-syntax del-x (syntax-rules () -- cgit v1.2.3