small steps

[software/python-on-guile.git] / modules / oop / pf-objects.scm

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 86f2e2c688bc2f47b9ba76fc488702102959a586..4d0b697686c165cb4dbdca6e856b773a6a6a7a3b 100644 (file)
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -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)