From ad5e33eba9b1274251ff79db2f4127db430fab3e Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Thu, 5 Oct 2017 16:01:15 +0200
Subject: bugfixes

---
 modules/oop/pf-objects.scm | 99 ++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 83 insertions(+), 16 deletions(-)

(limited to 'modules/oop/pf-objects.scm')

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 950a0ca..3508d16 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -113,12 +113,7 @@ explicitly tell it to not update etc.
             (let ((p (car li)))
               (cif (it h) (key p)
                    it
-                   (hif it ('__parents__ h)
-                        (let ((r (parents it)))
-                          (if (eq? r fail)
-                              (lp (cdr li))
-                              r))
-                        (lp (cdr li)))))
+		   (lp (cdr li))))
             fail)))
   
     (cif (it h) (key x)
@@ -126,7 +121,7 @@ explicitly tell it to not update etc.
          (hif cl ('__class__ h)
               (cif (it h) (key cl)
                    it
-                   (hif p ('__parents__ h)
+                   (hif p ('__mro__ h)
                         (let ((r (parents p)))
                           (if (eq? r fail)
                               (end)
@@ -144,11 +139,12 @@ explicitly tell it to not update etc.
       (let lp ((class-h h))
         (let ((r (hash-ref class-h key fail)))
           (if (eq? r fail)
-              (aif parents (hash-ref class-h '__parents__ #f)
+              (aif parents (hash-ref class-h '__mro__ #f)
                    (let lpp ((parents parents))
                      (if (pair? parents)
                          (let ((parent (car parents)))
-                           (let ((r (lp (slot-ref parent 'h))))
+                           (let* ((h (slot-ref parent 'h))
+				  (r (hash-ref class-h key fail)))
                              (if (eq? r fail)
                                  (lpp (cdr parents))
                                  r)))
@@ -292,9 +288,9 @@ explicitly tell it to not update etc.
                              (aif it (r h '__parents__)
                                   (let lp2 ((parents it))
                                     (if (pair? parents)
-                                        (if (lp (car parents))
-                                            (lp2 (cdr parents))
-                                            fret)
+                                        (let ((h (hm (car parents))))
+					  (ifh h
+					       (lp2 (cdr parents))))
                                         fret))
                                   fret))))
                     fret))
@@ -542,13 +538,14 @@ explicitly tell it to not update etc.
                (set  class '__name__     'name)
                (set  class '__parents__  (filter-parents
                                           (list sups (... ...))))
-               
-               (set class '__goops__    name)
+	       (set  class '__mro__ (get-mro class))               
+               (set  class '__goops__    name)
                (set  __const__ '__name__    'name)
                (set  __const__ '__goops__   class)
                (set  __const__ '__parents__ (filter-parents
                                              (list sups (... ...))))
                (set  __const__ '__goops__   name)
+
                class)))))))
 
 (mk-pf make-pf-class <pf>)
@@ -580,9 +577,10 @@ explicitly tell it to not update etc.
                
                (define class (dynamic <p>))
                (set class '__name__    'name)
-               (set class '__class__   #f)
+               (set class '__class__    #f)
                (set class '__goops__    name)
-               (set class '__parents__  (filter-parents (list sups (... ...))))
+               (set class '__parents__ (filter-parents (list sups (... ...))))
+	       (set class '__mro__     (get-mro class))               
                class)))))))
 
 (mk-p  make-p-class  <p>)
@@ -811,3 +809,72 @@ explicitly tell it to not update etc.
        
 (define-method (py-init (o <p>) . l)
   (apply (ref o '__init__) l))
+
+(define mk-tree
+  (case-lambda
+   ((root)
+    (vector root '()))
+   ((root hist) (vector root hist))))
+
+(define (geth t) (vector-ref t 1))
+(define (getr t) (vector-ref t 0))
+(define (tree-ref t) (car (getr t)))
+
+(define (nxt tree)  
+  (define (dive r h)
+    (let ((x (car r)))
+      (if (pair? x)
+	  (dive (car r) (cons (cdr r) h))
+	  (mk-tree r h))))
+  
+  (define (up r h)
+    (if (null? r)
+	(if (pair? h)
+	    (up (car h) (cdr h))
+	    #f)
+	(let ((x (car r)))
+	  (if (pair? x)
+	      (dive r h)
+	      (mk-tree r h)))))
+	 
+  (let ((r (getr tree)) (h (geth tree)))
+    (cond
+     ((pair? r)
+      (let ((r (cdr r)))
+	(if (pair? r)
+	    (let ((x (car r)))
+	      (if (pair? x)
+		  (dive x (cons (cdr r) h))
+		  (mk-tree r h)))
+	    (if (pair? h)
+		(up (car h) (cdr h))
+		#f))))
+     (else
+      (if (pair? h)
+	  (up (car h) (cdr h))
+	  #f)))))
+
+(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))
+
+(define (find-tree o tree)
+  (if tree
+      (let ((x (tree-ref tree)))
+	(if (eq? o x)
+	    #t
+	    (find-tree o (nxt tree))))
+      #f))
+
+(define (get-mro class)
+  (define tree (mk-tree (class-to-tree class)))
+  (let lp ((tree tree) (r '()))
+    (if tree
+	(let ((x (tree-ref tree))
+	      (n (nxt tree)))
+	  (if (pk 'find (find-tree x n))
+	      (lp n r)
+	      (lp n (cons x r))))
+	(reverse r))))
+	      
+
+    
+    
-- 
cgit v1.2.3