diff options
Diffstat (limited to 'modules/language/python')
-rw-r--r-- | modules/language/python/compile.scm | 333 | ||||
-rw-r--r-- | modules/language/python/parser.scm | 20 | ||||
-rw-r--r-- | modules/language/python/spec.scm | 12 |
3 files changed, 270 insertions, 95 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))) - - diff --git a/modules/language/python/parser.scm b/modules/language/python/parser.scm index 55c0d2d..55fc02e 100644 --- a/modules/language/python/parser.scm +++ b/modules/language/python/parser.scm @@ -590,12 +590,12 @@ (set! test (f-or! 'test - (f-list #:test - (Ds or_test) - (ff? (f-list - (f-seq "if" (Ds or_test)) - (f-seq "else" test)))) - (Ds lambdef))) + (f-list #:test + (Ds or_test) + (ff? (f-list + (f-seq "if" (Ds or_test)) + (f-seq "else" test)))) + (Ds lambdef))) (define test_nocond (f-or 'nocond (Ds or_test) (Ds lambdef_nocond))) @@ -709,9 +709,9 @@ mk-id)) (set! power - (p-freeze 'power - (f-cons 'power #:power - (f-cons (Ds atom) + (p-freeze 'power + (f-cons 'power #:power + (f-cons (f-or (f-list #:f (Ds identifier) ":" (Ds atom)) (Ds atom)) (f-cons (ff* (Ds trailer)) (f-or! (f-seq "**" factor) FALSE)))) @@ -721,7 +721,7 @@ (f-or! 'trailer (f-seq "(" (ff? (Ds arglist)) ")") (f-seq "[" (Ds subscriptlist) "]") - (f-seq "." identifier))) + (f-seq (f-list #:dot (ff+ "." identifier)))) (set! atom (p-freeze 'atom diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm index 1389165..c22c0b4 100644 --- a/modules/language/python/spec.scm +++ b/modules/language/python/spec.scm @@ -1,5 +1,5 @@ (define-module (language python spec) - #:use-module (language python parser) + #:use-module (parser stis-parser lang python3-parser) #:use-module (language python compile) #:use-module (rnrs io ports) #:use-module (ice-9 pretty-print) @@ -14,7 +14,13 @@ ;;; Language definition ;;; -(define (pr . x) (pretty-print x) (car (reverse x))) +(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) (car (reverse x)))) + (close port) + (car (reverse x))) (define (c x) (pr (comp (pr (p (pr x)))))) (define (cc port x) @@ -33,7 +39,7 @@ (lambda () ;; Ideally we'd duplicate the whole module hierarchy so that `set!', ;; `fluid-set!', etc. don't have any effect in the current environment. - (let ((m (make-fresh-user-module))) + (let ((m (make-fresh-user-module))) ;; Provide a separate `current-reader' fluid so that ;; compile-time changes to `current-reader' are ;; limited to the current compilation unit. |