compiles to bytecode, fails to load

5 files changed, 152 insertions, 84 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index a039ee1..e5bc219 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -178,13 +178,22 @@
 
     ((#:lambdef . _)
      vs)
+
+    ((#:with (l ...) code)
+     (scope code (union vs
+                  (let lp ((l l))
+                    (match l
+                     (((a b) . l)
+                      (cons (exp '() b) (lp l)))
+                     ((x . l) (lp l))
+                     (() '()))))))
     
     ((#:classdef f . _)
      (union (list (exp '() f)) vs))
 
     ((#:global . _)
      vs)
-
+                
     ((#:import (#:name ((ids ...) . as)) ...)
      (let lp ((ids ids) (as as) (vs vs))
        (if (pair? as)
@@ -445,7 +454,7 @@
   (let lp ((arg arg))
     (match arg
       (((#:* x) . arg)
-       (cons (exp vs (car x))
+       (cons (list '* (exp vs (car x)))
              (lp arg)))
 
       ((x . args)
@@ -458,7 +467,7 @@
   (let lp ((arg arg))
     (match arg
       (((#:** x) . arg)
-       (cons (exp vs (car x))
+       (cons (list '** (exp vs (car x)))
              (lp arg)))
 
       ((x . args)
@@ -635,23 +644,6 @@
                   ,(if op
                        `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
                        u)))))))))
-
-(define (filter-defs x)
-  (match (let lp ((x x))
-           (match x
-             ((('begin . l))
-              (lp (cons 'begin l)))
-             (('begin . l)
-              (let lp ((l l))
-                (match l
-                  ((('values) . l)
-                   (lp l))
-                  ((x . l)
-                   (cons x (lp l)))
-                  (x x))))))
-    (('begin)
-     '())
-    (x x)))
                   
 (define is-class? (make-fluid #f))
 (define (gen-yargs vs x)
@@ -813,12 +805,31 @@
 
  (#:with
   ((_ (l ...) code)
-   (let ((l (map (lambda (x)
-		   (match x
-		     ((a b) (list (exp vs a) (exp vs b)))
-		     ((b)   (list (exp vs b)))))
-		 l)))
-     `(,(W 'with) ,l ,(exp vs code)))))
+   (let* ((l (map (lambda (x)
+                    (match x
+                      ((a b) (list (exp vs b) (gensym "as") (exp vs a)))
+                      ((b)   (list (exp vs b)))))
+                  l))
+          (vs (union vs (let lp ((l l))
+                          (match l
+                            (((x) . l) (lp l))
+                            (((a b c) . l) (cons a (lp l)))
+                            (() '()))))))
+
+     (define (f x)
+       (match x
+         ((a b c) (list 'set! a b))
+         ((a) (list (G 'values)))))
+     
+     (define (g x)
+       (match x
+         ((a b c) (list b c))
+         ((a)     (list a))))
+     
+     `(,(W 'with) ,(map g l)
+       (,(G 'begin)
+        ,@(map f l)
+        ,(exp vs code))))))
    
  (#:if
   ((_ test a ((tests . as) ...) . else)
@@ -832,34 +843,33 @@
   ((_ . l) (cons 'begin (map (g vs exp) l))))
     
  (#:classdef
-   ((_ class parents defs)
+   ((_ class parents code)
     (with-fluids ((is-class? #t))
       (let ()
         (let* ((decor   (let ((r (fluid-ref decorations)))
                           (fluid-set! decorations '())
-                          r))
+                          r))               
                (class   (exp vs class))
+               (vs  (union (list class) vs))
+               (ns  (scope code vs))
+               (ls  (diff ns vs))
+
                (parents (match parents
                           (() #f)
                           (#f #f)
                           ((#:arglist . _)
                            (get-addings vs (list parents))))))
-          `(define ,class
+          `(set! ,class
              (,(C 'class-decor) ,decor
               (,(C 'with-class) ,class
-               (,(C 'mk-p-class)
+               (,(C 'mk-p-class2)
                 ,class                
                 ,(if parents
                      `(,(C 'ref-x) ,(C 'arglist->pkw) ,@parents)
                      `(,(G 'cons) '() '()))
-                ,@(match (filter-defs (exp vs defs))
-                    (('begin . l)
-                     l)
-                    ((('begin . l))
-                     l)
-                    (l l)))))))))))
-
- (#:verb
+                ,(map (lambda (x) `(define ,x #f)) ls)
+                ,(exp vs code))))))))))
+(#:verb
   ((_ x) x))
  
  (#:scm
@@ -977,7 +987,7 @@
           (p     (is-ec #t code2 #t (list (C 'break) (C 'continue))))
           (else2 (if else (exp vs2 else) #f))
           (in2   (map (g vs exp) in)))
-     (list (C 'for) es2 in2 code2 else2 p))))
+     (list (C 'cfor) es2 in2 code2 else2 p))))
  
 
  (#:while
@@ -1074,7 +1084,7 @@
    (let* ((decor   (let ((r (fluid-ref decorations)))
                           (fluid-set! decorations '())
                           r))
-          (args (get-args_ vs args))	  
+          (arg_ (get-args_ vs args))	  
 	  (arg= (get-args= vs args))
 	  (dd=  (map cadr arg=))
           (c?   (fluid-ref is-class?))
@@ -1093,7 +1103,7 @@
           (y   'scm.yield)
           (y.f (gen-yield f))
           (ls  (diff (diff ns vs) df)))
-     
+   
      (define (mk code)
        `(let-syntax ((,y   (syntax-rules ()
                              ((_ . args)
@@ -1106,19 +1116,19 @@
      (with-fluids ((is-class? #f))
        (if c?
            (if y?
-               `(define ,f
+               `(set! ,f
                   (,(C 'def-decor) ,decor
                    (,(C 'def-wrap) ,y? ,f ,ab
-                    (,(D 'lam) (,@args ,@*f ,@arg= ,@**f)
+                    (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f)
                      (,(C 'with-return) ,r
                       ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                               (,(C 'with-self) ,c? ,args
                                ,(with-fluids ((return r))
                                    (exp ns code))))))))))
                
-               `(define ,f
+               `(set! ,f
                   (,(C 'def-decor) ,decor
-                   (,(D 'lam) (,@args ,@*f ,@arg= ,@**f)
+                   (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f)
                     (,(C 'with-return) ,r
                      ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                              (,(C 'with-self) ,c? ,args
@@ -1126,19 +1136,19 @@
                                 (exp ns code))))))))))
             
            (if y?
-               `(define ,f
+               `(set! ,f
                   (,(C 'def-decor) ,decor
                    (,(C 'def-wrap) ,y? ,f ,ab
-                    (,(D 'lam) (,@args ,@*f ,@arg= ,@**f)
+                    (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f)
                      (,(C 'with-return) ,r 
                       (let ,(map (lambda (x) (list x #f)) ls)
                         (,(C 'with-self) ,c? ,args
                          ,(with-fluids ((return r))
                             (mk
                              (exp ns code))))))))))
-               `(define ,f
+               `(set! ,f
                   (,(C 'def-decor) ,decor
-                   (,(D 'lam) (,@args ,@*f ,@arg= ,@**f)
+                   (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f)
                     (,(C 'with-return) ,r 
                      (let ,(map (lambda (x) (list x #f)) ls)
                        (,(C 'with-self) ,c? ,args
@@ -1345,24 +1355,26 @@
 
 (define (comp x)
   (define start
-    (match (pr 'start x)
+    (match x
       (((#:stmt
          ((#:expr-stmt
            ((#:test
              (#:power #f
               (#:identifier "module" . _)
-              ((#:arglist arglist #f #f))
+              ((#:arglist arglist))
               . #f) #f))
-           (#:assign)))) . _)
+           (#:assign)))) . rest)
+
        (let ()
          (define args
            (map (lambda (x)
                   (exp '() x))
                 arglist))
 
-         `((,(G 'define-module)
-            (language python module ,@args)
-            #:use-module (language python module python)))))
+         `((,(G 'define-module) (language python module ,@args)
+            #:use-module (language python module python))
+           (define __doc__    #f)
+           (define __module__ '(language python module ,@args)))))
       (x '())))
   
   (if (fluid-ref (@@ (system base compile) %in-compile))
@@ -1570,7 +1582,7 @@
 
 (define (gentemp stx) (datum->syntax stx (gensym "x")))
 
-(define-syntax for
+(define-syntax cfor
   (syntax-rules ()
     ((_ (x) (a) code #f #f)
      (if (pair? a)
@@ -1804,29 +1816,30 @@
            obj)))))
                       
 (define-syntax ref-x
-  (syntax-rules ()
-    ((_ v)
-     v)
-    ((_ v (#:fastfkn-ref f _) . l)
-     (ref-x (lambda x (if (py-class? v) (apply f x) (apply f v x))) . l))
-    ((_ v (#:fast-id f _) . l)
-     (ref-x (f v) . l))
-    ((_ v (#:identifier x) . l)
-     (ref-x (ref v x) . l))
-    ((_ v (#:identifier x) . l)
-     (ref-x (ref v x) . l))
-    ((_ v (#:call-obj x) . l)
-     (ref-x (x v) . l))
-    ((_ v (#:call x ...) . l)
-     (ref-x (v x ...) . l))
-    ((_ v (#:apply x ...) . l)
-     (ref-x (py-apply v x ...) . l))
-    ((_ v (#:apply x ...) . l)
-     (ref-x (py-apply v x ...) . l))
-    ((_ v (#:vecref x) . l)
-     (ref-x (pylist-ref v x) . l))
-    ((_ v (#:vecsub . x) . l)
-     (ref-x (pylist-slice v . x) . l))))
+  (lambda (x)
+    (syntax-case x ()
+      ((_ v)
+       #'v)
+      ((_ v (#:fastfkn-ref f _) . l)
+       #'(ref-x (lambda x (if (py-class? v) (apply f x) (apply f v x))) . l))
+      ((_ v (#:fast-id f _) . l)
+       #'(ref-x (f v) . l))
+      ((_ v (#:identifier x) . l)
+       #'(ref-x (ref v x) . l))
+      ((_ v (#:identifier x) . l)
+       #'(ref-x (ref v x) . l))
+      ((_ v (#:call-obj x) . l)
+       #'(ref-x (x v) . l))
+      ((_ v (#:call x ...) . l)
+       #'(ref-x (v x ...) . l))
+      ((_ v (#:apply x ...) . l)
+       #'(ref-x (py-apply v x ...) . l))
+      ((_ v (#:apply x ...) . l)
+       #'(ref-x (py-apply v x ...) . l))
+      ((_ v (#:vecref x) . l)
+       #'(ref-x (pylist-ref v x) . l))
+      ((_ v (#:vecsub . x) . l)
+       #'(ref-x (pylist-slice v . x) . l)))))
 
 (define-syntax del-x
   (syntax-rules ()
diff --git a/modules/language/python/def.scm b/modules/language/python/def.scm
index 06e83e6..5c83b6f 100644
--- a/modules/language/python/def.scm
+++ b/modules/language/python/def.scm
@@ -130,9 +130,8 @@
     ((_ (*  a)) a)
     ((_ (** kw))
      (for ((k v : kw)) ((l '()))
-	  (cons* v (mk-k k) l)
-
-	  #:final (reverse l)))
+       (cons* v (mk-k k) l)
+       #:final (reverse l)))
     ((_ a) (list a))))
 
 (define-syntax py-apply  
diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm
index 99db1c2..30434af 100644
--- a/modules/language/python/module/python.scm
+++ b/modules/language/python/module/python.scm
@@ -122,6 +122,7 @@
   (let ((r (ref a (symbol->string b) miss)))
     (not (eq? r miss))))
 
+(define-method (issubclass x y) #f)
 (define-method (issubclass (sub <p>) (cls <p>))
   (aif it (ref cls '__subclasscheck__)
        (it cls sub)
@@ -129,6 +130,7 @@
 	   #t
 	   (is-a? (ref sub '__goops__) (ref cls '__goops__)))))
 
+(define-method (isinstance x y) #f)
 (define-method (isinstance (o <p>) (cl <p>))
   (aif it (ref cl '__instancecheck__)
        (it o)
diff --git a/modules/language/python/try.scm b/modules/language/python/try.scm
index 36d9b04..68a9b5d 100644
--- a/modules/language/python/try.scm
+++ b/modules/language/python/try.scm
@@ -67,9 +67,14 @@
          (lam tag l)
          (handler ecx tag l)))
 
+    ((handler ((#:except E) . ecx) tag l)
+     (if (check-exception E tag l)
+         (begin (values))
+         (handler ecx tag l)))
+
     ((handler ((#:except E code ...) . ecx) tag l)
      (if (check-exception E tag l)
-         (nbegin code ...)
+         (begin code ...)
          (handler ecx tag l)))
 
     ((handler ((#:else code ...)) tag l)
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 8ac2325..2e9f9d2 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -10,7 +10,7 @@
   #:export (set ref make-p <p> <py> <pf> <pyf> <property>
                 call with copy fset fcall put put!
                 pcall pcall! get fset-x pyclass?                
-                def-p-class   mk-p-class   make-p-class
+                def-p-class   mk-p-class   make-p-class mk-p-class2
                 define-python-class define-python-class-noname
 		get-type py-class
                 object-method class-method static-method
@@ -856,6 +856,55 @@ explicitly tell it to not update etc.
 	    (name-object name)
 	    name))))))
 
+(define-syntax mk-p-class2
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name parents ((ddef dname dval) ...) body)
+       #'(mk-p-class name parents "" (ddef dname dval) ...))
+      ((_ name parents doc (ddef dname dval) ...)
+       (with-syntax (((ddname ...)
+		      (map (lambda (dn)
+			     (datum->syntax
+			      #'name
+			      (string->symbol
+			       (string-append
+				(symbol->string
+				 (syntax->datum #'name))
+				"-"
+				(symbol->string
+				 (syntax->datum dn))))))
+			   #'(dname ...)))
+		     (nname (datum->syntax
+			     #'name
+			     (string->symbol
+			      (string-append
+			       (symbol->string
+				(syntax->datum #'name))
+			       "-goops-class")))))
+	 (%add-to-warn-list (syntax->datum #'nname))
+         (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
+              #'(ddname ...))
+	#'(let ()
+	    (define name 
+	      (letruc ((dname (make-up dval)) ...)
+                     body
+		     (make-p-class 'name doc
+				    parents
+				    (lambda (dict)
+				      (pylist-set! dict 'dname dname)
+				      ...
+				      (values)))))
+
+	    (begin
+	      (module-define! (current-module) 'ddname (ref name 'dname))
+	      (name-object ddname))
+	    ...
+
+	    (module-define! (current-module) 'nname (ref name '__goops__))
+	    (name-object nname)
+	    (name-object name)
+	    name))))))
+
 (define-syntax mk-p-class-noname
   (lambda (x)
     (syntax-case x ()