bugfixes
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 5 Oct 2017 14:01:15 +0000 (16:01 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 5 Oct 2017 14:01:15 +0000 (16:01 +0200)
modules/language/python/compile.scm
modules/oop/pf-objects.scm

index c3a64932c77f50a9550e864a8554bd45bf757b48..694b47007c6a4e0a32de87c30fcfc81360e513a9 100644 (file)
 
 (define s/d 'set!)
 
+(define (pre) (warn "Patching guile will lead to way better experience use 'python.patch' on guile-2.2"))
+
 (define-syntax clear-warning-data
   (lambda (x)
-    (set! (@@ (system base message) %dont-warn-list) '())
+    (catch #t
+      (lambda ()
+       (set! (@@ (system base message) %dont-warn-list) '()))
+      (lambda x (pre)))
     #f))
 
 (define (dont-warn v)
-  (set! (@@ (system base message) %dont-warn-list)
-    (cons v
-          (@@ (system base message) %dont-warn-list))))
+  (catch #t
+    (lambda ()
+      (set! (@@ (system base message) %dont-warn-list)
+           (cons v
+                 (@@ (system base message) %dont-warn-list))))
+    (lambda x (values))))
 
 (define *prefixes* (make-fluid '()))
 (define (add-prefix id)
-  (if (fluid-ref (@@ (system base compile) %in-compile))
-      (fluid-set! *prefixes* (cons id (fluid-ref *prefixes*)))
-      (begin
-        (when (not (module-defined? (current-module) '__prefixes__))
-          (module-define! (current-module) '__prefixes__ (make-fluid '())))
-        
-        (let ((p (module-ref (current-module) '__prefixes__)))
-          (fluid-set! p (cons id (fluid-ref p)))))))
+  (catch #t
+     (lambda ()
+       (if (fluid-ref (@@ (system base compile) %in-compile))
+          (fluid-set! *prefixes* (cons id (fluid-ref *prefixes*)))
+          (begin
+            (when (not (module-defined? (current-module) '__prefixes__))
+                  (module-define! (current-module)
+                                  '__prefixes__ (make-fluid '())))
+            
+            (let ((p (module-ref (current-module) '__prefixes__)))
+              (fluid-set! p (cons id (fluid-ref p)))))))
+     (lambda x (values))))
 
 (define (is-prefix? id)
-  (if (fluid-ref (@@ (system base compile) %in-compile))
-      (member id (fluid-ref *prefixes*))
-      (if (not (module-defined? (current-module) '__prefixes__))
-          #f
-          (let ((p (module-ref (current-module) '__prefixes__)))
-            (member id (fluid-ref p))))))
+  (catch #t
+    (lambda ()
+      (if (fluid-ref (@@ (system base compile) %in-compile))
+         (member id (fluid-ref *prefixes*))
+         (if (not (module-defined? (current-module) '__prefixes__))
+             #f
+             (let ((p (module-ref (current-module) '__prefixes__)))
+               (member id (fluid-ref p))))))
+    (lambda x #f)))
   
 (define-syntax call
   (syntax-rules ()
index 950a0ca628c918930d624646a2870c0a722d4def..3508d1614227b21e8606591659f61e0039ce302a 100644 (file)
@@ -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))))
+             
+
+    
+