small steps
[software/python-on-guile.git] / modules / oop / pf-objects.scm
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)