From d82a3d264d43a4fe751d6d3629f64088b03f6ede Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Sat, 16 Sep 2017 17:35:40 +0200
Subject: variable length function added

---
 modules/language/python/compile.scm | 74 ++++++++++++++++++++-----------------
 modules/language/python/list.scm    | 26 +++++++++++++
 2 files changed, 67 insertions(+), 33 deletions(-)
 create mode 100644 modules/language/python/list.scm

(limited to 'modules')

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 6dd12a5..597c71f 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -7,6 +7,7 @@
   #:use-module (language python yield)
   #:use-module (language python for)
   #:use-module (language python try)
+  #:use-module (language python list)
   #:use-module (ice-9 pretty-print)
   #:export (comp))
 
@@ -48,12 +49,13 @@
   (close port)
   x)
 
-(define (C x) `(@@ (language python compile) ,x))
-(define (Y x) `(@@ (language python yield) ,x))
-(define (T x) `(@@ (language python try) ,x))
-(define (F x) `(@@ (language python for) ,x))
-(define (O x) `(@@ (oop pf-objects) ,x))
-(define (G x) `(@ (guile) ,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))
+(define-inlinable (F x) `(@@ (language python for) ,x))
+(define-inlinable (L x) `(@@ (language python list) ,x))
+(define-inlinable (O x) `(@@ (oop pf-objects) ,x))
+(define-inlinable (G x) `(@ (guile) ,x))
 
 (define (union as vs)
   (let lp ((as as) (vs vs))
@@ -254,8 +256,14 @@
                ((#:identifier . _)
                 (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
                
-               ((#:arglist args #f #f)
-                (lp `(,e ,@(map (g vs exp) args)) trailer))
+               ((#:arglist args apply  #f)
+                (if apply
+                    (lp `(apply ,e
+                                ,@(map (g vs exp) args)
+                                ,`(,(L 'to-list) ,(exp vs apply)))
+                        trailer)
+                    (lp `(,e ,@(map (g vs exp) args)) trailer)))
+               
                (_ (error "unhandled trailer"))))))))))
 
  (#:identifier
@@ -282,7 +290,7 @@
  (#:%
   ((_ . l)
    (cons 'modulo (map (g vs exp) l))))
-    
+ 
  (#://
   ((_ . l)
    (cons 'floor-quotient (map (g vs exp) l))))
@@ -290,7 +298,7 @@
  (#:<<
   ((_ . l)
    (cons (C '<<) (map (g vs exp) l))))
-
+ 
  (#:>>
   ((_ . l)
    (cons (C '>>) (map (g vs exp) l))))
@@ -306,7 +314,7 @@
  (#:bxor
   ((_ . l)
    (cons 'logxor (map (g vs exp) l))))
-
+ 
  (#:bor
   ((_ . l)
    (cons 'logior (map (g vs exp) l))))
@@ -314,7 +322,7 @@
  (#:not
   ((_ x)
    (list 'not (exp vs x))))
-
+ 
  (#:or
   ((_ . x)
    (cons 'or (map (g vs exp) x))))
@@ -563,19 +571,23 @@
    ((_ f
        (#:types-args-list
         args
-        #f #f)
+        extra #f)
        #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))
            (ab  (gensym "ab"))
-           (vs  (union as vs))
+           (vs  (union dd (union as vs)))
            (ns  (scope code vs))
            (df  (defs code '()))
            (ex  (gensym "ex"))
@@ -597,59 +609,53 @@
             (if y?
                 `(define ,f
                    (,(C 'def-wrap) ,y? ,f ,ab
-                    (lambda (,@as)
+                    (lambda (,@as ,@dd2)
                       (,(C 'with-return) ,r
                        ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                                ,(with-fluids ((return r))
                                   (exp ns code))))))))
                 
-                `(define ,f
-                   (letrec ((,f
-                             (case-lambda
-                               ((,ex ,@as)
-                                (,f ,@as))
-                               ((,@as)
-                                (,(C 'with-return) ,r
-                                 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
-                                         ,(with-fluids ((return r))
-                                            (exp ns code)))))))))
-                     ,f)))
+                `(define ,f (lambda (,@as ,@dd2)
+                               (,(C 'with-return) ,r
+                                ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
+                                        ,(with-fluids ((return r))
+                                           (exp ns code))))))))
             
             (if y?
                 `(define ,f
                    (,(C 'def-wrap) ,y? ,f ,ab
-                    (lambda (,@as)
+                    (lambda (,@as ,@dd2)
                       (,(C 'with-return) ,r
                        (let ,(map (lambda (x) (list x #f)) ls)
                          ,(with-fluids ((return r))
                             (mk
                              (exp ns code))))))))
                 `(define ,f
-                   (lambda (,@as)
+                   (lambda (,@as ,@dd2)
                      (,(C 'with-return) ,r
                       (let ,(map (lambda (x) (list x #f)) ls)
                         ,(with-fluids ((return r))
                            (exp ns code))))))))))))
-   
+  
   (#:global
    ((_ . _)
     '(values)))
-    
+  
   (#:lambdef
    ((_ v e)
     (list `lambda v (exp vs e))))
-
+  
   (#:stmt
    ((_ l)
     (if (> (length l) 1)
         (cons 'values (map (g vs exp) l))
         (exp vs (car l)))))
-     
+  
 
   (#:expr-stmt
    ((_ (l) (#:assign))
     (exp vs l))
-
+   
    ((_ l type)
     (=> fail)
     (call-with-values
@@ -708,6 +714,8 @@
 
 (define (exp vs x)
   (match (pr x)
+    ((e)
+     (exp vs e))
     ((tag . l)
      ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs))
 
diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm
new file mode 100644
index 0000000..64ff6e4
--- /dev/null
+++ b/modules/language/python/list.scm
@@ -0,0 +1,26 @@
+(define-module (language python list)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (language python yield)
+  #:use-module (language python for)
+  #:use-module (language python exceptions)
+  #:export (to-list))
+
+
+(define-method (to-list x)
+  (if (vector? x)
+      (vector->list x)
+      x))
+
+(define-method (to-list (x <p>))
+  ((ref x '__tolist__ (lambda () (error "missing __tolist__ in object")))))
+
+(define-method (to-list (x <yield>))
+  (define l '())
+  (catch StopIteration
+    (lambda ()
+      (let lp ()
+        (set! l (cons (next x) l))
+        (lp)))
+    (lambda x
+      (reverse l))))
-- 
cgit v1.2.3