better operator compilings

1 files changed, 150 insertions, 66 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 81de0c3..962c877 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -4,13 +4,13 @@
   #:use-module (oop pf-objects)
   #:use-module (oop goops)
   #:use-module (ice-9 pretty-print)
-  #:export (comp send sendException sendClose))
+  #:replace (send)
+  #:export (comp sendException sendClose))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
 (define-syntax clear-warning-data
   (lambda (x)
-    (pr 'clear)
     (set! (@@ (system base message) %dont-warn-list) '())
     #f))
 
@@ -117,7 +117,7 @@
                                   (list (exp '() v2)))
                            s)
                           (union (list (exp '() v1)) s)))
-                     (() s)))
+                     (_ s)))
                   '()              
                   l)
             vs))
@@ -151,29 +151,60 @@
 
 (define return (make-fluid 'error-return))
 
-(define (make-set vs x u)
+(define-syntax-rule (<< x y) (ash x y))
+(define-syntax-rule (>> x y) (ash x (- y)))
+
+(define (make-set vs op x u)
+  (define (tr-op op)
+    (match op
+      ("+="  '+)
+      ("-="  '-)
+      ("*="  '*)
+      ("/="  '/)
+      ("%="  'modulo)
+      ("&="  'logand)
+      ("|="  'logior)
+      ("^="  'logxor)
+      ("**=" 'expt)
+      ("<<=" (C '<<))
+      (">>=" (C '>>))
+      ("//="  'floor-quotient)))
+  
   (match x
     ((#:test (#:power kind (#:identifier v . _) addings . _) . _)
-     (if kind
-         (let ((v (string->symbol v)))
-           (if (null? addings)                   
-               `(set! ,v ,u)
-               (let ((addings (map (lambda (x) `',(exp vs x)) addings)))
-                 `(set! ,(exp vs kind)
-                    (,(O 'fset-x) ,v (list ,@addings) ,u)))))
-
-         (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))))))))
+     (let ((addings (map (lambda (x) (exp vs x)) addings)))
+       (define q (lambda (x) `',x))
+       (if kind
+           (let ((v (string->symbol v)))
+             (if (null? addings)                   
+                 (if op
+                     `(set! ,v (,(tr-op op) ,v ,u))
+                     `(set! ,v ,u))
+                 (if op
+                     `(set! ,(exp vs kind)
+                        (,(O 'fset-x) ,v (list ,@(map q addings))
+                         (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
+                     
+                     `(set! ,(exp vs kind)
+                        (,(O 'fset-x) ,v (list ,@(map q addings)) ,u)))))
+           
+           (let ((v (string->symbol v)))
+             (if (null? addings)
+                 (if op
+                     `(set! ,v (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))
+                     `(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 'x) ',new))
+                                    (() v)))
+                     ',(exp vs las)
+                     ,(if op
+                          `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
+                          u))))))))))
   
 (define is-class? (make-fluid #f))
 (define (gen-yargs vs x)
@@ -191,21 +222,27 @@
     
     
     ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
-    ((#:power #f vf trailer . #f)
-     (let lp ((e (exp vs vf)) (trailer trailer))
-       (match trailer
-         (()
-          e)
-         ((#f)          
-          (list e))
-         ((x . trailer)
-          (match (pr x)
-            ((#:identifier . _)
-             (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
-
-            ((#:arglist args #f #f)
-             (lp `(,e ,@(map (g vs exp) args)) trailer))
-            (_ (error "unhandled trailer")))))))
+    ((#:power #f vf trailer . **)
+     (let ()
+       (define (pw x)
+         (if **
+             `(expt ,x ,(exp vs **))
+             x))
+       (pw
+        (let lp ((e (exp vs vf)) (trailer trailer))
+          (match trailer
+            (()
+             e)
+            ((#f)          
+             (list e))
+            ((x . trailer)
+             (match (pr x)
+               ((#:identifier . _)
+                (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
+               
+               ((#:arglist args #f #f)
+                (lp `(,e ,@(map (g vs exp) args)) trailer))
+               (_ (error "unhandled trailer")))))))))
                                                     
     ((#:identifier x . _)
      (string->symbol x))
@@ -216,24 +253,36 @@
     (((and x (or #:+ #:- #:* #:/)) . l)
      (cons (keyword->symbol x) (map (g vs exp) l)))
 
+    ((#:% . l)
+     (cons 'modulo (map (g vs exp) l)))
+    
+    ((#:// . l)
+     (cons 'floor-quotient (map (g vs exp) l)))
+
+    ((#:<< . l)
+     (cons (C '<<) (map (g vs exp) l)))
+
+    ((#:>> . l)
+     (cons (C '>>) (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)))
     
@@ -292,6 +341,8 @@
          
          (let* ((class   (string->symbol class))
                 (parents (match parents
+                           (()
+                            '())
                            (#f
                             '())
                            ((#:arglist args . _)
@@ -579,22 +630,32 @@
     ((#:expr-stmt (l) (#:assign))
      (exp vs l))
 
-    ((#:expr-stmt l (#:assign u))
-     (cond
-      ((= (length l) (length u))
-       (if (= (length l) 1)
-           (make-set vs (car l) (exp vs (car 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)))))))
-                             
+    ((#:expr-stmt l type)
+     (=> fail)
+     (call-with-values
+         (lambda () (match type
+                      ((#:assign u)
+                       (values #f u))
+                      ((#:augassign op u)
+                       (values op u))
+                      (_ (fail))))
+                 
+       (lambda (op u)
+         (cond
+          ((= (length l) (length u))
+           (if (= (length l) 1)
+               (make-set vs op (car l) (exp vs (car u)))
+               (cons 'begin
+                     (map (lambda (l u) (make-set vs op l u))
+                          l
+                          (map (g vs exp) u)))))
+          ((and (= (length u) 1) (not op))
+           (let ((vars (map (lambda (x) (gensym "v")) l)))
+             `(call-with-values (lambda () (exp vs (car u)))
+                (lambda vars
+                  ,@(map (lambda (l v) (make-set vs op l v))
+                         l vars)))))))))
+      
             
 
     ((#:return . x)
@@ -655,7 +716,7 @@
        ,@start
        ,(C 'clear-warning-data)
        (set! (@@ (system base message) %dont-warn-list) '())
-       ,@(map (lambda (s) `(,(C 'var) ',s)) globs)
+       ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
        ,@(map (g globs exp) x))))
 
 (define-syntax-parameter break
@@ -817,12 +878,15 @@
              #`(let/ec ret #,code)
              code))))))
 
-(define (var v)
-  (begin
-    (dont-warn v)
-    (if (module-defined? (current-module) v)
-        (values)
-        (define! v #f))))
+(define-syntax var
+  (lambda (x)
+    (syntax-case x ()
+      ((_ v)
+       (begin
+         (dont-warn (syntax->datum #'v))
+         #'(if (module-defined? (current-module) 'v)
+               (values)
+               (define! 'v #f)))))))
 
 (define-inlinable (non? x) (eq? x #:nil))
 
@@ -1030,7 +1094,20 @@
                            (apply throw 'python tag l))))
                     (apply throw tag v))))
             (slot-set! l 'closed #t)))))
-            
+
+(define-method (send (l <p>) . u)
+  (apply (ref l '__send__) u))
+
+(define-method (sendException (l <p>) . u)
+  (apply (ref l '__exception__) u))
+
+(define-method (sendClose (l <p>))
+  ((ref l '__close__)))
+
+(define-method (next (l <p>))
+  ((ref l '__next__)))
+
+
 
 (define-method (wrap-in  (x <p>))
   (aif it (ref x '__iter__ #f)
@@ -1093,3 +1170,10 @@
                       
 
                       
+(define-syntax ref-x
+  (syntax-rules ()
+    ((_ v)
+     v)
+    ((_ v x . l)
+     (ref-x (ref v 'x) . l))))
+