further improvements following python3 spec
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Tue, 17 Apr 2018 18:48:45 +0000 (20:48 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Tue, 17 Apr 2018 18:48:45 +0000 (20:48 +0200)
modules/language/python/module.scm
modules/oop/pf-objects.scm

index 53aa1c2941046f7a30eb201bf70c55e4c4ee3e32..ab963d180ebe7d236cf2cb6dd940e2d590fb5466 100644 (file)
   (define __getattribute__
     (lambda (self k)
       (define (fail)
-       (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))))
+       (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)))))
 
   (define __setattr__
     (lambda (self k v)
index 37ed5f081a6811a023272967fda14490af889a86..86f2e2c688bc2f47b9ba76fc488702102959a586 100644 (file)
@@ -8,7 +8,7 @@
   #:use-module (logic guile-log persistance)
   #:replace (equal?)  
   #:export (set ref make-p <p> <py> <pf> <pyf> <property>
-                call with copy fset fcall put put!
+                call with copy fset fcall put put! py-get
                 pcall pcall! get fset-x pyclass?                
                 def-p-class   mk-p-class   make-p-class mk-p-class2
                 define-python-class define-python-class-noname
@@ -78,6 +78,12 @@ explicitly tell it to not update etc.
        it
        (error "IndexError")))
 
+(define-method (py-get (o <hashtable>) key . l)
+  (define -fail (if (pair? l) (car l) #f))
+  (kif it (hash-ref o key fail)
+       it
+       -fail))
+
 (define (is-acl? a b) (member a (cons b (class-subclasses b))))
 
 (define-class <p>  (<applicable-struct> <object>) h)
@@ -121,6 +127,13 @@ explicitly tell it to not update etc.
        (cdr r)
        fail)))
 
