summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--modules/language/python/compile.scm51
-rw-r--r--modules/oop/pf-objects.scm99
2 files changed, 116 insertions, 34 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index c3a6493..694b470 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -35,34 +35,49 @@
(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 ()
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))))
+
+
+
+
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-19 06:46:50 +0000