From f3f0828d3dda8045d538eaacc4e5384e9c835c56 Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Thu, 14 Sep 2017 23:25:49 +0200
Subject: refactoring scheme macros out from the compilier

---
 modules/language/python/compile.scm    | 130 +++------------------------------
 modules/language/python/exceptions.scm |  33 +++++++++
 modules/language/python/for.scm        |  60 ++++++++++++++-
 modules/language/python/try.scm        |  94 ++++++++++++++++++++++++
 modules/language/python/yield.scm      | 116 +++++++++++++++++++++++++++++
 5 files changed, 313 insertions(+), 120 deletions(-)
 create mode 100644 modules/language/python/exceptions.scm
 create mode 100644 modules/language/python/try.scm
 create mode 100644 modules/language/python/yield.scm

(limited to 'modules/language')

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)
diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm
new file mode 100644
index 0000000..57690aa
--- /dev/null
+++ b/modules/language/python/exceptions.scm
@@ -0,0 +1,33 @@
+(define-module (language python exceptions)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:export (StopIteration GeneratorExit RuntimeError
+                          Exception))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define StopIteration 'StopIteration)
+(define GeneratorExit 'GeneratorExit)
+(define RuntimeError  'RuntimeError)
+
+(define-python-class Exception ()
+  (define __init__
+    (case-lambda
+      ((self)
+       (values))
+      ((self str)
+       (set self 'str str))))
+                 
+  (define __repr__
+    (lambda (self . l)
+      (define port (if (pair? l) (car l) #f))
+      (aif it (ref self 'str)
+           (format port "~s: ~a"
+                   (ref self '__name__) it)
+           (format port "~s"
+                   (ref self '__name__))))))
+
+
+
+
+            
diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm
index 47f6992..f23ce6e 100644
--- a/modules/language/python/for.scm
+++ b/modules/language/python/for.scm
@@ -1,7 +1,12 @@
 (define-module (language python for)
+  #:use-module (language python yield)
   #:use-module (oop pf-objects)
+  #:use-module (language python exceptions)
+  #:use-module (oop goops)
   #:use-module (ice-9 control)
-  #:export (for break))
+  #:export (for break next write))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
 (eval-when (compile eval load)
   (define (generate-temporaries2 x)
@@ -129,6 +134,59 @@
                    (lambda q (values)))))))))))
 
 
+(define-class <scm-list>   () l)
+(define-class <scm-string> () s i)
+  
+(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 (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)))
+
+
 #;
 (pk
  (for c ((x : (gen '(1 2 3)))) ((s 0))
diff --git a/modules/language/python/try.scm b/modules/language/python/try.scm
new file mode 100644
index 0000000..2d10ad2
--- /dev/null
+++ b/modules/language/python/try.scm
@@ -0,0 +1,94 @@
+(define-module (language python try)
+  #:use-module (language python exceptions)
+  #:use-module (language python yield)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:export (raise try))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define-method (check (class <class> ) obj l) (is-a? obj class))
+(define-method (check (s     <symbol>) obj l) (eq? obj s))
+(define-method (check (p  <procedure>) obj l)
+  (aif it (procedure-property p 'pyclass)
+       (is-a? obj it)
+       (p obj l)))
+  
+(define-syntax compile-error
+  (lambda (x)
+    (syntax-case x ()
+      ((_ x)
+       (error (syntax->datum #'x))))))
+
+(define-syntax check-exception
+  (syntax-rules (and or not)
+    ((_ (or E ...) tag l)
+     (or (check-exception E tag l) ...))
+    ((_ (and E ...) tag l)
+     (and (check-exception E tag l) ...))
+    ((_ (not E) tag l)
+     (not (check-exception E tag l)))
+    ((_ E tag l)
+     (check E tag l))))
+
+(define-syntax handler
+  (syntax-rules ()
+    ((handler ecx)
+     (lambda x
+       (match x
+         ((_ 'python tag . l)
+          (handler ecx tag l))
+         ((k . x)
+          (apply throw x)))))
+    
+    ((handler ((#:except E => lam) . ecx) tag l)
+     (if (check-exception E tag l)
+         (lam tag l)
+         (handler ecx tag l)))
+
+    ((handler ((#:except E code ...) . ecx) tag l)
+     (if (check-exception E tag l)
+         (begin code ...)
+         (handler ecx tag l)))
+
+    ((handler ((#:else code ...)) tag l)
+     (begin code ...))
+
+    ((handler () tag l)
+     (apply throw 'python tag l))
+
+    ((a ...)
+     (compile-error "not a proper python macro try block"))))
+
+    
+    
+(define-syntax try
+  (syntax-rules ()
+    ((try  code exc ... #:finally fin)
+     (dynamic-wind
+       (lambda () #f)
+       (lambda ()
+         (catch #t
+           (lambda () code)
+           (handler (exc ...))))
+       (lambda ()
+         (if (not (fluid-ref in-yield))
+             fin))))
+
+    ((try  code exc ...)
+     (catch #t
+       (lambda () code)
+       (handler (exc ...))))))
+  
+
+(define raise
+  (case-lambda
+    (() (raise Exception))
+    ((x)
+     (if (procedure? x)
+         (if (procedure-property x 'pyclass)
+             (throw 'python (x))
+             (throw 'python x))
+         (throw 'python x)))))
diff --git a/modules/language/python/yield.scm b/modules/language/python/yield.scm
new file mode 100644
index 0000000..289eb4d
--- /dev/null
+++ b/modules/language/python/yield.scm
@@ -0,0 +1,116 @@
+(define-module (language python yield)
+  #:use-module (oop pf-objects)
+  #:use-module (language python exceptions)
+  #:use-module (oop goops)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:replace (send)
+  #:export (<yield> in-yield yield define-generator
+                    make-generator
+                    sendException sendClose))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define in-yield (make-fluid #f))
+
+(define-syntax-parameter YIELD (lambda (x) #f))
+
+(define-syntax yield
+  (lambda (x)
+    (syntax-case x ()
+      ((_ x ...)
+       #'(begin
+           (fluid-set! in-yield #t)
+           abort-to-prompt YIELD x ...))
+      (x
+       #'(lambda x
+           (fluid-set! in-yield #t)
+           (apply abort-to-prompt YIELD x))))))
+
+(define-syntax-rule (make-generator (args) code ...)
+  (lambda args
+    (let ()
+      (define obj   (make <yield>))
+      (define ab (make-prompt-tag))
+      (syntax-parameterize ((YIELD (lambda x #'ab)))
+        (slot-set! obj 'k #f)
+        (slot-set! obj 'closed #f)
+        (slot-set! obj 's
+                   (lambda ()
+                     (call-with-prompt
+                      ab
+                      (lambda ()
+                        code ...
+                        (slot-set! obj 'closed #t)
+                        (throw StopIteration))
+                      (letrec ((lam
+                                (lambda (k . l)
+                                  (set! in-yield #f)
+                                  (slot-set! obj 'k
+                                             (lambda (a)
+                                               (call-with-prompt
+                                                ab
+                                                (lambda ()
+                                                  (k a))
+                                                lam)))
+                                  (apply values l))))
+                        lam))))
+        ob))))
+
+(define-syntax-rule (define-generator (f . args) code ...)
+  (define f (make-generator args code ...)))
+(define-class <yield>      () s k closed)
+
+(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 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__)))
-- 
cgit v1.2.3