+(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)
+         (hash-ref h key -fail))))
+
+
 (define-syntax-rule (find-in-class-and-parents klass key fail-)
   (aif parents (find-in-class klass '__mro__ #f)
        (let lp ((parents parents))
@@ -221,9 +234,7 @@ explicitly tell it to not update etc.
        (hash-for-each
         (lambda (k v) k (set class k v))
         dict)
-       (hashforeach
-        (lambda (k v) k (set class k v))
-        dict))
+        (set class '__dict__ dict))
     
     (let ((mro (ref class '__mro__)))
       (if (pair? mro)
@@ -249,18 +260,18 @@ explicitly tell it to not update etc.
     (aif it (and meta (find-in-class-and-parents meta '__init__ #f))
          (it class name parents dict keys)
          #f)
-    (pk 'res class)))
+    class))
 
 
 (define (the-create-object class x)
-  (let* ((meta  (ref class '__class__))
-         (goops (ref class '__goops__))
+  (let* ((meta  (ficap class '__class__ #f))
+         (goops (ficap class '__goops__ #f))
          (obj   (aif it (ficap class '__new__ #f)
                      (apply it class x)
                      (make-object class meta goops))))
     
-    (aif it (ref obj '__init__)
-         (apply it x)
+    (aif it (ficap class '__init__ #f)
+         (apply it obj x)
          #f)
 
     (slot-set! obj 'procedure
@@ -380,9 +391,6 @@ explicitly tell it to not update etc.
                               r))
                         (end)))
               (end)))))
-
-(define-method (find-in-class (klass <p>) key fail)
-  (hash-ref (slot-ref klass 'h) key fail))
   
 (define-syntax-rule (mrefx klass key l)
   (let ()
@@ -400,17 +408,16 @@ explicitly tell it to not update etc.
 
 (define not-implemented (cons 'not 'implemeneted))
 
-(define-syntax-rule (mrefx-py x key l)
+(define-inlinable (mrefx-py x key l)
   (let ((xx x))
-    (let* ((f (aif it (or (mrefx xx '__getattribute__ '())
-                          (mrefx xx '__getattr__ '()))
+    (let* ((f (aif it (mrefx xx '__getattribute__ '())
                    (gox xx it)
                    #f)))
       (if (or (not f) (eq? f not-implemented))
           (gox xx (mrefx xx key l))
          (catch #t
-                (lambda () (gox xx (f xx key)))
-                (lambda z  (if (pair? l) (car l) #f)))))))
+            (lambda () (f key))
+            (lambda z  (pk z) (if (pair? l) (car l) #f)))))))
 
 (define-syntax-rule (mref x key l)
   (let ((xx x))
@@ -856,7 +863,6 @@ explicitly tell it to not update etc.
 
     (let ((cl (with-fluids ((*make-class* #t))
                 (create-class meta name parents gen-methods kw))))
-      (pk 'got cl)
       (aif it (ref meta '__init_subclass__)
           (let lp ((ps cparents))
             (if (pair? ps)
@@ -864,7 +870,6 @@ explicitly tell it to not update etc.
                   (it cl super)
                   (lp (cdr ps)))))
           #f)
-      (pk 'return)
       cl))))
                    
 
@@ -931,7 +936,7 @@ explicitly tell it to not update etc.
                        ...
                        ret)))
            
-           (module-define! (current-module) 'nname (ref name '__goops__))
+           (module-define! (current-module) 'nname (rawref name '__goops__))
            (name-object nname)
            (name-object name)
            name))))))
@@ -961,12 +966,14 @@ explicitly tell it to not update etc.
                               (symbol->string
                                (syntax->datum #'name))
                               "-goops-class")))))
-        (%add-to-warn-list (syntax->datum #'nname))
+         
+         (%add-to-warn-list (syntax->datum #'nname))
          (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
               #'(ddname ...))
-       #'(let ()
-           (define name 
-             (letruc ((dname (make-up dval)) ...)
+         
+         #'(let ()
+             (define name 
+               (letruc ((dname (make-up dval)) ...)
                       body
                       (let ((ret
                             (make-p-class 'name doc
@@ -980,7 +987,7 @@ explicitly tell it to not update etc.
                          (name-object ddname))
                        ...
                        ret)))
-           (module-define! (current-module) 'nname (ref name '__goops__))
+           (module-define! (current-module) 'nname (rawref name '__goops__))
            (name-object nname)
            (name-object name)
            name))))))
@@ -1113,12 +1120,10 @@ explicitly tell it to not update etc.
                   (o (make-p <py>)))
               (set c '__class__        type)
               (set c '__mro__          (cons c parents))
-              (set c '__getattribute__ (lambda (self key . l)
-                                         (aif it (ficap c key #f)
-                                              (if (procedure? it)
-                                                  (gokx obj cl it)
-                                                  it)
-                                              (error "no attribute"))))
+              (set c '__getattribute__
+                   (object-method
+                    (lambda (self key . l)
+                      (ficap c key #f))))
               (set c '__name__  "**super**")
               (set o '__class__ c)
               o))))
@@ -1291,6 +1296,30 @@ explicitly tell it to not update etc.
         (hash-fold (lambda (k v s) (cons k s)) '() h))
        '()))
 
+(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)
+                         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))))
+             
+(define attr __getattribute__)
+
 (set! type
   (make-python-class type ()
      (define __new__           new-class0)
@@ -1302,10 +1331,12 @@ explicitly tell it to not update etc.
 
 (set type '__class__ type)
 
-(set! object (make-python-class object ()
-    (define __init__       (lambda x (values)))
-    (define __subclasses__ subclasses)
-    (define __weakref__    (lambda (self) self))))
+(set! object
+  (make-python-class object ()
+    (define __init__         (lambda x (values)))
+    (define __subclasses__   subclasses)
+    (define __getattribute__ (object-method attr))
+    (define __weakref__      (lambda (self) self))))
                
 
 (name-object type)
@@ -1326,4 +1357,3 @@ explicitly tell it to not update etc.
   (define __new__
     (lambda x 'None)))
 
-