advanced argument parsing now works via the def.scm macro

1 files changed, 53 insertions, 26 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 230279a..eace6ec 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -51,6 +51,11 @@
   (close port)
   x)
 
+(define (pp x)
+  (pretty-print (syntax->datum x))
+  x)
+
+
 (define-inlinable (C x) `(@@ (language python compile) ,x))
 (define-inlinable (Y x) `(@@ (language python yield)   ,x))
 (define-inlinable (T x) `(@@ (language python try)     ,x))
@@ -58,6 +63,7 @@
 (define-inlinable (L x) `(@@ (language python list)    ,x))
 (define-inlinable (A x) `(@@ (language python array)   ,x))
 (define-inlinable (S x) `(@@ (language python string)  ,x))
+(define-inlinable (D x) `(@@ (language python def)     ,x))
 (define-inlinable (O x) `(@@ (oop pf-objects)          ,x))
 (define-inlinable (G x) `(@  (guile)                   ,x))
 
@@ -142,7 +148,7 @@
 
 (define (defs x vs)
   (match x
-    ((#:def  (#:identifier f . _) . _)
+    ((#:def  ((#:identifier f) . _) . _)
      (union (list (string->symbol f)) vs))
     ((#:lambdef . _)
      vs)
@@ -200,7 +206,19 @@
        (lp arg (cons (exp vs x) l) kw))
       (()
        (values (reverse l) (reverse kw))))))
-        
+
+(define (get-kwarg-def vs arg)
+  (let lp ((arg arg))
+    (match arg
+      ((((x . _) #f) . arg)
+       (cons (exp vs x)
+             (lp arg)))
+      ((((a . _) b) . arg)      
+       (cons (list '= (exp vs a) (exp vs b))
+             (lp arg)))
+      (()
+       '()))))
+
 (define (get-addings vs x)
   (match x
     (() '())
@@ -214,7 +232,7 @@
        
        (cons
         (match x
-          ((#:identifier . _)
+          (((#:identifier . _) . _)
            (let* ((tag     (exp vs x))
                   (xs      (gensym "xs"))
                   (is-fkn? (aif it (and is-fkn? (fastfkn tag))
@@ -224,7 +242,7 @@
                                 #f)))
              (if is-fkn?
                  is-fkn?
-                 `(#:identifier ',tag))))
+                 `((#:identifier ',tag) . _))))
           
           ((#:arglist args apply #f)
            (call-with-values (lambda () (get-kwarg vs args))
@@ -275,7 +293,7 @@
       ("//="  'floor-quotient)))
   
   (match x
-    ((#:test (#:power kind (#:identifier v . _) addings . _) . _)
+    ((#:test (#:power kind ((#:identifier v . _) . _) addings . _) . _)
      (let ((addings (get-addings vs addings)))
        (define q (lambda (x) `',x))
        (if kind
@@ -349,7 +367,7 @@
                             (_
                              #f))))
              (match (pr x)
-               ((#:identifier . _)
+               (((#:identifier . _) . _)
                 (let* ((tag     (exp vs x))
                        (xs      (gensym "xs"))
                        (is-fkn? (aif it (and is-fkn? (fastfkn tag))
@@ -701,28 +719,37 @@
          (set! ,(C 'inhibit-finally) #t)
          (let ((,g (,f ,@(gen-yargs vs args))))
            (,g))))))
-    
+  
   (#:def
    ((_ f
        (#:types-args-list
         args
-        extra #f)
+        *e **e)
        #f
        code)
-    (let* ((c?  (fluid-ref is-class?))
-           (f   (exp vs f))
-           (y?  (is-yield f #f code))
-           (r   (gensym "return"))
-           (dd  (match extra
-                  (((e . #f) ()) (list (exp vs e)))
-                  (#f '())))
-           (dd2 (if (null? dd) dd (car dd)))
-           (as  (map (lambda (x) (match x
-                                   ((((#:identifier x . _) . #f) #f)
-                                    (string->symbol x))))
-                     args))
+    (let* ((args (get-kwarg-def vs args))
+           (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))
            (ab  (gensym "ab"))
-           (vs  (union dd (union as vs)))
+           (vs  (union dd3 (union dd2 (union as vs))))
            (ns  (scope code vs))
            (df  (defs code '()))
            (ex  (gensym "ex"))
@@ -738,19 +765,19 @@
                               ((_ . args)
                                (abort-to-prompt ,ab . args)))))
            ,code))
-      
+
       (with-fluids ((is-class? #f))
         (if c?
             (if y?
                 `(define ,f
                    (,(C 'def-wrap) ,y? ,f ,ab
-                    (lambda (,@as ,@dd2)
+                    (,(D 'lam) (,@args ,@*f ,@**f)
                       (,(C 'with-return) ,r
                        ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                                ,(with-fluids ((return r))
                                   (exp ns code))))))))
                 
-                `(define ,f (lambda (,@as ,@dd2)
+                `(define ,f (,(D 'lam) (,@args ,@*f ,@**f)
                                (,(C 'with-return) ,r
                                 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                                         ,(with-fluids ((return r))
@@ -759,14 +786,14 @@
             (if y?
                 `(define ,f
                    (,(C 'def-wrap) ,y? ,f ,ab
-                    (lambda (,@as ,@dd2)
+                    (,(D 'lam) (,@args ,@*f ,@**f)
                       (,(C 'with-return) ,r
                        (let ,(map (lambda (x) (list x #f)) ls)
                          ,(with-fluids ((return r))
                             (mk
                              (exp ns code))))))))
                 `(define ,f
-                   (lambda (,@as ,@dd2)
+                   (,(D 'lam) (,@args ,@*f ,@**f)
                      (,(C 'with-return) ,r
                       (let ,(map (lambda (x) (list x #f)) ls)
                         ,(with-fluids ((return r))