compiles to bytecode, fails to load
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Sun, 8 Apr 2018 19:30:12 +0000 (21:30 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Sun, 8 Apr 2018 19:30:12 +0000 (21:30 +0200)
modules/language/python/compile.scm
modules/language/python/def.scm
modules/language/python/module/python.scm
modules/language/python/try.scm
modules/oop/pf-objects.scm

index a039ee15e7e0ebceee52a5fe050f8b1abd17d0c1..e5bc219856ce1c3fad465f8f42f2d38099c965f7 100644 (file)
 
     ((#: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)
   (let lp ((arg arg))
     (match arg
       (((#:* x) . arg)
-       (cons (exp vs (car x))
+       (cons (list '* (exp vs (car x)))
              (lp arg)))
 
       ((x . args)
   (let lp ((arg arg))
     (match arg
       (((#:** x) . arg)
-       (cons (exp vs (car x))
+       (cons (list '** (exp vs (car x)))
              (lp arg)))
 
       ((x . args)
                   ,(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)
 
  (#: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)
   ((_ . 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
           (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
    (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?))
           (y   'scm.yield)
           (y.f (gen-yield f))
           (ls  (diff (diff ns vs) df)))
-     
+   
      (define (mk code)
        `(let-syntax ((,y   (syntax-rules ()
                              ((_ . args)
      (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
                                 (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
 
 (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))
 
 (define (gentemp stx) (datum->syntax stx (gensym "x")))
 
-(define-syntax for
+(define-syntax cfor
   (syntax-rules ()
     ((_ (x) (a) code #f #f)
      (if (pair? a)
            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 ()
index 06e83e62f4eb1c1fdfc7bc6df75566ad9a8f9542..5c83b6f8de3fcc8580945e26a2f086333ec67bb3 100644 (file)
     ((_ (*  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  
index 99db1c21712a75ecb0c295a78a9748d00e0ce1a1..30434afd20f52ad05002c66bb21832ae80ab0bc1 100644 (file)
   (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)
           #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)
index 36d9b04f3e12d717ca58bca1e04a57d31291345c..68a9b5d6f4e753160743734641df1a6f3aad3717 100644 (file)
          (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)
index 8ac2325a60b6119f3bd8c96bfb7a2a3971b9ddc3..2e9f9d284d44d3cc43a9fe87ed9dee5e592a50e0 100644 (file)
@@ -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 ()