refactoring scheme macros out from the compilier

1 files changed, 11 insertions, 119 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 962c877..e74b9f2 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -3,9 +3,12 @@
   #:use-module (ice-9 control)
   #:use-module (oop pf-objects)
   #:use-module (oop goops)
+  #:use-module (language python exceptions)
+  #:use-module (language python yield)
+  #:use-module (language python for)
+  #:use-module (language python try)
   #:use-module (ice-9 pretty-print)
-  #:replace (send)
-  #:export (comp sendException sendClose))
+  #:export (comp))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
@@ -44,6 +47,7 @@
   x)
 
 (define (C x) `(@@ (language python compile) ,x))
+(define (Y x) `(@@ (language python yield) ,x))
 (define (O x) `(@@ (oop pf-objects) ,x))
 (define (G x) `(@ (guile) ,x))
 
@@ -302,7 +306,7 @@
 
     (#:True  #t)
     (#:False #f)
-    
+    (#:pass  `(values))
     ((#:while test code . #f)
      (let ((lp (gensym "lp")))
        `(let ,lp ()
@@ -357,8 +361,8 @@
                                  'mk-p-class
                                  'mk-py-class)))              
                 (parents (filt parents)))
-           `(define ,class (,(O 'wrap)
-                            (,(O kind)
+           `(define ,class (,(O 'wrap) ,class
+                            (,(O kind) 
                              ,class
                              ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
                              #:const
@@ -531,7 +535,7 @@
     ((#:yield args)
      (let ((f (gensym "f")))
        `(begin
-          (set! ,(C 'inhibit-finally) #t)
+          (fluid-set! ,(Y 'in-yield) #t)
           (let ((,f (scm.yield ,@(gen-yargs vs args))))
             (,f)))))
 
@@ -1021,116 +1025,6 @@
                                (lp)))))
                        (lambda e else))))))))))))
     
-
-(define-class <scm-list>   () l)
-(define-class <scm-string> () s i)
-(define-class <yield>      () s k closed)
-  
-(define-method (next (l <scm-list>))
-  (let ((ll (slot-ref l 'l)))
-    (if (pair? ll)
-        (begin
-          (slot-set! l 'l (cdr ll))
-          (car ll))
-        (throw StopIteration))))
-
-(define-method (next (l <scm-string>))
-  (let ((s (slot-ref l 's))
-        (i (slot-ref l 'i)))
-    (if (= i (string-length s))
-        (throw StopIteration)
-        (begin
-          (slot-set! l 'i (+ i 1))
-          (string-ref s i)))))
-
-(define-method (next (l <yield>))
-  (let ((k (slot-ref l 'k))
-        (s (slot-ref l 's)))
-    (if k
-        (k (lambda () 'None))
-        (s))))
-
-(define-method (send (l <yield>) . u)
-  (let ((k (slot-ref l 'k))
-        (s (slot-ref l 's))
-        (c (slot-ref l 'closed)))
-    (if (not c)
-        (if k
-            (k (lambda ()
-                 (if (null? u)
-                     'Null
-                     (apply values u))))
-            (throw 'python (Exception))))))
-
-
-(define-method (sendException (l <yield>) e . ls)
-  (let ((k (slot-ref l 'k))
-        (s (slot-ref l 's))
-        (c (slot-ref l 'closed)))
-    (if (not c)
-        (if k
-            (k (lambda () (throw 'python (apply e ls))))
-            (throw 'python (Exception))))))
-
-(define-method (sendClose (l <yield>))
-  (let ((k (slot-ref l 'k))
-        (s (slot-ref l 's))
-        (c (slot-ref l 'closed)))
-    (if c
-        (values)
-        (if k
-            (catch #t
-              (lambda ()
-                (k (lambda () (throw 'python GeneratorExit)))
-                (slot-set! l 'closed #t)
-                (throw 'python RuntimeError))
-              (lambda (k tag . v)
-                (slot-set! l 'closed #t)
-                (if (eq? tag 'python)
-                    (match v
-                      ((tag . l)
-                       (if (eq? tag GeneratorExit)
-                           (values)
-                           (apply throw 'python tag l))))
-                    (apply throw tag v))))
-            (slot-set! l 'closed #t)))))
-
-(define-method (send (l <p>) . u)
-  (apply (ref l '__send__) u))
-
-(define-method (sendException (l <p>) . u)
-  (apply (ref l '__exception__) u))
-
-(define-method (sendClose (l <p>))
-  ((ref l '__close__)))
-
-(define-method (next (l <p>))
-  ((ref l '__next__)))
-
-
-
-(define-method (wrap-in  (x <p>))
-  (aif it (ref x '__iter__ #f)
-       (it)
-       x))
-
-(define-method (wrap-in x)
-  (cond
-   ((pair? x)
-    (let ((o (make <scm-list>)))
-      (slot-set! o 'l x)
-      o))
-   
-   ((string? x)
-    (let ((o (make <scm-string>)))
-      (slot-set! o 's x)
-      (slot-set! o 'i 0)
-      o))
-   
-   (else
-    x)))
-
-(define yield-prompt (list 'yield))
 (define-syntax def-wrap
   (lambda (x)
     (syntax-case x ()
@@ -1156,7 +1050,7 @@
                            (throw StopIteration))
                          (letrec ((lam
                                    (lambda (k . l)
-                                     (set! inhibit-finally #f)
+                                     (fluid-set! in-yield #f)
                                      (slot-set! obj 'k
                                                 (lambda (a)
                                                   (call-with-prompt
@@ -1168,8 +1062,6 @@
                            lam))))
            obj)))))
                       
-
-                      
 (define-syntax ref-x
   (syntax-rules ()
     ((_ v)