diff options
Diffstat (limited to 'modules/oop')
| -rw-r--r-- | modules/oop/pf-objects.scm | 87 |
1 files changed, 47 insertions, 40 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index d22a9a0..8e08b3e 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -67,15 +67,15 @@ explicitly tell it to not update etc. class)) ;; Make an empty pf object -(define (make-pf) - (define r (make-pyclass <pf>)) +(define* (make-pf #:optional (class <pf>)) + (define r (make-pyclass class)) (slot-set! r 'h vlist-null) (slot-set! r 'size 0) (slot-set! r 'n 0) r) -(define (make-p) - (define r (make-pyclass <p>)) +(define* (make-p #:optional (class <p>)) + (define r (make-pyclass class)) (slot-set! r 'h (make-hash-table)) r) @@ -517,10 +517,10 @@ explicitly tell it to not update etc. (slot-set! out 'size s) out) -(define (union- x y) +(define (union- class x y) (define hx (slot-ref x 'h)) (define hy (slot-ref y 'h)) - (define out (make-p)) + (define out (make-p class)) (define h (slot-ref out 'h)) (hash-for-each (lambda (k v) (hash-set! h k v)) hy) (hash-for-each (lambda (k v) (hash-set! h k v)) hx) @@ -540,12 +540,12 @@ explicitly tell it to not update etc. (with-syntax (((sups (... ...)) (generate-temporaries #'(supers (... ...))))) #'(let ((sups supers) (... ...)) - (define class dynamic) (define name (make-class (list sups (... ...) <pf>) '())) - + (define class (dynamic name)) (define __const__ (union const - (let lp ((sup (list sups (... ...)))) + (let lp ((sup (filter-parents + (list sups (... ...))))) (if (pair? sup) (union (ref (car sup) '__const__ null) (lp (cdr sup))) @@ -555,17 +555,28 @@ explicitly tell it to not update etc. (set class '__const__ __const__) (set class '__goops__ name) (set class '__name__ 'name) - (set class '__parents__ (list sups (... ...))) + (set class '__parents__ (filter-parents + (list sups (... ...)))) + (set class '__goops__ name) (set __const__ '__name__ 'name) - (set __const__ '__class__ class) - (set __const__ '__parents__ (list sups (... ...))) + (set __const__ '__goops__ class) + (set __const__ '__parents__ (filter-parents + (list sups (... ...)))) (set __const__ '__goops__ name) class))))))) (mk-pf make-pf-class <pf>) (mk-pf make-pyf-class <pyf>) +(define (filter-parents l) + (let lp ((l l)) + (if (pair? l) + (if (is-a? (car l) <p>) + (cons (car l) (lp (cdr l))) + (lp (cdr l))) + '()))) + (define-syntax-rule (mk-p make-p-class <p>) (define-syntax make-p-class (lambda (x) @@ -574,23 +585,19 @@ explicitly tell it to not update etc. (with-syntax (((sups (... ...)) (generate-temporaries #'(supers (... ...))))) #'(let ((sups supers) (... ...)) - (define class dynamic) - (define name (make-class (list (ref sups '__goops__ #f) - (... ...) <p>) '())) + (define name (make-class (list + (if (is-a? sups <p>) + (aif it (ref sups '__goops__ #f) + it + sups) + sups) + (... ...) <p>) '())) - (set! class - (union- const - (let lp ((sup (list sups (... ...)))) - (if (pair? sup) - (union- (car sup) - (lp (cdr sup))) - (make-p))))) - - + (define class (dynamic <p>)) + (set class '__name__ 'name) + (set class '__class__ #f) (set class '__goops__ name) - (set class '__name__ 'name) - (set class '__parents__ (list sups (... ...))) - + (set class '__parents__ (filter-parents (list sups (... ...)))) class))))))) (mk-p make-p-class <p>) @@ -606,16 +613,16 @@ explicitly tell it to not update etc. #:dynamic ((ddef dname dval) (... ...))) (let () - (define name - (make-pf-class name - (letrec ((mname sval) ...) + (define name + (letrec ((mname sval) (... ...) (dname dval) (... ...)) + (make-pf-class name (let ((s (make-pf))) (set s 'mname mname) (... ...) - s)) - (letrec ((dname dval) ...) - (let ((d (make-pf))) - (set d 'dname dname) (... ...) - d) + s) + (lambda (class) + (let ((d (make-pf class))) + (set d 'dname dname) (... ...) + d)) (parents (... ...))))) name))) @@ -657,11 +664,11 @@ explicitly tell it to not update etc. 'none))) (define (print o l) - (define p1 (if (pyclass? o) "Class" "Object")) - (define p2 (if (pyclass? o) "Class" "Object")) + (define p1 (if (pyclass? o) "C" "O")) + (define p2 (if (pyclass? o) "C" "O")) (define port (if (pair? l) (car l) #t)) (format port "~a" - (aif it (ref o '__repr__ #f) + (aif it (if (pyclass? o) #f (ref o '__repr__ #f)) (format #f "~a(~a)<~a>" p1 (get-type o) (it)) (format @@ -674,9 +681,9 @@ explicitly tell it to not update etc. (define name (mk-py-class name parents #:const - (code ...) + () #:dynamic - ()))) + (code ...)))) (define (pyclass? x) (and (is-a? x <p>) (not (ref x '__class__)))) |