super trouper
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 5 Oct 2017 15:32:09 +0000 (17:32 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 5 Oct 2017 15:32:09 +0000 (17:32 +0200)
modules/language/python/property.scm [new file with mode: 0644]
modules/language/python/set.scm
modules/oop/pf-objects.scm

diff --git a/modules/language/python/property.scm b/modules/language/python/property.scm
new file mode 100644 (file)
index 0000000..eaefc74
--- /dev/null
@@ -0,0 +1,35 @@
+(define-module (language python property)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (language python def)
+  #:use-module (language python exceptions)
+  #:export (property))
+
+(define-python-class property (<property>)
+  (define __init__
+    (lam (o (= getx None) (= setx None) (= delx None))
+         (slot-set! o 'get getx)
+         (slot-set! o 'set setx)
+         (slot-set! o 'del delx)
+         o))
+  (define setter
+    (lambda (self f)
+      (slot-set! self 'set f)
+      self))
+
+  (define getter
+    (lambda (self f)
+      (slot-set! self 'get f)
+      self))
+
+  (define deleter
+    (lambda (self f)
+      (slot-set! self 'del f)
+      self))
+
+  (define fget (lambda (self) (slot-ref self 'get)))
+  (define fset (lambda (self) (slot-ref self 'set)))
+  (define fdel (lambda (self) (slot-ref self 'del))))
+
+
index cd1258697e6e682270c785eae4cd8574432175d6..f0e295668436fc58a836d647d00d46eacf32378f 100644 (file)
@@ -12,7 +12,7 @@
 (define-class <set> () dict)
 
 (define miss (list 'miss))
-
 (define-python-class set (<set>)
   (define __init__
     (case-lambda
index 3508d1614227b21e8606591659f61e0039ce302a..ebaa3b7d504af2c15a23192a78fb86f3cbef67a3 100644 (file)
@@ -144,7 +144,7 @@ explicitly tell it to not update etc.
                      (if (pair? parents)
                          (let ((parent (car parents)))
                            (let* ((h (slot-ref parent 'h))
-                                 (r (hash-ref class-h key fail)))
+                                 (r (hash-ref h key fail)))
                              (if (eq? r fail)
                                  (lpp (cdr parents))
                                  r)))
@@ -722,12 +722,13 @@ explicitly tell it to not update etc.
 
 (define *super* (list 'super))
 
+(define (not-a-super) 'not-a-super)
 (define (py-super class obj)
   (define (make cl parents)
     (let ((c (make-p))
           (o (make-p)))
       (set c '__super__        #t)
-      (set c '__parents__       parents)
+      (set c '__mro__       parents)
       (set c '__getattribute__  (lambda (self key . l)
                                   (aif it (ref c key)
                                        (if (procedure? it)
@@ -744,31 +745,15 @@ explicitly tell it to not update etc.
   
   (call-with-values
       (lambda ()
-        (let lp ((c (ref obj '__class__)))
-          (if (eq? class c)
-              (let ((p (ref c '__parents__)))
-                (if (pair? p)
-                    (values (car p) p)
-                    (values #t #t)))
-              (let lp2 ((p (ref c 'parents)))
-                (if (pair? p)
-                    (call-with-values (lambda () (lp (car p)))
-                      (lambda (c ps)
-                        (cond
-                         ((eq? c #t)
-                          (if (pair? p)
-                              (let ((x (car p)))
-                                (values
-                                 x
-                                 (append
-                                  (ref x '__parents__)
-                                  (cdr p))))
-                              (values #t #t)))
-                         (c
-                          (values c (append ps (cdr p))))
-                         (else
-                          (lp2 (cdr p))))))                      
-                    (values #f #f))))))
+        (let lp ((l (ref (ref obj '__class__) '__mro__ '())))
+          (if (pair? l)
+              (if (eq? class (car l))
+                  (let ((r (cdr l)))
+                    (if (pair? r)
+                        (values (car r) r)
+                        (values #f      #f)))
+                  (lp (cdr l)))
+              (values #f #f))))
     make))
         
         
@@ -870,11 +855,7 @@ explicitly tell it to not update etc.
     (if tree
        (let ((x (tree-ref tree))
              (n (nxt tree)))
-         (if (pk 'find (find-tree x n))
+         (if (find-tree x n)
              (lp n r)
              (lp n (cons x r))))
        (reverse r))))
-             
-
-    
-