diff options
| -rw-r--r-- | modules/language/python/compile.scm | 129 | ||||
| -rw-r--r-- | modules/oop/pf-objects.scm | 7 |
2 files changed, 104 insertions, 32 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 241005c..81de0c3 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -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))) @@ -180,6 +180,8 @@ (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) @@ -249,10 +251,13 @@ ((#: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)))))) @@ -405,15 +410,22 @@ `(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")) @@ -422,7 +434,8 @@ `(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) @@ -465,12 +478,20 @@ ((#: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 @@ -939,7 +960,7 @@ (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))) @@ -962,9 +983,55 @@ (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) @@ -1000,26 +1067,28 @@ (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))))) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 29d8fc9..515af74 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -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)) |