module support
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 15 Mar 2018 16:56:01 +0000 (17:56 +0100)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 15 Mar 2018 16:56:01 +0000 (17:56 +0100)
modules/language/python/dir.scm
modules/language/python/module.scm [new file with mode: 0644]
modules/oop/pf-objects.scm

index da07642cc43c680b353acafbea9cadb025ff3c23..e41e2357a5f3c354fa7e333ea24687628279a98a 100644 (file)
 
 (define (chash-for-each f c)
   (let ((h (slot-ref c 'h)))
-  (if (is-a? c <pf>)
-      (let ((hh (make-hash-table)))
-        (vhash-fold
-         (lambda (k v s)
-           (when (not (hash-ref hh k))
-             (hash-set! hh k #t)
-             (f k v))
-           s) #f h))
-      (hash-for-each f h))))
+    (if (is-a? c <pf>)
+       (let ((hh (make-hash-table)))
+         (vhash-fold
+          (lambda (k v s)
+            (when (not (hash-ref hh k))
+                  (hash-set! hh k #t)
+                  (f k v))
+            s) #f h))
+       (hash-for-each f h))))
 
 (define (get-from-class c f)
   (let lp ((pl (ref c '__mro__)))
   (if (not (pyclass? o))
       (aif it (ref o '__dir__)
            (it)
-           (aif it (ref o '__dict__)
-                (let ((l (pylist)))
-                  (for ((k v : it)) ()
-                       (pylist-append! l k))
-                  (pylist-sort! l)
-                  l)
-                (let* ((h (make-hash-table))
-                       (c (ref o '__class__))
-                       (l '())
-                       (f (lambda (k v) (set! l (cons k l)))))
-                  (chash-for-each f o)
-                  (get-from-class c f)
-                  (hash-for-each (lambda (k v) (pylist-append! l k)) h)
-                  (to-pylist (map symbol->string (sort l <))))))
+          (begin
+            (let ((l1 (aif it (ref o '__dict__)
+                           (let ((l (pylist)))
+                             (for ((k v : it)) ()
+                                  (pylist-append! l k))
+                             (pylist-sort! l)
+                             l)
+                           (pylist))))
+              (let* ((h (make-hash-table))
+                     (c (ref o '__class__))
+                     (l '())
+                     (f (lambda (k v) (set! l (cons k l)))))
+                (chash-for-each f o)
+                (get-from-class c f)
+                (hash-for-each (lambda (k v) (pylist-append! l k)) h)
+                (+ (pylist (map symbol->string (sort l <))) l1)))))
       (let* ((h (make-hash-table))
              (c o)
              (l '())
diff --git a/modules/language/python/module.scm b/modules/language/python/module.scm
new file mode 100644 (file)
index 0000000..615d163
--- /dev/null
@@ -0,0 +1,123 @@
+(define-module (language python module)
+  #:use-module (oop pf-objects)
+  #:use-module (ice-9 match)
+  #:use-module (language python exceptions)
+  #:use-module (language python yield)
+  #:use-module (language python try)
+  #:use-module (language python dir)
+  #:export (Module))
+
+(define e (list 'e))
+
+(define _k
+  (lambda (k)
+    (if (string? k)
+       (string->symbol k)
+       k)))
+
+(define _m
+  (lambda (self)
+    (if (rawref self '_private)
+       (rawref self '_module)
+       (rawref self '_export))))
+
+(define-python-class Module ()
+  (define __setprivate__
+    (lambda (self p)
+      (set self '_isprivate p)))
+
+  (define __init__
+    (case-lambda
+     ((self pre l nm)
+      (match l
+       ((name)
+        (_make self (cons name pre) (cons name nm)))
+       ((name . (and l (name2 . _)))
+        (set self name2 (Module (cons name pre) l (cons name nm)))
+        (_make self (cons name pre) (cons name nm)))))
+     
+     ((self l)     
+      (if (pair? l)
+         (if (and (> (length l) 3)
+                  (equal? (list (list-ref l 0)
+                                (list-ref l 1)
+                                (list-ref l 2))
+                          '(language python module)))
+             (__init__ self (reverse '(language python module)) (cdddr l) '())
+             (_make self l l))
+         (__init__ self
+                   (map string->symbol
+                        (string-split l #\.)))))))
+  (define _make
+    (lambda (self l nm)
+      (begin
+       (set self '_private #f)
+       (set self '__dict__ self)
+       (set self '__name__ (string-join (map symbol->string (reverse nm)) "."))
+       (let ((_module (resolve-module (reverse l))))
+         (set self '_export (module-public-interface _module))
+         (set self '_module _module)))))
+    
+  (define __getattribute__
+    (lambda (self k . l)
+      (define (fail)
+       (if (pair? l)
+           (car l)
+           (raise KeyError "getattr in Module")))
+      (if (rawref self '_module)
+         (let ((k (_k k))
+               (m (_m self)))
+           (let ((x (module-ref m k e)))
+             (if (eq? e x)
+                 (fail)
+                 x)))
+         (fail))))
+
+  (define __setattr__
+    (lambda (self k v)
+      (let ((k     (_k k))
+           (fail  (lambda () (raise KeyError "getattr in Module"))))
+       (if (rawref self k)
+           (fail)
+           (if (rawref self '_module)
+               (let ((m (_m self)))
+                 (catch #t
+                        (lambda ()
+                          (if (module-defined? m k)
+                              (module-set! m k v)
+                              (module-define! m k v)))                 
+                        (lambda x (pk 'fail x))))
+               (fail))))))
+
+  (define __delattr__
+    (lambda (self k)
+      (define (fail) (raise KeyError "getattr in Module"))
+      (if (rawref self '_module)
+         (let ((m (_m self))
+               (k (_k k)))
+           (if (module-defined? m k)
+               (module-remove!  m k)
+               (raise KeyError "delattr of missing key in Module")))
+         (fail))))
+
+  (define __repr__
+    (lambda (self) (ref self '__name__)))
+
+  (define __getitem__
+    (lambda (self k)
+      (define k (if (string? k) (string->symbol k) k))
+      (__getattr__ self k)))
+  
+  (define __iter__
+    (lambda (self)
+      (define m (_m self))
+      ((make-generator ()
+        (lambda (yield)
+          (define l '())
+          (define (f k v) (set! l (cons (list (symbol->string k) v) l)))
+          (module-for-each f m)
+          (let lp ((l l))
+            (if (pair? l)
+                (begin
+                  (apply yield (car l))
+                  (lp (cdr l)))))))))))
index f80a2d2a15517757da7b77e364dba376c9199161..5b7806332c89e6ffb258e14e4bb3dd58eec158fb 100644 (file)
@@ -13,7 +13,7 @@
                 py-super-mac py-super py-equal? 
                 *class* *self* pyobject? pytype?
                 type object pylist-set! pylist-ref tr
-               resolve-method
+               resolve-method rawref
                 ))
 
 #|
@@ -153,7 +153,8 @@ explicitly tell it to not update etc.
          (type- meta name parents dict keys))))
 
 (define (create-object class meta goops x)
-  (aif it #f ;(ref meta '__call__)
+  (with-fluids ((*make-class* #t))
+    (aif it #f ;(ref meta '__call__)
        (apply it x)       
        (let ((obj (aif it (find-in-class class '__new__ #f)
                        ((it class 'object))
@@ -166,7 +167,7 @@ explicitly tell it to not update etc.
                       (aif it (ref obj '__call__)
                            (apply it x)
                            (error "not a callable object"))))
-         obj)))
+         obj))))
 
 (define (make-object class meta goops)
   (let ((obj (make-p goops)))
@@ -288,16 +289,20 @@ explicitly tell it to not update etc.
                   (if (eq? g #t)
                       (aif it (mrefx xx '__getattribute__ '())
                            (begin
-                             (set xx '__fget__ it)
+                             (mset xx '__fget__ it it)
                              it)
                            (begin
-                             (set xx '__fget__ it)
+                             (if (mc?)
+                                 (mset xx '__fget__ it it))
                              #f))
                       g)
                   #f)))
        (if (or (not f) (eq? f not-implemented))
           (mrefx xx key l)
-          (apply f xx key l))))))
+          (catch #t
+                 (lambda () ((f xx (fluid-ref *refkind*)) key))
+                 (lambda x
+                   (mrefx xx key l))))))))
 
 
 (define-syntax-rule (mref x key l)
@@ -320,6 +325,10 @@ explicitly tell it to not update etc.
 (define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
 (define-method (ref (x <py> )  key . l) (mref-py  x key l))
 
+(define-method (rawref (x <pf> )  key . l) (mref     x key l))
+(define-method (rawref (x <p>  )  key . l) (mref     x key l))
+
+
 (define-method (set (f <procedure>) key val)
   (set-procedure-property! f key val))
 
@@ -351,7 +360,7 @@ explicitly tell it to not update etc.
     (values)))
 
 ;; on object x add a binding that key -> val
-(define-method (mset (x <pf>) key val)
+(define-method (mset (x <pf>) key rval val)
   (let ((h (slot-ref x 'h))
         (s (slot-ref x 'size))
         (n (slot-ref x 'n)))
@@ -366,33 +375,39 @@ explicitly tell it to not update etc.
 
 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
 
-(define-method (mset (x <p>) key val)
+(define-method (mset (x <p>) key rval val)
   (begin
     (hash-set! (slot-ref x 'h) key val)
     (values)))
 
-(define-syntax-rule (mset-py x key val)
-  (let* ((v (mref x key (list fail))))
-    (if (or (eq? v fail) (not (and (is-a? v <property>) (not (pyclass? x)))))
-       (let* ((g (mrefx x '__fset__ '(#t)))
+(define *make-class* (make-fluid #f))
+(define (mc?) (not (fluid-ref *make-class*)))
+
+(define-syntax-rule (mset-py x key rval val)
+  (let* ((xx x)
+        (v  (mref xx key (list fail))))
+    (if (or (eq? v fail)
+           (not (and (is-a? v <property>)
+                     (not (pyclass? xx)))))
+       (let* ((g (mrefx xx '__fset__ '(#t)))
               (f (if g
                      (if (eq? g #t)
-                         (let ((class (aif it (mref x '__class__ '())
-                                           it
-                                           x)))
-                           (aif it (mrefx x '__setattr__ '())
-                                (begin
-                                  (mset class '__fset__ it)
-                                  it)
-                                (begin
-                                  (mset class '__fset__ it)
-                                  #f)))
+                         (aif it (mrefx xx '__setattr__ '())
+                              (begin
+                                (mset xx '__fset__ it it)
+                                it)
+                              (begin
+                                (if (mc?)
+                                    (mset xx '__fset__ it it))
+                                #f))
                          g)
                      #f)))
          (if (or (eq? f not-implemented) (not f))
-             (mset x key val)              
-             (f key val)))
-       ((slot-ref v 'set) x val))))
+             (mset xx key val val)              
+             (catch #t
+               (lambda () ((f xx (fluid-ref *refkind*)) key rval))
+               (lambda x (mset xx key val val)))))
+       ((slot-ref v 'set) xx val))))
 
 (define-syntax-rule (mklam (mset a ...) val)
   (if (and (procedure? val)
@@ -402,9 +417,9 @@ explicitly tell it to not update etc.
                (ref val '__call__)
                #t))
       (if (procedure-property val 'py-special)
-          (mset a ... val)
-          (mset a ... (object-method val)))
-      (mset a ... val)))
+          (mset a ... val val)
+          (mset a ... val (object-method val)))
+      (mset a ... val val)))
 
 (define-method (set (x <pf>)  key val) (mklam (mset     x key) val))
 (define-method (set (x <p>)   key val) (mklam (mset     x key) val))
@@ -489,12 +504,12 @@ explicitly tell it to not update etc.
 ;; x untouched
 (define-method (fset (x <pf>) key val)
   (let ((x (mcopy x)))
-    (mset x key val)
+    (mset x key val val)
     x))
 
 (define-method (fset (x <p>) key val)
   (let ((x (mcopy- x)))
-    (mset x key val)
+    (mset x key val val)
     x))
 
 (define (fset-x obj l val)
@@ -702,8 +717,9 @@ explicitly tell it to not update etc.
     (pylist-set! dict '__class__   meta)
     (pylist-set! dict '__mro__     (get-mro parents))
     dict)
-  
-  (create-class meta name parents gen-methods kw))
+
+  (with-fluids ((*make-class* #t))
+    (create-class meta name parents gen-methods kw)))
 
 
 ;; Let's make an object essentially just move a reference