try works

2 files changed, 152 insertions, 98 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index c11bd76..a1c6509 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -14,16 +14,10 @@
     (set! (@@ (system base message) %dont-warn-list) '())
     #f))
 
-(define-syntax dont-warn
-  (lambda (x)
-    (syntax-case x ()
-      ((_ d)
-       #t
-       (begin
-         (set! (@@ (system base message) %dont-warn-list)
-           (cons (syntax->datum #'d)
-                 (@@ (system base message) %dont-warn-list)))
-         #f)))))
+(define (dont-warn v)
+  (set! (@@ (system base message) %dont-warn-list)
+    (cons v
+          (@@ (system base message) %dont-warn-list))))
 
 (define-syntax call
   (syntax-rules ()
@@ -101,19 +95,33 @@
 
 (define (scope x vs)
   (match x
-    ((#:def  (#:identifier f . _) . _)
-     (union (list (string->symbol f)) vs))
+    ((#:def f . _)
+     (union (list (exp '() f)) vs))
+
     ((#:lambdef . _)
      vs)
-    ((#:classdef . _)
-     vs)
+    
+    ((#:classdef f . _)
+     (union (list (exp '() f)) vs))
+
     ((#:global . _)
      vs)
-    ((#:identifier v . _)
-     (let ((s (string->symbol v)))
-       (if (member s vs)
-           vs
-           (cons s vs))))
+    
+    ((#:expr-stmt l (#:assign u))
+     (union (fold (lambda (x s)
+                   (match x
+                     ((#:test (#:power v2 v1 () . _) . _)
+                      (if v2
+                          (union
+                           (union (list (exp '() v1))
+                                  (list (exp '() v2)))
+                           s)
+                          (union (list (exp '() v1)) s)))
+                     (() s)))
+                  '()              
+                  l)
+            vs))
+    
     ((x . y)
      (scope y (scope x vs)))
     (_ vs)))
@@ -241,12 +249,6 @@
     
     ((#:suite . l) (cons 'begin (map (g vs exp) l)))
 
-    ((#:try x #f #f fin)
-     `(dynamic-wind
-        (lambda () #f)
-        (lambda () ,(exp vs x))
-        (lambda () ,(exp vs fin))))
-
     ((#:while test code #f)
      (let ((lp (gensym "lp")))
        `(let ,lp ()
@@ -312,7 +314,9 @@
                                 (l l))
                              #:dynamic
                              ())))))))
-                          
+
+    ((#:import ((() nm) . #f))
+     `(use-modules (language python module ,(exp vs nm))))
        
     (#:break
      (C 'break))
@@ -391,41 +395,75 @@
     ((#:while test code else)
      (let ((lp (gensym "lp")))
        `(let ,lp ()
-          (if test
-              (begin
-                ,(exp vs code)
-                (,lp))
-              ,(exp vs else)))))
-    
-    ((#:try x exc else fin)
-     (define (f x)
-       (match else
-         ((#f x)
-          `(catch #t
-             (lambda () ,x)
-             (lambda ,(gensym "x") ,(exp vs x))))))
-    
+             (if test
+                 (begin
+                   ,(exp vs code)
+                   (,lp))
+                 ,(exp vs else)))))
+
+    ((#:try x (or #f ()) #f . fin)
      `(dynamic-wind
         (lambda () #f)
-        (lambda ()
-          ,(f
-            (let lp ((code (exp vs x)) (l (reverse exc)))                    
-              (match l
-                ((((e) c) . l)
-                 (lp `(catch ,(exp vs e)
-                        (lambda () ,code)
-                        (lambda ,(gensym "x")
-                          ,(exp vs c))) l))
-                ((((e . as) c) . l)
-                 (lp `(let ((,as ,(exp vs e)))
-                        (catch ,as
-                          (lambda () ,code)
-                          (lambda ,(gensym "x")
-                            ,(exp vs c)))) l))
+        (lambda () ,(exp vs x))
+        (lambda () ,(exp vs fin))))
+
+    ((#:try x exc else . fin)
+     (define (guard x)
+       (if fin
+           `(dynamic-wind
+              (lambda () #f)
+              (lambda () ,x)
+              (lambda () ,(exp vs fin)))
+           x))
+     (define tag (gensym "tag"))
+     (define o   (gensym "o"))
+     (define l   (gensym "l"))
+     (guard
+      `(catch #t
+         (lambda () ,(exp vs x))         
+         (lambda (,tag ,o . ,l)
+           ,(let lp ((it  (if else (exp vs else) `(apply throw ,tag ,l)))
+                     (exc  exc))
+              (match exc
+                ((((test . #f) code) . exc)
+                 (lp `(if (,(O 'testex) ,tag ,o ,(exp vs test) ,l)
+                          ,(exp vs code)
+                          ,it)
+                     exc))
+                ((((test . as) code) . exc)
+                 (let ((a (exp vs as)))
+                   (lp `(if (,(O 'testex) ,o ,tag ,(exp vs test) ,l)
+                            (let ((,a ,o))
+                              (,(O 'set) ,a '__excargs__ ,l)
+                              ,(exp vs code))
+                            ,it)
+                       exc)))
                 (()
-                 code))))
-          (lambda () ,(exp vs fin)))))
+                 it)))))))
 
+    ((#:raise #f   . #f)
+     `(throw 'python (,(O 'Exception))))
+    
+    ((#:raise code . #f)
+     (let ((c (gensym "c")))
+       `(throw 'python
+               (let ((,c ,(exp vs code)))
+                 (if (,(O 'pyclass?) ,c)
+                     (,c)
+                     ,c)))))
+    
+    ((#:raise code . from)
+     (let ((o (gensym "o"))
+           (c (gensym "c")))              
+       `(throw 'python
+               (let ((,c ,(exp vs code)))
+                 (let ((,o (if (,(O 'pyclass?) ,c)
+                               (,c)
+                               ,c)))
+                   (,(O 'set) ,o '__cause__ ,(exp vs from))
+                   ,o)))))
+             
+      
     ((#:yield args)
      `(scm-yield ,@(gen-yargs vs args)))
 
@@ -468,27 +506,42 @@
        
        (with-fluids ((is-class? #f))
          (if c?
-             `(define ,f
-                (,(C 'def-wrap) ,y? ,f ,ab
-                  (letrec ((,f
-                            (case-lambda
-                              ((,ex ,@as)
-                               (,f ,@as))
-                              ((,@as)
-                               (,(C 'with-return) ,r
+             (if y?
+                 `(define ,f
+                    (,(C 'def-wrap) ,y? ,f ,ab
+                     (lambda (,@as)
+                       (,(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
-                (,(C 'def-wrap) ,y? ,f ,ab
-                  (lambda (,@as)
-                    (,(C 'with-return) ,r
-                     (let ,(map (lambda (x) (list x #f)) ls)
-                       ,(with-fluids ((return r))
-                          (mk
-                           (exp ns code))))))))))))
+                                          ,(with-fluids ((return r))
+                                             (exp ns code)))))))))
+                      ,f)))
+
+             (if y?
+                 `(define ,f
+                    (,(C 'def-wrap) ,y? ,f ,ab
+                     (lambda (,@as)
+                       (,(C 'with-return) ,r
+                        (let ,(map (lambda (x) (list x #f)) ls)
+                          ,(with-fluids ((return r))
+                             (mk
+                              (exp ns code))))))))
+                 `(define ,f
+                    (lambda (,@as)
+                      (,(C 'with-return) ,r
+                       (let ,(map (lambda (x) (list x #f)) ls)
+                         ,(with-fluids ((return r))
+                            (exp ns code)))))))))))
      
     ((#:global . _)
      '(values))
@@ -569,7 +622,8 @@
                 arglist))
 
          `((,(G 'define-module)
-            (language python module ,@args)))))
+            (language python module ,@args)
+            #:use-module (language python module python)))))
       (x '())))
   
   (if (pair? start)
@@ -580,7 +634,7 @@
        ,@start
        ,(C 'clear-warning-data)
        (set! (@@ (system base message) %dont-warn-list) '())
-       ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
+       ,@(map (lambda (s) `(,(C 'var) ',s)) globs)
        ,@(map (g globs exp) x))))
 
 (define-syntax-parameter break
@@ -742,12 +796,12 @@
              #`(let/ec ret #,code)
              code))))))
 
-(define-syntax-rule (var v)
+(define (var v)
   (begin
     (dont-warn v)
-    (if (defined? 'v)
+    (if (module-defined? (current-module) v)
         (values)
-        (define! 'v #f))))
+        (define! v #f))))
 
 (define-inlinable (non? x) (eq? x #:nil))
 
diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm
index c22c0b4..0cfb83a 100644
--- a/modules/language/python/spec.scm
+++ b/modules/language/python/spec.scm
@@ -36,19 +36,19 @@
   #:evaluator	(lambda (x module) (primitive-eval x))
   #:printer	write
   #:make-default-environment
-                (lambda ()
-                  ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
-                  ;; `fluid-set!', etc. don't have any effect in the current environment.
-                  (let ((m (make-fresh-user-module)))                    
-                    ;; Provide a separate `current-reader' fluid so that
-                    ;; compile-time changes to `current-reader' are
-                    ;; limited to the current compilation unit.
-                    (module-define! m 'current-reader (make-fluid))
-
-                    ;; Default to `simple-format', as is the case until
-                    ;; (ice-9 format) is loaded.  This allows
-                    ;; compile-time warnings to be emitted when using
-                    ;; unsupported options.
-                    (module-set! m 'format simple-format)
-                    
-                    m)))
+  (lambda ()
+    ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
+    ;; `fluid-set!', etc. don't have any effect in the current environment.
+    (let ((m (make-fresh-user-module)))                    
+      ;; Provide a separate `current-reader' fluid so that
+      ;; compile-time changes to `current-reader' are
+      ;; limited to the current compilation unit.
+      (module-define! m 'current-reader (make-fluid))
+      
+      ;; Default to `simple-format', as is the case until
+      ;; (ice-9 format) is loaded.  This allows
+      ;; compile-time warnings to be emitted when using
+      ;; unsupported options.
+      (module-set! m 'format simple-format)
+      
+      m)))