Better python semantics is now followed
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Mon, 11 Sep 2017 23:14:19 +0000 (01:14 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Mon, 11 Sep 2017 23:14:19 +0000 (01:14 +0200)
modules/language/python/compile.scm
modules/oop/pf-objects.scm

index 241005c260f435b1f7b55c613978168e27e2b339..81de0c3dc71698ae1cca9744acf0a4744d547a68 100644 (file)
@@ -4,7 +4,7 @@
   #:use-module (oop pf-objects)
   #:use-module (oop goops)
   #:use-module (ice-9 pretty-print)
-  #:export (comp))
+  #:export (comp send sendException sendClose))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
   (match (pr 'yarg x)    ((#:list args)
      (map (g vs exp) args))))
 
+(define inhibit-finally #f)
+
 (define (exp vs x)
   (match (pr x)
     ((#:power _ (x) () . #f)
     
     ((#:suite . l) (cons 'begin (map (g vs exp) l)))
 
-    ((#:while test code #f)
+    (#:True  #t)
+    (#:False #f)
+    
+    ((#:while test code . #f)
      (let ((lp (gensym "lp")))
        `(let ,lp ()
-          (if test
+          (if ,(exp vs test)
               (begin
                 ,(exp vs code)
                 (,lp))))))
      `(dynamic-wind
         (lambda () #f)
         (lambda () ,(exp vs x))
-        (lambda () ,(exp vs fin))))
+        (lambda ()
+          (if (not ,(C 'inhibit-finally))
+              ,(exp vs fin)))))
 
+    ((#:subexpr . l)
+     (exp vs l))
+    
     ((#:try x exc else . fin)
      (define (guard x)
        (if fin
            `(dynamic-wind
               (lambda () #f)
               (lambda () ,x)
-              (lambda () ,(exp vs fin)))
+              (lambda ()
+                (if (not ,(C 'inhibit-finally))
+                    ,(exp vs fin))))
            x))
      (define tag (gensym "tag"))
      (define o   (gensym "o"))
       `(catch #t
          (lambda () ,(exp vs x))         
          (lambda (,tag ,o . ,l)
-           ,(let lp ((it  (if else (exp vs else) `(apply throw ,tag ,o ,l)))
+           ,(let lp ((it  (if else (exp vs else) `(apply throw 'python
+                                                         ,tag ,o ,l)))
                      (exc  exc))
               (match exc
                 ((((test . #f) code) . exc)
              
       
     ((#:yield args)
-     `(scm.yield ,@(gen-yargs vs args)))
+     (let ((f (gensym "f")))
+       `(begin
+          (set! ,(C 'inhibit-finally) #t)
+          (let ((,f (scm.yield ,@(gen-yargs vs args))))
+            (,f)))))
 
     
     ((#:yield f args)
-     (let ((f (gen-yield (exp vs f))))
-       `(,f ,@(gen-yargs vs args))))
+     (let ((f (gen-yield (exp vs f)))
+           (g (gensym "f")))
+       `(begin
+          (set! ,(C 'inhibit-finally) #t)
+          (let ((,g (,f ,@(gen-yargs vs args))))
+            (,g)))))
     
     ((#:def f
             (#:types-args-list
 
 (define-class <scm-list>   () l)
 (define-class <scm-string> () s i)
-(define-class <yield>      () s k)
+(define-class <yield>      () s k closed)
   
 (define-method (next (l <scm-list>))
   (let ((ll (slot-ref l 'l)))
   (let ((k (slot-ref l 'k))
         (s (slot-ref l 's)))
     (if k
-        (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 (wrap-in  (x <p>))
   (aif it (ref x '__iter__ #f)
        (it)
            (define obj   (make <yield>))
            (define ab (make-prompt-tag))
            (slot-set! obj 'k #f)
+           (slot-set! obj 'closed #f)
            (slot-set! obj 's
-                (lambda ()
-                  (let/ec return                          
-                    (call-with-prompt
-                     ab
-                     (lambda ()
-                       (apply code x)
-                       (throw StopIteration))
-                     (letrec ((lam
-                               (lambda (k . l)
-                                 (slot-set! obj 'k
-                                            (lambda ()
-                                              (call-with-prompt
-                                               ab
-                                               (lambda ()
-                                                 (k)
-                                                 (throw StopIteration))
-                                               lam)))
-                                 (apply values l))))
-                       lam)))))
+                      (lambda ()
+                        (call-with-prompt
+                         ab
+                         (lambda ()
+                           (let/ec return                          
+                             (apply code x))
+                           (slot-set! obj 'closed #t)
+                           (throw StopIteration))
+                         (letrec ((lam
+                                   (lambda (k . l)
+                                     (set! inhibit-finally #f)
+                                     (slot-set! obj 'k
+                                                (lambda (a)
+                                                  (call-with-prompt
+                                                   ab
+                                                   (lambda ()
+                                                     (k a))
+                                                   lam)))
+                                     (apply values l))))
+                           lam))))
            obj)))))
                       
 
index 29d8fc957e7bea5df4917a65586e5c0f5081f43a..515af74bb38795f2aa70c9af73f4e38ad5c052a4 100644 (file)
@@ -10,7 +10,7 @@
                 def-p-class   mk-p-class   make-p-class
                 def-pyf-class mk-pyf-class make-pyf-class
                 def-py-class  mk-py-class  make-py-class
-                StopIteration
+                StopIteration GeneratorExit RuntimeError
                 Exception))
 
 #|
@@ -593,6 +593,9 @@ explicitly tell it to not update etc.
        (error "not a class")))
 
 (define StopIteration 'StopIteration)
+(define GeneratorExit 'GeneratorExit)
+(define RuntimeError  'RuntimeError)
+
 (define-method (next (o <p>))
   (catch StopIteration
     (lambda () ((ref o '__next__)))
@@ -631,7 +634,7 @@ explicitly tell it to not update etc.
         (lambda (cl)
           (testex py tag cl l)))
        (else
-        #f))
+        (eq? tag ex)))
       #f))