compiler

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)))