advanced argument parsing now works via the def.scm macro
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 21 Sep 2017 18:03:49 +0000 (20:03 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 21 Sep 2017 18:03:49 +0000 (20:03 +0200)
modules/language/python/compile.scm

index 230279ae464b04e9cf0029fc60b4600e56dc455b..eace6ec0f53d6a6678eac00052df2106165ede71 100644 (file)
   (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))
 
 
 (define (defs x vs)
   (match x
-    ((#:def  (#:identifier f . _) . _)
+    ((#:def  ((#:identifier f) . _) . _)
      (union (list (string->symbol f)) vs))
     ((#:lambdef . _)
      vs)
        (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
     (() '())
        
        (cons
         (match x
-          ((#:identifier . _)
+          (((#:identifier . _) . _)
            (let* ((tag     (exp vs x))
                   (xs      (gensym "xs"))
                   (is-fkn? (aif it (and is-fkn? (fastfkn tag))
                                 #f)))
              (if is-fkn?
                  is-fkn?
-                 `(#:identifier ',tag))))
+                 `((#:identifier ',tag) . _))))
           
           ((#:arglist args apply #f)
            (call-with-values (lambda () (get-kwarg vs args))
       ("//="  '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
                             (_
                              #f))))
              (match (pr x)
-               ((#:identifier . _)
+               (((#:identifier . _) . _)
                 (let* ((tag     (exp vs x))
                        (xs      (gensym "xs"))
                        (is-fkn? (aif it (and is-fkn? (fastfkn tag))
          (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"))
                               ((_ . 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))
             (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))