small steps
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 18 Apr 2018 12:58:45 +0000 (14:58 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 18 Apr 2018 12:58:45 +0000 (14:58 +0200)
modules/language/python/dict.scm
modules/language/python/hash.scm
modules/language/python/module.scm
modules/language/python/module/enum.py
modules/oop/pf-objects.scm

index 977d5e14fde7a0ed1702bef703ee6742f2a74b93..f76e2ad019fb3d1700fd6b809bef83b7e18c8cea 100644 (file)
@@ -13,7 +13,7 @@
   #:use-module (oop goops)
   #:use-module (oop pf-objects)  
   #:export (make-py-hashtable <py-hashtable>
-            py-copy py-fromkeys py-get py-has_key py-items py-iteritems
+            py-copy py-fromkeys py-has_key py-items py-iteritems
             py-iterkeys py-itervalues py-keys py-values
             py-popitem py-setdefault py-update py-clear
             py-hash-ref dict pyhash-listing
index 4fab02d11495c48fa3bc6ce22c565be43893b856..168cd44079e4b4a6a3742c0964be31d6811f2d60 100644 (file)
@@ -42,7 +42,7 @@
           s))))
 
 (define-method (py-hash (x <p>))
-  (aif it (pk 'it (ref x '__hash__))
+  (aif it (ref x '__hash__)
        (pk 'hash (it))
        (next-method)))
 
index ab963d180ebe7d236cf2cb6dd940e2d590fb5466..5c5d630354a3f357373510ecf7fc8af1dcba81fe 100644 (file)
@@ -7,6 +7,7 @@
   #:use-module (language python yield)
   #:use-module (language python try)
   #:use-module (language python dir)
+  #:use-module (language python list)
   #:export (Module private public import))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
       (rawset self '_private #f)
       (if (not (rawref self '_module))
          (begin
-           (set self '__dict__ self)
            (set self '__name__ (string-join
                                 (map symbol->string (reverse nm)) "."))
            (let* ((_module (in-scheme (resolve-module (reverse l))))
              (set self '_module _module)
              (hash-set! _modules l self))))))
       
-  (define __getattribute__
+  (define __getattr__
     (lambda (self k)
       (define (fail)
-       (raise (KeyError "getattr in Module")))
-      (aif it (rawref self k)
-           it
-           (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)))))
+       (raise (AttributeError "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)
                (raise KeyError "delattr of missing key in Module")))
          (fail))))
 
+  (define __dir__
+    (lambda (self)
+      (let* ((h (slot-ref self 'h))
+            (l '())
+            (add (lambda (k . u) (set! l (cons (symbol->string k) l)))))
+       (hash-for-each add h)
+       (aif it (ref self '_module)
+            (module-for-each add it)
+            #f)
+       (py-list l))))
+       
+  
   (define __repr__
     (lambda (self) (format #f "Module(~a)" (ref self '__name__))))
 
   (define __getitem__
     (lambda (self k)
       (define k (if (string? k) (string->symbol k) k))
-      (__getattribute__ self k)))
+      (__getattr__ self k)))
   
   (define __iter__
     (lambda (self)
index 7e7e46ceda49306e98fd1ee43b7301bb6cd88a79..eefc1b50bf3a024910e52560a77ad9a6f98cc477 100644 (file)
@@ -150,7 +150,7 @@ class EnumMeta(type):
         if invalid_names:
             raise ValueError('Invalid enum member name: {0}'.format(
                 ','.join(invalid_names)))
-
+        
         # create a default docstring if one has not been provided
         if '__doc__' not in classdict:
             classdict['__doc__'] = 'An enumeration.'
@@ -164,7 +164,7 @@ class EnumMeta(type):
 
         # save attributes from super classes so we know if we can take
         # the shortcut of storing members in the class dict
-
+        
         base_attributes = {a for b in enum_class.mro() for a in b.__dict__}
 
         # Reverse value->name map for hashable values.
index 86f2e2c688bc2f47b9ba76fc488702102959a586..4d0b697686c165cb4dbdca6e856b773a6a6a7a3b 100644 (file)
@@ -78,6 +78,9 @@ explicitly tell it to not update etc.
        it
        (error "IndexError")))
 
+(define-method (py-get x key . l)
+  (if (pair? l) (car l) #f))
+
 (define-method (py-get (o <hashtable>) key . l)
   (define -fail (if (pair? l) (car l) #f))
   (kif it (hash-ref o key fail)
@@ -121,6 +124,7 @@ explicitly tell it to not update etc.
 (define-method (rawset (o <procedure>) key val)
   (set-procedure-property! o key val))
 
+(define-method (find-in-class x key fail) fail)
 (define-method (find-in-class (klass <pf>) key fail)
   (let ((r (vhash-assoc key (slot-ref klass 'h))))
     (if r
@@ -130,7 +134,9 @@ explicitly tell it to not update etc.
 (define-method (find-in-class (klass <p>) key -fail)
   (let ((h (slot-ref klass 'h)))
     (aif dict (hash-ref h '__dict__)
-         (py-get dict key -fail)
+         (kif it (py-get dict key fail)
+             it
+             (hash-ref h key -fail))
          (hash-ref h key -fail))))
 
 
@@ -152,7 +158,7 @@ explicitly tell it to not update etc.
 (define (mk-getter-object f)
   (lambda (obj cls)
     (if (pytype? obj)
-       (lambda x (apply f x))
+       f
         (if (pyclass? obj)
             (if (pytype? cls)                
                 (lambda x (apply f obj x))
@@ -223,9 +229,10 @@ explicitly tell it to not update etc.
 
 
 (define (new-class0 meta name parents dict . kw)
-  (let* ((goops (pylist-ref dict '__goops__))
-        (p     (kwclass->class kw meta))         
-        (class (make-p p)))
+  (let* ((goops   (pylist-ref dict '__goops__))
+        (p       (kwclass->class kw meta))
+        (class   (make-p p)))
+    
     (slot-set! class 'procedure
               (lambda x
                 (create-object class x)))
@@ -234,20 +241,31 @@ explicitly tell it to not update etc.
        (hash-for-each
         (lambda (k v) k (set class k v))
         dict)
-        (set class '__dict__ dict))
+        (begin (set class '__dict__ dict)))
     
-    (let ((mro (ref class '__mro__)))
+    (let lp ((mro (find-in-class class '__mro__ #f)))
       (if (pair? mro)
          (let ((p (car mro)))
-           (aif it (ref p '__zub_classes__)
+           (aif it (find-in-class p '__zub_classes__ #f)
                 (hash-set! it class #t)
                 #f)
            
-           (aif it (ref p '__init_subclass__)
+           (aif it (find-in-class p '__init_subclass__ #f)
                 (apply it class p #f kw)
-                #f))))
+                #f)
+           
+           (lp (cdr mro)))))
+    
     (set class '__mro__ (cons class (find-in-class-and-parents
                                     class '__mro__ '())))
+
+    (if (not (ficap class '__getattribute__ #f))
+       (set class '__getattribute__ attr))
+    (if (not (ficap class 'mro #f))
+       (set class 'mro _mro))
+
+    (set class '__class__ meta)
+    
     class))
 
 (define (new-class meta name parents dict kw)
@@ -264,12 +282,11 @@ explicitly tell it to not update etc.
 
 
 (define (the-create-object class x)
-  (let* ((meta  (ficap class '__class__ #f))
-         (goops (ficap class '__goops__ #f))
+  (let* ((meta  (and class (find-in-class class '__class__ #f)))
+         (goops (find-in-class class '__goops__ #f))
          (obj   (aif it (ficap class '__new__ #f)
                      (apply it class x)
                      (make-object class meta goops))))
-    
     (aif it (ficap class '__init__ #f)
          (apply it obj x)
          #f)
@@ -279,13 +296,13 @@ explicitly tell it to not update etc.
                  (aif it (ref obj '__call__)
                       (apply it x)
                       (error "not a callable object"))))
-
+    
     obj))
 
 (define (create-object class x)
   (if (pytype? class)
       (apply type-call class x)
-      (let ((meta (find-in-class class '__class__ #f)))
+      (let ((meta (and class (find-in-class class '__class__ #f))))
        (with-fluids ((*make-class* #t))
          (aif it (ficap meta '__call__ #f)
               (apply it class x)
@@ -296,7 +313,7 @@ explicitly tell it to not update etc.
     (if (pytype? class)
         (apply (case-lambda
                  ((meta obj)
-                  (ref obj '__class__ 'None))
+                  (and obj (find-in-class obj '__class__ 'None)))
                  ((meta name bases dict . keys)
                   (type- meta name bases dict keys)))
                class l)
@@ -309,7 +326,7 @@ explicitly tell it to not update etc.
 
 (define (create-class meta name parents gen-methods keys)
   (let ((dict (gen-methods (get-dict meta name parents))))
-    (aif it (ref meta '__class__)
+    (aif it (and meta (find-in-class meta '__class__ #f))
          (aif it (find-in-class it '__call__ #f)
               (apply it meta name parents dict keys)
               (type- meta name parents dict keys))
@@ -398,7 +415,7 @@ explicitly tell it to not update etc.
     (fluid-set! *location* klass)
     (kif it (find-in-class-and-parents klass key fail)
         it
-        (aif klass (find-in-class klass '__class__ #f)
+        (aif klass (and klass (find-in-class klass '__class__ #f))
              (begin
                (fluid-set! *location* klass)
                (kif it (find-in-class-and-parents klass key fail)
@@ -411,13 +428,13 @@ explicitly tell it to not update etc.
 (define-inlinable (mrefx-py x key l)
   (let ((xx x))
     (let* ((f (aif it (mrefx xx '__getattribute__ '())
-                   (gox xx it)
+                   it
                    #f)))
-      (if (or (not f) (eq? f not-implemented))
+      (if (or (not f) (eq? f not-implemented))   
           (gox xx (mrefx xx key l))
-         (catch #t
-            (lambda () (f key))
-            (lambda z  (pk z) (if (pair? l) (car l) #f)))))))
+         (kif it (f xx key)
+              it
+              (if (pair? l) (car l) #f))))))
 
 (define-syntax-rule (mref x key l)
   (let ((xx x))
@@ -524,7 +541,7 @@ explicitly tell it to not update etc.
                (lambda () (f key val))
                (lambda q  (mset xx key val)))))
        
-       (aif it (ref v '__class__)
+       (aif it (and v (find-in-class v '__class__ #f))
             (aif it (ref it '__set__)
                  (it val)
                  (mset xx key val))
@@ -780,7 +797,7 @@ explicitly tell it to not update etc.
     (define kw      (cdr s.kw))
     (define supers  (car s.kw))
     (define goopses (map (lambda (sups)
-                          (aif it (ref sups '__goops__ #f)
+                          (aif it (find-in-class sups '__goops__ #f)
                                it
                                sups))
                         supers))
@@ -1114,19 +1131,20 @@ explicitly tell it to not update etc.
   (define (make cl parents)
     (if (not cl)
         #f
-        (if (or (pyclass? obj) (pytype? obj))
-            cl
-            (let ((c (make-p <py>))
-                  (o (make-p <py>)))
-              (set c '__class__        type)
-              (set c '__mro__          (cons c parents))
-              (set c '__getattribute__
-                   (object-method
-                    (lambda (self key . l)
-                      (ficap c key #f))))
-              (set c '__name__  "**super**")
-              (set o '__class__ c)
-              o))))
+        (let ((c (make-p <py>))
+             (o (make-p <py>)))
+         (set c '__class__        type)
+         (set c '__mro__          (cons* c parents))
+         (set c '__getattribute__
+              (lambda (self key)
+                (kif it (ficap c key fail)
+                     (aif dt (ref it '__get__)
+                          (dt obj cl)
+                          it)
+                     fail)))
+         (set c '__name__  "**super**")
+         (set o '__class__ c)
+         o)))
   
   (call-with-values
       (lambda ()
@@ -1231,7 +1249,10 @@ explicitly tell it to not update etc.
          (up (car h) (cdr h))
          #f)))))
 
-(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__bases__))))
+(define (class-to-tree cl)
+  (cons cl
+       (map class-to-tree
+            (find-in-class cl '__bases__ #f))))
 
 (define (find-tree o tree)
   (if tree
@@ -1298,25 +1319,33 @@ explicitly tell it to not update etc.
 
 (define __getattribute__
   (case-lambda
-    ((self key)
-     (aif class (find-in-class self '__class__ #f)
-          (kif it1 (find-in-class-and-parents self key fail)
-               (aif dd1 (ref it1 '__get__)
-                    (if (ref it1 '__set__)
-                        (dd1 self class)
-                        (kif it2 (find-in-class self key fail)
-                             it2
-                             (it1 self class)))
-                    (kif it2 (find-in-class self key fail)
+   ((self key)
+    (define (-fail class)
+      (if (eq? key 'mro)
+         (find-in-class self '__mro__ fail)
+         fail))
+    
+    (aif class (find-in-class self '__class__ #f)
+        (kif it1 (find-in-class-and-parents class key fail)
+             (aif dd1 (rawref it1 '__get__)
+                  (if (rawref it1 '__set__)
+                      (dd1 self class)
+                      (kif it2 (find-in-class-and-parents self key fail)
+                           it2
+                           (dd1 self class)))
+                    (kif it2 (find-in-class-and-parents self key fail)
                          it2
                          it1))
-               (kif it2 (find-in-class self key fail)
-                    it2
-                    (aif it (ref self '__getattr__)
-                         (it key)
-                         (error "AttributeError" key))))
-          (error "AttributeError" "could not find class" key)))
-    (l (error "AttributeError" "wrong arguments BUG" l))))
+             (kif it2 (find-in-class-and-parents self key fail)
+                  it2
+                  (aif it (find-in-class-and-parents class '__getattr__ #f)
+                       (kif it1 (it self key)
+                            (aif dd1 (rawref it1 '__get__)
+                                 (dd1 self class)
+                                 it1)
+                            (-fail class))
+                       (-fail class))))
+        fail))))
              
 (define attr __getattribute__)
 
@@ -1331,12 +1360,15 @@ explicitly tell it to not update etc.
 
 (set type '__class__ type)
 
+(define _mro (object-method (lambda (self) (ref self '__mro__))))
+
 (set! object
   (make-python-class object ()
     (define __init__         (lambda x (values)))
     (define __subclasses__   subclasses)
-    (define __getattribute__ (object-method attr))
-    (define __weakref__      (lambda (self) self))))
+    (define __getattribute__ attr)
+    (define __weakref__      (lambda (self) self))
+    (define mro              _mro)))
                
 
 (name-object type)