improving python parser and compiler
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 4 Apr 2018 17:08:28 +0000 (19:08 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 4 Apr 2018 17:08:28 +0000 (19:08 +0200)
modules/language/python/compile.scm
modules/language/python/dict.scm
modules/oop/pf-objects.scm

index f936aa0d00638efc3cb2b9d1623902432b8bec81..8f5139d9dadf8d332cdce29eed483e73437ff600 100644 (file)
@@ -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))
       (()
        (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))
+      
       (()
        '()))))
 
     
  (#: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
  (#: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))))
          (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")))
   
  (#: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"))
                `(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
                
                `(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
                `(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
                              (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
     ((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))
     ((_ 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))))
index c034503ed691b93e555e68d9dab799c3163f0ece..260aa0de1b2036ecd98f951d28331089118588eb 100644 (file)
 
 (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))))
index 792a89a25f25e11e4988dd2b172a88c15e094c23..8ac2325a60b6119f3bd8c96bfb7a2a3971b9ddc3 100644 (file)
@@ -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)