summaryrefslogtreecommitdiff
path: root/modules/language/python
diff options
context:
space:
mode:
Diffstat (limited to 'modules/language/python')
-rw-r--r--modules/language/python/compile.scm385
-rw-r--r--modules/language/python/parser.scm17
-rw-r--r--modules/language/python/spec.scm48
3 files changed, 445 insertions, 5 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
new file mode 100644
index 0000000..d634d1b
--- /dev/null
+++ b/modules/language/python/compile.scm
@@ -0,0 +1,385 @@
+(define-module (language python compile)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:export (comp))
+
+(define (p x) (pretty-print (syntax->datum x)) x)
+(define (pf x)
+ (define port (open-file "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 (G x) `(@ (guile) ,x))
+
+(define (union as vs)
+ (let lp ((as as) (vs vs))
+ (match as
+ ((x . as)
+ (if (member x vs)
+ (lp as vs)
+ (lp as (cons x vs))))
+ (()
+ vs))))
+
+(define (diff as vs)
+ (let lp ((as as) (rs '()))
+ (match as
+ ((x . as)
+ (if (member x vs)
+ (lp as rs)
+ (lp as (cons x rs))))
+ (()
+ rs))))
+
+(define (get-globals code)
+ (let lp ((vs (glob code '())) (rs (scope code '())))
+ (match vs
+ ((x . l)
+ (if (member x rs)
+ (lp l rs)
+ (lp l (cons x rs))))
+ (()
+ rs))))
+
+(define (glob x vs)
+ (match x
+ ((#:global . l)
+ (let lp ((l l) (vs vs))
+ (match l
+ (((#:identifier v) . l)
+ (let ((s (string->symbol v)))
+ (if (member s vs)
+ (lp l vs)
+ (lp l (cons s vs)))))
+ (()
+ vs))))
+ ((x . y)
+ (glob y (glob x vs)))
+ (x vs)))
+
+(define (scope x vs)
+ (match x
+ ((#:def (#:identifier f) . _)
+ (union (list (string->symbol f)) vs))
+ ((#:lambdef . _)
+ vs)
+ ((#:class . _)
+ vs)
+ ((#:global . _)
+ vs)
+ ((#:identifier v)
+ (let ((s (string->symbol v)))
+ (if (member s vs)
+ vs
+ (cons s vs))))
+ ((x . y)
+ (scope y (scope x vs)))
+ (_ vs)))
+
+(define (defs x vs)
+ (match x
+ ((#:def (#:identifier f) . _)
+ (union (list (string->symbol f)) vs))
+ ((#:lambdef . _)
+ vs)
+ ((#:class . _)
+ vs)
+ ((#:global . _)
+ vs)
+ ((x . y)
+ (defs y (defs x vs)))
+ (_ vs)))
+
+(define (g vs e)
+ (lambda (x) (e vs x)))
+
+(define return (make-fluid 'error-return))
+
+(define (exp vs x)
+ (match (p x)
+ ((#:power (#:identifier x) () . #f)
+ (string->symbol x))
+
+ ((#:power x () . #f)
+ x)
+
+ (((and x (or #:+ #:- #:* #:/)) . l)
+ (cons (keyword->symbol x) (map (g vs exp) l)))
+
+ ((#:u~ x)
+ (list 'lognot (exp vs x)))
+
+ ((#:band . l)
+ (cons 'logand (map (g vs exp) l)))
+
+ ((#:bxor . l)
+ (cons 'logxor (map (g vs exp) l)))
+
+ ((#:bor . l)
+ (cons 'logior (map (g vs exp) l)))
+
+ ((#:not x)
+ (list 'not (exp vs x)))
+
+ ((#:or . x)
+ (cons 'or (map (g vs exp) x)))
+
+ ((#: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)))
+
+ ((#:suite . l) (cons 'begin (map (g vs exp) l)))
+
+ ((#:try x #f #f fin)
+ `(dynamic-wind
+ (lambda () #f)
+ (lambda () ,(exp vs x))
+ (lambda () ,(exp vs fin))))
+
+ ((#:while test code #f)
+ (let ((lp (gensym "lp")))
+ `(let ,lp ()
+ (if test
+ (begin
+ ,(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))))))))))
+
+
+ ((#:while test code else)
+ (let ((lp (gensym "lp")))
+ `(let ,lp ()
+ (if test
+ (begin
+ ,(exp vs code)
+ (,lp))
+ ,(exp else)))))
+
+ ((#:try x exc else fin)
+ (define (f x)
+ (match else
+ ((#f x)
+ `(catch #t
+ (lambda () ,x)
+ (lambda ,(gensym "x") ,(exp vs x))))))
+
+ `(dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ ,(f
+ (let lp ((code (exp vs x)) (l (reverse exc)))
+ (match l
+ ((((e) c) . l)
+ (lp `(catch ,(exp vs e)
+ (lambda () ,code)
+ (lambda ,(gensym "x")
+ ,(exp c))) l))
+ ((((e . as) c) . l)
+ (lp `(let ((,as ,(exp vs e)))
+ (catch ,as
+ (lambda () ,code)
+ (lambda ,(gensym "x")
+ ,(exp vs c))) l)))
+ (()
+ code))))
+ (lambda () ,(exp vs fin)))))
+
+ ((#:def (#:identifier f)
+ (#:types-args-list
+ args
+ #f)
+ #f
+ code)
+ (let* ((f (string->symbol f))
+ (r (gensym "return"))
+ (as (map (lambda (x) (match x
+ ((((#:identifier x) . #f) #f)
+ (string->symbol x))))
+ args))
+ (vs (union as vs))
+ (ns (scope code vs))
+ (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)))))))
+
+ ((#:global . _)
+ '(values))
+
+ ((#:lambdef v e)
+ (list `lambda v (exp vs e)))
+
+ ((#:stmt l)
+ (if (> (length l) 1)
+ (cons 'values (map (g vs exp) l))
+ (exp vs (car l))))
+
+
+ ((#:expr-stmt (l) (#:assign))
+ (exp vs l))
+
+ ((#:return . x)
+ `(,(fluid-ref return) ,@(map (g vs exp) x)))
+
+ ((#:expr-stmt
+ ((#:test (#:power (#:identifier v) () . #f) #f))
+ (#:assign (l)))
+ (let ((s (string->symbol v)))
+ `(set! ,s ,(exp vs l))))
+
+
+ ((#:comp . l)
+ (define (tr op x y)
+ (match op
+ ((or "<" ">" "<=" ">=")
+ (list (string->symbol op) x y))
+ ("!=" (list 'not (list 'equal? x y)))
+ ("==" (list 'equal? x y))
+ ("is" (list 'eq? x y))
+ ("isnot" (list 'not (list 'eq? x y)))
+ ("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))))))))
+
+(define (comp x)
+ (let ((globs (get-globals x)))
+ `(begin
+ ,@(map (lambda (s) `(define ,s (values))) globs)
+ ,@(map (g globs exp) x))))
+
+(define-syntax with-return
+ (lambda (x)
+ (define (analyze ret x)
+ (syntax-case x (begin let if)
+ ((begin a ... b)
+ #`(begin a ... #,(analyze ret #'b)))
+ ((let lp v a ... b)
+ (symbol? (syntax->datum #'lp))
+ #`(let lp v a ... #,(analyze ret #'b)))
+ ((let v a ... b)
+ #`(let v a ... #,(analyze ret #'b)))
+ ((if p a b)
+ #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
+ ((if p a)
+ #`(if p #,(analyze ret #'a)))
+ ((return a b ...)
+ (equal? (syntax->datum #'return) (syntax->datum ret))
+ (if (eq? #'(b ...) '())
+ #'a
+ #`(values a b ...)))
+ (x #'x)))
+
+ (define (is-ec ret x tail)
+ (syntax-case x (begin let)
+ ((begin a ... b)
+ #t
+ (or
+ (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
+ (is-ec ret #'b tail)))
+
+ ((let lp ((y x) ...) a ... b)
+ (symbol? (syntax->datum #'lp))
+ (or
+ (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
+ (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
+ (is-ec ret #'b tail)))
+
+ ((let ((y x) ...) a ... b)
+ #t
+ (or
+ (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
+ (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
+ (is-ec ret #'b tail)))
+
+ ((if p a b)
+ #t
+ (or
+ (is-ec ret #'p #f)
+ (is-ec ret #'a tail)
+ (is-ec ret #'b tail)))
+ ((if p a)
+ #t
+ (or
+ (is-ec ret #'p #f)
+ (is-ec ret #'a tail)))
+
+ ((return a b ...)
+ (equal? (syntax->datum #'return) (syntax->datum ret))
+ (not tail))
+
+ ((a ...)
+ #t
+ (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
+
+ (x
+ #t
+ #f)))
+
+ (syntax-case x ()
+ ((_ ret l)
+ (pf (let ((code (analyze #'ret #'l)))
+ (if (is-ec #'ret #'l #t)
+ #`(let/ec ret #,code)
+ code)))))))
+
+
+
diff --git a/modules/language/python/parser.scm b/modules/language/python/parser.scm
index c7e48c1..55c0d2d 100644
--- a/modules/language/python/parser.scm
+++ b/modules/language/python/parser.scm
@@ -510,6 +510,7 @@
(f-seq indent= compound_stmt nl)
(f-seq (f-or nl f-eof))))
+
(set! stmt (f-or 'stmt simple_stmt compound_stmt))
(set! if_stmt
@@ -540,7 +541,7 @@
#:for
(f-seq "for"
(f-cons (Ds exprlist)
- (f-seq "in"
+ (f-seq "in"
(f-cons (Ds testlist)
(f-cons (f-seq ":" (Ds suite))
(ff? (f-seq "else" ":" (Ds suite))))))))))
@@ -552,7 +553,7 @@
(f-cons (Ds suite)
(f-or
(f-cons
- (ff+ (f-seq (Ds except_clause) ":" (Ds suite)))
+ (ff+ (f-list (Ds except_clause) ":" (Ds suite)))
(f-cons
(ff? (f-seq "else" ":" (Ds suite)))
(ff? (f-seq "finally" ":" ws (Ds suite)))))
@@ -830,13 +831,19 @@
(f-list #:list testlist)))
+(define input (f-seq
+ (ff+ (f-seq (f? ws)
+ (f-or! (f-seq indent= simple_stmt)
+ (f-seq indent= compound_stmt nl))))
+
+ (f-seq (f? ws) (f-or nl f-eof))))
+
(define (p str)
(with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
- (ppp (parse str (f-seq nl single_input)))
- (if #f #f)))
+ (parse str input)))
(define (python-parser . l)
(with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
- (ppp (apply parse (append l (list (f-seq nl single_input)))))))
+ (ppp (apply parse (append l (list (f-seq nl ws single_input ws)))))))
diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm
new file mode 100644
index 0000000..1389165
--- /dev/null
+++ b/modules/language/python/spec.scm
@@ -0,0 +1,48 @@
+(define-module (language python spec)
+ #:use-module (language python parser)
+ #:use-module (language python compile)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (system base compile)
+ #:use-module (system base language)
+ #:use-module (language scheme compile-tree-il)
+ #:use-module (language scheme decompile-tree-il)
+ #:use-module (ice-9 rdelim)
+ #:export (python))
+
+;;;
+;;; Language definition
+;;;
+
+(define (pr . x) (pretty-print x) (car (reverse x)))
+
+(define (c x) (pr (comp (pr (p (pr x))))))
+(define (cc port x)
+ (if (equal? x "") (read port) (c x)))
+
+(define-language python
+ #:title "python"
+ #:reader (lambda (port env)
+ (cc port (read-string port)))
+
+ #:compilers `((tree-il . ,compile-tree-il))
+ #:decompilers `((tree-il . ,decompile-tree-il))
+ #:evaluator (lambda (x module) (primitive-eval x))
+ #:printer write
+ #:make-default-environment
+ (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)))
+ ;; Provide a separate `current-reader' fluid so that
+ ;; compile-time changes to `current-reader' are
+ ;; limited to the current compilation unit.
+ (module-define! m 'current-reader (make-fluid))
+
+ ;; Default to `simple-format', as is the case until
+ ;; (ice-9 format) is loaded. This allows
+ ;; compile-time warnings to be emitted when using
+ ;; unsupported options.
+ (module-set! m 'format simple-format)
+
+ m)))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-20 00:13:05 +0000