From f045774d073c7d2c2f755c1a8a0e07fa6661e3a3 Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Mon, 23 Jun 2014 22:33:29 +0200
Subject: development

---
 modules/language/python/class.scm       |  71 +++++++++
 modules/language/python/expr.scm        | 106 +++++++++++++
 modules/language/python/parser-tool.scm |  18 +--
 modules/language/python/parser.scm      |  19 ++-
 modules/language/python/python.scm      | 265 ++++++++++++++++++++++++++++++++
 5 files changed, 464 insertions(+), 15 deletions(-)
 create mode 100644 modules/language/python/class.scm
 create mode 100644 modules/language/python/expr.scm
 create mode 100644 modules/language/python/python.scm

(limited to 'modules/language/python')

diff --git a/modules/language/python/class.scm b/modules/language/python/class.scm
new file mode 100644
index 0000000..41ed09a
--- /dev/null
+++ b/modules/language/python/class.scm
@@ -0,0 +1,71 @@
+(define-module (language python class)
+  #:export (class_+ class_- class_* class_// class_%
+		    class_power class_<< class_>> class_ior
+		    class_xor class_band))
+
+(define-syntax-rule (class-ref x) (struct-ref x 0))
+(define-syntax-rule (class-num x) (struct-ref x 1))
+(define-syntax-rule (class-log x) (struct-ref x 2))
+(define-syntax-rule (class-map x) (struct-ref x 3))
+
+(define-syntax-rule (mkref +-ref n)
+  (define-syntax-rule (+-ref x)     (vector-ref x n)))
+
+(mkref +-ref     0)
+(mkref --ref     1)
+(mkref *-ref     2)
+(mkref /-ref     3)
+(mkref //-ref    4)
+(mkref %-ref     5)
+(mkref **-ref    6)
+(mkref <<-ref    7)
+(mkref >>-ref    8)
+
+(mkref ior-ref   0)
+(mkref xor-ref   1)
+(mkref and-ref   2)
+
+(define-syntax-rule (class-lookup class key )
+  (hashq-ref (class-map class) key #f))
+
+(define-syntax-rule (meta-mk mk-num class-num)
+(define-syntax-rule (mk-num class_+ __add__ __radd__ +-ref  err)
+  (define (class_+ x y)
+    (let* ((cl (class-ref  x))
+	   (r  (class-num cl)))
+      (define (f)
+	(let ((rrr (class-lookup cl '__add__)))
+	  (if rrr
+	      (rrr x y)
+	      (if (class? y)
+		  (let* ((cl   (class-ref y))
+			 (rrrr (class-lookup cl '__radd__)))
+		    (if rrrr
+			(rrrr y x)
+			(err)))
+		  (err)))))
+	 
+      (if r
+          (let ((rr (+-ref r)))
+            (if rr
+                (rr x y)
+                (f)))
+	  (f))))))
+			    
+(meta-mk mk-num class-num)
+(meta-mk mk-log class-log)
+
+(define (err) (error "could not do artithmetic ops"))
+
+(mk-num class_+      __add__      __radd__         +-ref  err)
+(mk-num class_-      __sub__      __rsub__         --ref  err)
+(mk-num class_*      __mul__      __rmul__         *-ref  err)
+(mk-num class_/      __div__      __rdiv__         /-ref  err)
+(mk-num class_//     __floordiv__ __rfloordiv__    //-ref err)
+(mk-num class_%      __divmod__   __rdivmod__      %-ref  err)
+(mk-num class_power  __pow__      __rpow__         **-ref err)
+(mk-num class_<<     __lshift__   __rlshift__      <<-ref err)
+(mk-num class_>>     __rshift__   __rrshift__      >>-ref err)
+(mk-log class_ior    __or__       __ror__         ior-ref err)
+(mk-log class_xor    __xor__      __rxor__        xor-ref err)
+(mk-log class_band   __and__      __rand__        and-ref err)
diff --git a/modules/language/python/expr.scm b/modules/language/python/expr.scm
new file mode 100644
index 0000000..81c2cbe
--- /dev/null
+++ b/modules/language/python/expr.scm
@@ -0,0 +1,106 @@
+(define-module (language python expr)
+  #:use-module (language python class)
+  #:export (py-true? to-py py-or py-and py-not py_==
+                     py_>= py_<= py_< py_> py_<> py_!= py_in py_notin py_is
+                     py_isnot py_bor py_xor py_band py-<< py->> py-+ py-- 
+                     py-* py-/ py-% py-// py-u+ py-u- py-u~ py-power
+                     ))
+
+
+(define-syntax-rule (py-true? x)  (eq? x 'True))
+(define-syntax-rule (to-py x) (if x 'True 'false))
+(define-syntax-rule (py-or  x ...) (to-py (or  (py-true? x) ...)))
+(define-syntax-rule (py-and x ...) (to-py (and (py-true? x) ...)))
+(define-syntax-rule (py-not x)     (if (py-true? x) 'False 'True))
+
+(define-syntax-rule (py_== x y)
+  (if (struct? x) 
+      (if (class? x) 
+          (class_== x y)
+          (to-py (equal? x y)))
+      (to-py (equal? x y))))
+
+(define-syntax-rule (mk-comp py_>= >= class_>=)
+  (define-syntax-rule (py_>= x y)
+     (if (number? x)
+         (to-py (>= x y))
+         (if (class? x)
+             (class_>= x y)
+             'False))))
+
+(mk-comp py_>= >= class_>=)
+(mk-comp py_<= <= class_<=)
+(mk-comp py_<  <  class_<)
+(mk-comp py_>  >  class_>)
+
+(define-syntax-rule (<> x y) (not (= x y)))
+(mk-comp py_<> <> class_<>)
+(mk-comp py_!= <> class_<>)
+
+
+(define-syntax-rule (py_in x y)
+  (cond
+   ((struct? y)
+    (if (class? y)
+        (to-py (class_in y x))
+        'False))
+   ((pair? y)
+    (list-in x y))
+   ((vector? y)
+    (vector-in x y))
+   (else
+    'False)))
+
+(define-syntax-rule (py_notin x y)
+  (cond
+   ((struct? y)
+    (if (class? y)
+        (to-py (not (class_in y x)))
+        'True))
+   ((pair? y)
+    (to-py (list-in x y)))
+   ((vector? y)
+    (to-py (vector-in x y)))
+   (else
+    'True)))
+
+(define-syntax-rule (py_is x y)
+  (to-py (and (class? x) (class? y) (eq? (class-ref x) (class-ref y)))))
+
+(define-syntax-rule (py_isnot x y)
+  (to-py (not (and (class? x) (class? y) (eq? (class-ref x) (class-ref y))))))
+
+(define-syntax-rule (mk-num py_>= >= class_>=)
+  (define-syntax-rule (py_>= x . y)
+     (if (number? x)
+         (>= x . y)
+         (if (class? x)
+             (class_>= x . y)
+             (error "wrong numerics")))))
+
+(mk-num py_bor  logior            class_ior)
+(mk-num py_xor  logxor            class_xor)
+(mk-num py_band logand            class_band)
+(mk-num py-<<   ash               class_<<)
+(define-syntax-rule (rash x y) (ash x (- y)))
+(mk-num py->>   rash              class_>>)
+(mk-num py-+    +                 class_+)
+(mk-num py--    -                 class_-)
+(mk-num py-*    *                 class_*)
+(mk-num py-/    /                 class_/)
+(mk-num py-%    modulo            class_%)
+(mk-num py-//   truncate-quotient class_//)
+
+(define-syntax-rule (mk-unum py_>= >= class_>=)
+  (define-syntax-rule (py_>= x)
+     (if (number? x)
+         (>= x)
+         (if (class? x)
+             (class_>= x)
+             (error "wrong numerics")))))
+
+(mk-unum py-u+    +                 class_u+)
+(mk-unum py-u-    -                 class_u-)
+(mk-unum py-u~    lognot            class_u~)
+
+(mk-num py-power  expt class_power)
diff --git a/modules/language/python/parser-tool.scm b/modules/language/python/parser-tool.scm
index 00359c9..75da429 100644
--- a/modules/language/python/parser-tool.scm
+++ b/modules/language/python/parser-tool.scm
@@ -16,17 +16,17 @@
 		  f-pk))
 
 ;; Preliminary
-(define do-print #t)
+(define do-print #f)
 (define pp
   (case-lambda
-   ((s x)
-    (when do-print
-      (pretty-print `(,s ,(syntax->datum x))))
-    x)
-   ((x)
-    (when do-print
-      (pretty-print (syntax->datum x)))
-    x)))
+    ((s x)
+     (when do-print
+       (pretty-print `(,s ,(syntax->datum x))))
+     x)
+    ((x)
+     (when do-print
+       (pretty-print (syntax->datum x)))
+     x)))
 
 
 (begin
diff --git a/modules/language/python/parser.scm b/modules/language/python/parser.scm
index 180ec0a..c7e48c1 100644
--- a/modules/language/python/parser.scm
+++ b/modules/language/python/parser.scm
@@ -4,7 +4,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
   #:use-module (language python parser-tool)
-  #:export (p))
+  #:export (p python-parser))
 
 (define do-print #f)
 (define pp
@@ -441,8 +441,8 @@
 
 (set! flow_stmt 
   (f-or 'flow_stmt
-   (f-seq "break"   #:break)
-   (f-seq "coninue" #:continue)
+   (f-seq "break"    #:break)
+   (f-seq "continue" #:continue)
    (f-cons #:return (f-seq "return" (ff? (Ds testlist))))
    (Ds yield_expr)
    (f-cons #:raise  (f-seq "raise" 
@@ -452,7 +452,8 @@
 				 (f-cons FALSE FALSE))))))
 
 (set! import_name (f-seq "import" dotted_as_names))
-(set! import_stmt (f-or 'import_stmt import_name (Ds import_from)))
+(set! import_stmt (f-list #:import
+                          (f-or 'import_stmt import_name (Ds import_from))))
 
 
 
@@ -651,14 +652,14 @@
 (set! expr
   (p-freeze 'expr
     (f-or! 'expr
-     (f-cons #:bxor (f-cons (Ds xor_expr) (ff+ (f-seq "|" (Ds xor_expr)))))
+     (f-cons #:bor (f-cons (Ds xor_expr) (ff+ (f-seq "|" (Ds xor_expr)))))
      (Ds xor_expr))
     mk-id))
 
 (set! xor_expr
  (p-freeze 'xor
    (f-or! 'xor
-     (f-cons #:band (f-cons (Ds and_expr) (ff+ (f-seq "^" (Ds and_expr)))))
+     (f-cons #:bxor (f-cons (Ds and_expr) (ff+ (f-seq "^" (Ds and_expr)))))
      (Ds and_expr))
    mk-id))
 
@@ -833,3 +834,9 @@
   (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
     (ppp (parse str (f-seq nl single_input)))
     (if #f #f)))
+
+(define (python-parser . l)
+  (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
+    (ppp (apply parse (append l (list (f-seq nl single_input)))))))
+    
+  
diff --git a/modules/language/python/python.scm b/modules/language/python/python.scm
new file mode 100644
index 0000000..4bd99a5
--- /dev/null
+++ b/modules/language/python/python.scm
@@ -0,0 +1,265 @@
+(define-module (language python python)
+  #:use-module (language python parser)
+  #:use-module (language python expr)
+  #:use-module (ice-9    match)
+  #:export (compile-python-string compile-python-file))
+
+;;; VARIABLES ----------------------------------------------------------------
+(define (find-global-variables vars tree)
+  (define (for-each* f l)
+    (match l
+      ((x . l)
+       (f x)
+       (for-each* f l))
+      (x
+       (f x))))
+
+  (define (local tree)
+    (match tree
+      ((#:global l)
+       (for-each* 
+        (lambda (x) (hash-set! vars x #t)) l))
+      ((x . l) 
+       (for-each* local tree))
+      (_       
+       #t)))
+
+  (define (collect tree)
+    (match tree
+      ((#:lambdef . _)
+       #t)
+      ((#:identifier . l)
+       (hash-set! vars tree #t))
+      ((_ . _)
+       (for-each* collect tree))
+      (_
+       #t)))
+
+  (let lp ((tree tree))
+    (match tree
+      ((#:def . l)
+       (for-each* local l))
+      ((#:lambdef . l)
+       (for-each* local l))
+      ((#:class  . l)
+       (for-each* local l))
+      ((#:expr-stmt
+        a (#:assign x ... e))
+       (collect a)
+       (collect x))
+      ((x . l)
+       (for-each* lp tree))
+      (_
+       #t))))
+;; COMPILATION
+
+(define (expr stx out tree)
+  (define (expr-lhs tree)
+    (match tree
+      ((#:test (#:power (#:identifier v . _)))
+       (datum->syntax stx (string->symbol v)))))
+
+
+  (define (expr-rhs tree)
+    (define (comp-tr op)
+      (match op
+        ("notin" #'py-notin)
+        ("isnot" #'py-isnot)
+        ("=="    #'py_==)
+        (">="    #'py_>=)
+        ("<="    #'py_<=)
+        ("<>"    #'py_<>)
+        ("!="    #'py_!=)
+        ("in"    #'py_in)
+        ("is"    #'py_is)
+        ("<"     #'py_< )
+        (">"     #'py_> )))
+
+    (let lp ((tree tree))
+      (match tree
+        ((#:test x #f)
+         (lp x))
+        ((#:test x (a b))
+         #`(if #,(py-true? (lp a)) #,(lp x) #,(lp b)))
+        ((#:or x . y)
+         #`(py-or #,(lp x) #,@(map lp y)))
+        ((#:and x y)
+         #`(py-and #,(lp x) #,@(map lp y)))
+        ((#:not x)
+         #`(py-not #,(lp x)))
+        ((#:comp x)
+         (lp x))
+        ((#:comp x (op . y) . l)
+         #'(#,(comp-tr op) #,(lp x) #,(lp (cons* #:comp y l))))
+        ((#:bor x y)
+         #`(py-bor #,(lp x) #,@(map lp y)))
+        ((#:bxor x y)
+         #`(py-bxor #,(lp x) #,@(map lp y)))
+        ((#:xand x y)
+         #`(py-band #,(lp x) #,@(map lp y)))
+        ((#:<< x y)
+         #`(py-<< #,(lp x) #,@(map lp y)))
+        ((#:>> x y)
+         #`(py->> #,(lp x) #,@(map lp y)))
+        ((#:+ x y)
+         #`(py-+ #,(lp x) #,@(map lp y)))
+        ((#:- x y)
+         #`(py-- #,(lp x) #,@(map lp y)))
+        ((#:* x y)
+         #`(py-* #,(lp x) #,@(map lp y)))
+        ((#:/ x y)
+         #`(py-/ #,(lp x) #,@(map lp y)))
+        ((#:// x y)
+         #`(py-// #,(lp x) #,@(map lp y)))
+        ((#:% x y)
+         #`(py-% #,(lp x) #,@(map lp y)))
+        ((#:u+ x)
+         #`(py-u+ #,(lp x)))
+        ((#:u- x)
+         #`(py-u- #,(lp x)))
+        ((#:u~ x)
+         #`(py-u~ #,(lp x)))
+        ((#:power x trailer . #f)
+         (compile-trailer trailer (lp x)))
+        ((#:power x trailer . l)
+         #'(py-power ,#(compile-trailer trailer (lp x)) #,(lp l)))
+        ((#:identifier x . _)
+         (datum->syntax stx (string->symbol x)))
+        ((not (_ . _))
+         tree))))
+        
+        
+
+  (lambda (tree)
+    (match tree
+      ((test1 (#:assign))
+       (expr-rhs test1))
+      ((test1 (#:assign tests ... last))
+       (with-syntax (((rhs ...)       (map expr-rhs last))
+                     ((lhs1 ...)      (map expr-lhs test1))
+                     (((lhs ...) ...) (reverse (map (lambda (l) 
+                                                      (map expr-lhs l))
+                                                    tests))))
+	  (with-syntax (((v ...) (generate-temporaries #'(lhs1 ...))))
+	     (out #'(call-with-values (lambda () (values rhs ...))
+                      (lambda (v ...)
+                        (begin
+                          (set! lhs v) ...)
+                        ...
+                        (set! lhs1 v) ...)))))))))
+             
+
+(define (compile-outer state out tree)
+  (define (compile-stmt state tree)    
+    (match tree
+      ((#:expr-stmt l)
+       (compile-expr l))
+
+      ((#:del       l)
+       (compile-del l))
+      
+      (#:pass 
+       (out #'(if #f #f)))
+      
+      (#:break
+       (break out))      
+      
+      (#:continue
+       (continue out))
+      
+      ((#:return . l)
+       (compile-return state l))
+      
+      ((#:raise . l)
+       (compile-raise state l))
+      
+      ((#:import l)
+       (compile-import state l))
+
+      ((#:global . _)
+       #t)
+      
+      ((#:nonlocal . _)
+       #t)
+         
+      ((#:assert . l)
+       (compile-assert state l))))
+    
+  (match tree
+    ((#:stmt x)
+     (for-each* compile-stmt tree))
+    ((#:if . l)
+     (compile-if state l))
+    ((#:while . l)
+     (compile-while state l))
+    ((#:for  . l)
+     (compile-for state l))
+    ((#:try  . l)
+     (compile-try state l))
+    ((#:with . l)
+     (compile-with state l))
+    ((#:def  . l)
+     (compile-def state l))
+    ((#:decorated . l)
+     (compile-decorated state l))))
+
+
+(define (compile-python0 stx tree output)
+  (define global-variables (make-hash-table))
+  
+  (find-global-variables global-variables tree)
+  (set! all-variables 
+        (hash-fold
+         (lambda (k v e)
+           (match k
+             ((_ v . _)
+              (cons (datum->syntax stx (string->symbol v)) e))))
+         '() global-variables))
+  (set! all-globals
+        (hash-fold
+         (lambda (k v e)
+           (match k
+	     ((_ v)
+              (cons (datum->syntax stx (string->symbol v)) e))))
+         '() global-variables))
+
+  (output (with-syntax (((v ...) all-variables))
+	   #'(begin (define v (if #f #f)) ...)))
+  
+  (output (with-syntax (((v ...) all-globals))
+            #'(export v ...)))
+
+  (output #`(begin #,@(compile-outer))))
+  
+
+(define (compile-python1 stx tree)
+  (let ((out '()))
+    (define (out x) (set! out (cons x out)))
+    (compile-python0 stx tree out)
+    (cons* #'begin (reverse out))))
+
+(define-syntax compile-python-string
+  (lambda (x)
+    (syntax-case x ()
+      ((_ y)
+       (if (string? (syntax->datum #'y))
+	   (compile-python1 x (python-parser (syntax->datum #'y))))))))
+
+(define-syntax compile-python-file
+  (lambda (x)
+    (syntax-case x ()
+      ((_ y)
+       (if (string? (syntax->datum #'y))
+	   (with-input-from-file (syntax->datum #'y)
+	     (compile-python1 x (python-parser)))
+	   #f)))))
+	   
+	   
+	   
+
+
+  
+  
+  
+    
+    
-- 
cgit v1.2.3