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>
   #: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
             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>))
           s))))
 
 (define-method (py-hash (x <p>))
-  (aif it (pk 'it (ref x '__hash__))
+  (aif it (ref x '__hash__)
        (pk 'hash (it))
        (next-method)))
 
        (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 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)))
   #: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
       (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 '__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))))))
       
              (set self '_module _module)
              (hash-set! _modules l self))))))
       
-  (define __getattribute__
+  (define __getattr__
     (lambda (self k)
       (define (fail)
     (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)
 
   (define __setattr__
     (lambda (self k v)
                (raise KeyError "delattr of missing key in Module")))
          (fail))))
 
                (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))
   (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)
   
   (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)))
         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.'
         # 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
 
         # 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.
         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")))
 
        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)
 (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 (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
 (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__)
 (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))))
 
 
          (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)
 (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))
         (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)
 
 
 (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)))
     (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)
        (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)))
       (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)
            
                 (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)
                 (apply it class p #f kw)
-                #f))))
+                #f)
+           
+           (lp (cdr mro)))))
+    
     (set class '__mro__ (cons class (find-in-class-and-parents
                                     class '__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)
     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)
 
 
 (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))))
          (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)
     (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"))))
                  (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)
     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)
        (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)
     (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)
                  ((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))))
 
 (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))
          (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
     (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)
              (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__ '())
 (define-inlinable (mrefx-py x key l)
   (let ((xx x))
     (let* ((f (aif it (mrefx xx '__getattribute__ '())
-                   (gox xx it)
+                   it
                    #f)))
                    #f)))
-      (if (or (not f) (eq? f not-implemented))
+      (if (or (not f) (eq? f not-implemented))   
           (gox xx (mrefx xx key l))
           (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))
 
 (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)))))
        
                (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))
             (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)
     (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))
                                it
                                sups))
                         supers))
@@ -1114,19 +1131,20 @@ explicitly tell it to not update etc.
   (define (make cl parents)
     (if (not cl)
         #f
   (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 ()
   
   (call-with-values
       (lambda ()
@@ -1231,7 +1249,10 @@ explicitly tell it to not update etc.
          (up (car h) (cdr h))
          #f)))))
 
          (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
 
 (define (find-tree o tree)
   (if tree
@@ -1298,25 +1319,33 @@ explicitly tell it to not update etc.
 
 (define __getattribute__
   (case-lambda
 
 (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))
                          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__)
 
              
 (define attr __getattribute__)
 
@@ -1331,12 +1360,15 @@ explicitly tell it to not update etc.
 
 (set type '__class__ type)
 
 
 (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)
 (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)
                
 
 (name-object type)