improving python parser and compiler

3 files changed, 177 insertions, 122 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index f936aa0..8f5139d 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -17,6 +17,7 @@
   #:use-module (language python module)
   #:use-module (language python dir)
   #:use-module (language python procedure)
+  #:use-module (language python bool)
   #:use-module ((language python with) #:select ())
   #:use-module (ice-9 pretty-print)
   #:export (comp))
@@ -415,15 +416,54 @@
       (()
        (values (reverse l) (reverse kw))))))
 
-(define (get-kwarg-def vs arg)
+(define (get-args_ vs arg)
   (let lp ((arg arg))
     (match arg
-      ((((x . _) #f) . arg)
-       (cons (exp vs x)
+      (((#:arg x) . arg)
+       (cons (exp vs (car x))
              (lp arg)))
-      ((((a . _) b) . arg)      
-       (cons (list '= (exp vs a) (exp vs b))
+      ((x . args)
+       (lp args))
+      
+      (()
+       '()))))
+
+(define (get-args= vs arg)
+  (let lp ((arg arg))
+    (match arg
+      (((#:= x v) . arg)
+       (cons (list '= (exp vs (car x)) (exp vs v))
+             (lp arg)))
+      
+      ((x . args)
+       (lp args))
+      
+      (()
+       '()))))
+
+(define (get-args* vs arg)
+  (let lp ((arg arg))
+    (match arg
+      (((#:* x) . arg)
+       (cons (exp vs (car x))
+             (lp arg)))
+
+      ((x . args)
+       (lp args))
+      
+      (()
+       '()))))
+
+(define (get-args** vs arg)
+  (let lp ((arg arg))
+    (match arg
+      (((#:** x) . arg)
+       (cons (exp vs (car x))
              (lp arg)))
+
+      ((x . args)
+       (lp args))
+      
       (()
        '()))))
 
@@ -757,22 +797,25 @@
     
  (#:not
   ((_ x)
-   (list 'not (exp vs x))))
+   (list 'not (list (C 'boolit) (exp vs x)))))
  
  (#:or
   ((_ . x)
-   (cons 'or (map (g vs exp) x))))
+   (cons 'or (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
     
  (#:and
   ((_ . x)
-   (cons 'and (map (g vs exp) x))))
+   (cons 'and (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
     
  (#:test
   ((_ e1 #f)
    (exp vs e1))
-    
-  ((_ e1 e2 e3)
-   (list 'if (exp vs e2) (exp vs e1) (exp vs e3))))
+
+  ((_ e1 (e2 #f))
+   (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (C 'None)))
+
+  ((_ e1 (e2 e3))
+   (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (exp vs e3))))
 
  (#:del
   ;;We don't delete variables
@@ -797,9 +840,10 @@
  (#: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))) '()))))
+     (,(list (C 'boolit) (exp vs test)) ,(exp vs a))
+     ,@(map (lambda (p a) (list (list (C 'boolit) (exp vs p))
+				(exp vs a))) tests as)
+     ,@(if else `((else ,(exp vs else))) '()))))
     
  (#:suite
   ((_ . l) (cons 'begin (map (g vs exp) l))))
@@ -984,6 +1028,9 @@
          (match exc
            ((((test . #f) code) . exc)
             (lp exc (cons `(#:except ,(exp vs code)) r)))
+
+	   (((#f code) . exc)
+            (lp exc (cons `(#:except ,(exp vs code)) r)))
            
            ((((test . as) code) . exc)
             (let ((l (gensym "l")))
@@ -1038,37 +1085,25 @@
   
  (#:def
   ((_ f
-      (#:types-args-list
-       args
-       *e **e)
+      (#:types-args-list . args)
       #f
       code)
    (let* ((decor   (let ((r (fluid-ref decorations)))
                           (fluid-set! decorations '())
                           r))
-          (args (get-kwarg-def vs args))
+          (args (get-args_ vs args))	  
+	  (arg= (get-args= vs args))
+	  (dd=  (map cadr arg=))
           (c?   (fluid-ref is-class?))
           (f    (exp vs f))
           (y?   (is-yield f #f code))
           (r    (gensym "return"))
-          (*f   (match *e
-                  (((e . #f) ()) (list (list '* (exp vs e))))
-                  (#f '())))
-          (dd2  (match *e
-                  (((e . #f) ()) (list (exp vs e)))
-                  (#f '())))
-          (**f   (match **e
-                   ((e . #f) (list (list '** (exp vs e))))
-                   (#f '())))
-          (dd3  (match **e
-                  ((e . #f) (list (exp vs e)))
-                  (#f '())))
-          (as   (map (lambda (x) (match x
-                                   (('= a _) a)
-                                   (a        a)))
-                     args))
+          (*f   (get-args* vs args))
+	  (dd*  (map cadr *f))
+          (**f  (get-args** vs args))
+	  (dd** (map cadr **f))
           (ab  (gensym "ab"))
-          (vs  (union dd3 (union dd2 (union as vs))))
+          (vs  (union dd** (union dd* (union dd= (union args vs)))))
           (ns  (scope code vs))
           (df  (defs code '()))
           (ex  (gensym "ex"))
@@ -1091,7 +1126,7 @@
                `(define ,f
                   (,(C 'def-decor) ,decor
                    (,(C 'def-wrap) ,y? ,f ,ab
-                    (,(D 'lam) (,@args ,@*f ,@**f)
+                    (,(D 'lam) (,@args ,@*f ,@arg= ,@**f)
                      (,(C 'with-return) ,r
                       ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                               (,(C 'with-self) ,c? ,args
@@ -1100,7 +1135,7 @@
                
                `(define ,f
                   (,(C 'def-decor) ,decor
-                   (,(D 'lam) (,@args ,@*f ,@**f)
+                   (,(D 'lam) (,@args ,@*f ,@arg= ,@**f)
                     (,(C 'with-return) ,r
                      ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                              (,(C 'with-self) ,c? ,args
@@ -1111,7 +1146,7 @@
                `(define ,f
                   (,(C 'def-decor) ,decor
                    (,(C 'def-wrap) ,y? ,f ,ab
-                    (,(D 'lam) (,@args ,@*f ,@**f)
+                    (,(D 'lam) (,@args ,@*f ,@arg= ,@**f)
                      (,(C 'with-return) ,r 
                       (let ,(map (lambda (x) (list x #f)) ls)
                         (,(C 'with-self) ,c? ,args
@@ -1120,7 +1155,7 @@
                              (exp ns code))))))))))
                `(define ,f
                   (,(C 'def-decor) ,decor
-                   (,(D 'lam) (,@args ,@*f ,@**f)
+                   (,(D 'lam) (,@args ,@*f ,@arg= ,@**f)
                     (,(C 'with-return) ,r 
                      (let ,(map (lambda (x) (list x #f)) ls)
                        (,(C 'with-self) ,c? ,args
@@ -1300,7 +1335,9 @@
     ((e)
      (exp vs e))
     ((tag . l)
-     ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs))
+     ((hash-ref tagis tag
+		(lambda y (warn (format #f "not tag in tagis ~a" tag)) x))
+      x vs))
 
     (#:True  #t)
     (#:None  (E 'None))
@@ -1878,3 +1915,12 @@
     ((_ s c)
      (syntax-parameterize ((*class* (lambda (x) #'s))) c))))
 
+
+(define-syntax boolit
+  (syntax-rules (and or not)
+    ((_ (and x y)) (and (boolit x) (boolit y)))
+    ((_ (or  x y)) (or  (boolit x) (boolit y)))
+    ((_ (not x  )) (not (boolit x)))
+    ((_ #t) #t)
+    ((_ #f) #f)
+    ((_ x ) (bool x))))
diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm
index c034503..260aa0d 100644
--- a/modules/language/python/dict.scm
+++ b/modules/language/python/dict.scm
@@ -485,7 +485,7 @@
 
 (define-method (write (o <py-hashtable>) . l)
   (define port (match l (() #f) ((p) p)))
-  (define li (hash-fold cons* '() (slot-ref o 't)))              
+  (define li (hash-fold cons* '() (slot-ref o 't)))
   (if (null? li)
       (format port "{}") 
       (format port "{~a: ~a~{, ~a: ~a~}}" (car li) (cadr li) (cddr li))))
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 792a89a..8ac2325 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -700,88 +700,93 @@ explicitly tell it to not update etc.
 
 (define type   #f)
 (define object #f)
-(define (make-p-class name supers.kw methods)
-  (define kw      (cdr supers.kw))
-  (define supers  (car supers.kw))
-  (define goopses (map (lambda (sups)
-                         (aif it (ref sups '__goops__ #f)
-                              it
-                              sups))
-                       supers))
-  (define parents (let ((p (filter-parents supers)))
-                    (if (null? p)
-                        (if object
-                            (list object)
-                            '())
-                        p)))
-  
-  (define meta (aif it (memq #:metaclass kw)
-                    (cadr it)
-                    (if (null? parents)
-                        type
-                        (let* ((p   (car parents))
-                               (m   (ref p '__class__))
-                               (mro (reverse (ref m '__mro__ '()))))
-                          (let lp ((l   (cdr parents))
-                                   (max mro)
-                                   (min mro))
-                            (if (pair? l)
-                                (let* ((p    (car l))
-                                       (meta (ref p '__class__))
-                                       (mro  (ref meta '__mro__ '())))
-                                  (let lp2 ((max max) (mr (reverse mro)))
-                                    (if (and (pair? max) (pair? mr))
-                                        (if (eq? (car max) (car mr))
-                                            (lp2 (cdr max) (cdr mr))
-                                            (error
-                                             "need a common lead for meta"))
-                                        (if (pair? max)
-                                            (if (< (length mro) (length min))
-                                                (lp (cdr l) max mro)
-                                                (lp (cdr l) max min))
-                                            (lp (cdr l) mro min)))))
-                                (car (reverse min))))))))
+(define make-p-class
+  (case-lambda
+   ((name supers.kw methods)
+    (make-p-class name "" supers.kw methods))
+   ((name doc supers.kw methods)
+    (define kw      (cdr supers.kw))
+    (define supers  (car supers.kw))
+    (define goopses (map (lambda (sups)
+			   (aif it (ref sups '__goops__ #f)
+				it
+				sups))
+			 supers))
+    (define parents (let ((p (filter-parents supers)))
+		      (if (null? p)
+			  (if object
+			      (list object)
+			      '())
+			  p)))
+    
+    (define meta (aif it (memq #:metaclass kw)
+		      (cadr it)
+		      (if (null? parents)
+			  type
+			  (let* ((p   (car parents))
+				 (m   (ref p '__class__))
+				 (mro (reverse (ref m '__mro__ '()))))
+			    (let lp ((l   (cdr parents))
+				     (max mro)
+				     (min mro))
+			      (if (pair? l)
+				  (let* ((p    (car l))
+					 (meta (ref p '__class__))
+					 (mro  (ref meta '__mro__ '())))
+				    (let lp2 ((max max) (mr (reverse mro)))
+				      (if (and (pair? max) (pair? mr))
+					  (if (eq? (car max) (car mr))
+					      (lp2 (cdr max) (cdr mr))
+					      (error
+					       "need a common lead for meta"))
+					  (if (pair? max)
+					      (if (< (length mro) (length min))
+						  (lp (cdr l) max mro)
+						  (lp (cdr l) max min))
+					      (lp (cdr l) mro min)))))
+				  (car (reverse min))))))))
   
-  (define goops (make-class (append goopses (list (kw->class kw meta)))
-                            '() #:name name))
-
-  (define (make-module)
-    (let ((l (module-name (current-module))))
-      (if (and (>= (length l) 3)
-	       (equal? (list-ref l 0) 'language)
-	       (equal? (list-ref l 1) 'python)
-	       (equal? (list-ref l 2) 'module))
-	  (string-join
-	   (map symbol->string (cdddr l))
-	   ".")
-	  l)))
+    (define goops (make-class (append goopses (list (kw->class kw meta)))
+			      '() #:name name))
+
+    (define (make-module)
+      (let ((l (module-name (current-module))))
+	(if (and (>= (length l) 3)
+		 (equal? (list-ref l 0) 'language)
+		 (equal? (list-ref l 1) 'python)
+		 (equal? (list-ref l 2) 'module))
+	    (string-join
+	     (map symbol->string (cdddr l))
+	     ".")
+	    l)))
   
-  (define (gen-methods dict)
-    (methods dict)
-    (pylist-set! dict '__goops__    goops)
-    (pylist-set! dict '__class__    meta)
-    (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
-    (pylist-set! dict '__module__   (make-module))
-    (pylist-set! dict '__bases__    parents)
-    (pylist-set! dict '__fget__     #t)
-    (pylist-set! dict '__fset__     #t)
-    (pylist-set! dict '__name__     name)
-    (pylist-set! dict '__qualname__ name)
-    (pylist-set! dict '__class__    meta)
-    (pylist-set! dict '__mro__      (get-mro parents))
-    dict)
-
-  (let ((cl (with-fluids ((*make-class* #t))
-			 (create-class meta name parents gen-methods kw))))
-    (aif it (ref meta '__init_subclass__)
-	 (let lp ((ps parents))
-	   (if (pair? ps)
-	       (let ((super (car ps)))
-		 (it cl super)
-		 (lp (cdr ps)))))
-	 #f)
+    (define (gen-methods dict)
+      (methods dict)
+      (pylist-set! dict '__goops__    goops)
+      (pylist-set! dict '__class__    meta)
+      (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
+      (pylist-set! dict '__module__   (make-module))
+      (pylist-set! dict '__bases__    parents)
+      (pylist-set! dict '__fget__     #t)
+      (pylist-set! dict '__fset__     #t)
+      (pylist-set! dict '__name__     name)
+      (pylist-set! dict '__qualname__ name)
+      (pylist-set! dict '__class__    meta)
+      (pylist-set! dict '__mro__      (get-mro parents))
+      (pylist-set! dict '__doc__      doc)
+      dict)
+
+    (let ((cl (with-fluids ((*make-class* #t))
+			   (create-class meta name parents gen-methods kw))))
+      (aif it (ref meta '__init_subclass__)
+	   (let lp ((ps parents))
+	     (if (pair? ps)
+		 (let ((super (car ps)))
+		   (it cl super)
+		   (lp (cdr ps)))))
+	   #f)
     
-    cl))
+      cl))))
 		    
 
 
@@ -807,6 +812,8 @@ explicitly tell it to not update etc.
   (lambda (x)
     (syntax-case x ()
       ((_ name parents (ddef dname dval) ...)
+       #'(mk-p-class name parents "" (ddef dname dval) ...))
+      ((_ name parents doc (ddef dname dval) ...)
        (with-syntax (((ddname ...)
 		      (map (lambda (dn)
 			     (datum->syntax
@@ -832,7 +839,7 @@ explicitly tell it to not update etc.
 	#'(let ()
 	    (define name 
 	      (letruc ((dname (make-up dval)) ...)
-		     (make-p-class 'name
+		     (make-p-class 'name doc
 				    parents
 				    (lambda (dict)
 				      (pylist-set! dict 'dname dname)
@@ -853,10 +860,12 @@ explicitly tell it to not update etc.
   (lambda (x)
     (syntax-case x ()
       ((_ name parents (ddef dname dval) ...)
+       #'(mk-p-class-noname name parents "" (ddef dname dval) ...))
+      ((_ name parents doc (ddef dname dval) ...)
        #'(let ()
 	   (define name 
 	     (letruc ((dname dval) ...)
-		     (make-p-class 'name
+		     (make-p-class 'name doc
 				   parents
 				   (lambda (dict)
 				     (pylist-set! dict 'dname dname)