super

1 files changed, 129 insertions, 17 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 56247ab..950a0ca 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -11,6 +11,8 @@
                 def-py-class  mk-py-class  make-py-class
                 define-python-class get-type py-class
                 object-method class-method static-method
+                py-super-mac py-super
+                *class* *self*
                 ))
 #|
 Python object system is basically syntactic suger otop of a hashmap and one
@@ -597,7 +599,7 @@ explicitly tell it to not update etc.
                                    ((ddef dname dval) (... ...)))
     (let ()
       (define name 
-        (let* ((mname sval) (... ...) (dname dval) (... ...))
+        (letruc ((mname sval) (... ...) (dname dval) (... ...))
           (make-pf-class name
                          (let ((s (make-pf)))
                            (set s 'mname mname) (... ...)
@@ -670,32 +672,142 @@ explicitly tell it to not update etc.
 
 (define (pyclass? x)
   (and (is-a? x <p>)
-       (not (ref x '__class__))))
-
+       (if (ref x '__class__)
+         #f
+         (if (ref x '__super__)
+             'super
+             #t))))
 
 (define-method (py-class (o <p>))
   (ref o '__class__ 'type))
 
-(define (mark-fkn f)
-  (set-procedure-property! f 'py-special #t)
+(define (mark-fkn tag f)
+  (set-procedure-property! f 'py-special tag)
   f)
 
 (define (object-method f)
-  (mark-fkn
-   (lambda (x)
-     (if (pyclass? x)
-         f
-         (lambda z (apply f x z))))))
+  (letrec ((self
+            (mark-fkn 'object
+                      (lambda (x)
+                        (aif it (pyclass? x)
+                             (if (eq? it 'super)
+                                 self
+                                 f)
+                             (lambda z (apply f x z)))))))
+    self))
 
 (define (class-method f)
-  (mark-fkn
-   (lambda (x)
-     (if (pyclass? x)
-         (lambda z (apply f x z))
-         (lambda z (apply f (ref x '__class__) z))))))
+  (letrec ((self
+            (mark-fkn 'class
+              (lambda (x)
+                (aif it (pyclass? x)
+                     (if (eq? it 'super)
+                         self
+                         (lambda z (apply f x z)))
+                     (lambda z (apply f (ref x '__class__) z)))))))
+    self))
 
 (define (static-method f)
-  (mark-fkn
-   (lambda (x) f)))
+  (letrec ((self
+            (mark-fkn 'static
+                      (lambda (x)
+                        (if (eq? (pyclass? x) 'super)
+                            self
+                            f)))))
+    self))
 
         
+(define-syntax-parameter
+  *class* (lambda (x) (error "*class* not parameterized")))
+(define-syntax-parameter
+  *self* (lambda (x) (error "*class* not parameterized")))
+
+(define *super* (list '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 '__getattribute__  (lambda (self key . l)
+                                  (aif it (ref c key)
+                                       (if (procedure? it)
+                                           (if (eq? (procedure-property
+                                                     it
+                                                     'py-special)
+                                                    'class)
+                                               (it cl)
+                                               (it obj))
+                                           it)
+                                       (error "no attribute"))))
+      (set o '__class__ c)
+      o))
+  
+  (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))))))
+    make))
+        
+        
+   
+(define-syntax py-super-mac
+  (syntax-rules ()
+    ((_)
+     (py-super *class* *self*))
+    ((_ class self)
+     (py-super class self))))
+
+(define-syntax letruc
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((x v) ...) code ...)
+       (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
+         (if (pair? a)
+             (let* ((x (car a))
+                    (s (syntax->datum x)))
+               (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
+                         (r (list (car b))))
+                 (if (pair? a2)
+                     (if (eq? (syntax->datum a2) s)
+                         (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
+                         (lp2 (cdr a2) (cdr b2)
+                              (cons (car a2) a3)
+                              (cons (car b2) b3)
+                              r))
+                     (lp (reverse a3) (reverse b3)
+                         (cons
+                          (list x #`(let* #,(map (lambda (v) (list x v))
+                                                 (reverse r)) #,x))
+                          u)))))
+             #`(letrec #,(reverse u) code ...)))))))
+                        
+
+             
+       
+(define-method (py-init (o <p>) . l)
+  (apply (ref o '__init__) l))