diff options
Diffstat (limited to 'modules/oop')
| -rw-r--r-- | modules/oop/pf-objects.scm | 285 |
1 files changed, 166 insertions, 119 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 5eea799..f5b6466 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -184,18 +184,18 @@ explicitly tell it to not update etc. (define-syntax-rule (find-in-class-and-parents klass key fail-) - (aif parents (let ((x (find-in-class-raw klass '__mro__ #f))) - (if (null? x) - #f - x)) - (let lp ((parents parents)) - (if (pair? parents) - (kif r (find-in-class (car parents) key fail) - r - (lp (cdr parents))) - fail-)) - (kif r (find-in-class klass key fail) - r + (kif r (find-in-class klass key fail) + r + (aif parents (let ((x (find-in-class-raw klass '__mro__ #f))) + (if (null? x) + #f + x)) + (let lp ((parents parents)) + (if (pair? parents) + (kif r (find-in-class (car parents) key fail) + r + (lp (cdr parents))) + fail-)) fail-))) (define-syntax-rule (find-in-class-and-parents-raw klass key fail-) @@ -310,8 +310,116 @@ explicitly tell it to not update etc. (define hash-for-each* hash-for-each) +(define (kw->class kw meta) + (if (memq #:functional kw) + (if (memq #:fast kw) + <pf> + (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>)) + <pyf> + <pf>)) + (if (memq #:fast kw) + (if (or (is-a? meta <pyf>) (is-a? meta <pf>)) + <pf> + <p>) + (cond + ((is-a? meta <pyf>) + <pyf>) + ((is-a? meta <py>) + <py>) + ((is-a? meta <pf>) + <pf>) + ((is-a? meta <p>) + <p>) + (else + <py>))))) + +(define (project-goopses supers) + (map (lambda (sups) + (aif it (find-in-class sups '__goops__ #f) + it + sups)) + supers)) + +(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 (get-goops meta name parents kw) + (define (unique l) + (define t (make-hash-table)) + (let lp ((l l)) + (if (pair? l) + (let ((c (car l))) + (if (hashq-ref t c) + (lp (cdr l)) + (begin + (hashq-set! t c #t) + (cons c (lp (cdr l)))))) + '()))) + + (make-class + (unique + (append + (project-goopses parents) + (list (kw->class kw meta)))) '() #:name name)) + +(define (get-cparents supers) + (let ((parents (filter-parents supers))) + (if (null? parents) + (if object + (list object) + '()) + parents))) + +(define (get-mros supers) + (get-mro (get-cparents supers))) + +(define (Module x . l) (reverse x)) + +(define (add-specials pylist-set! dict name goops supers meta doc) + (define (make-module) + (let ((l (module-name (current-module)))) + (if (and (>= (length l) 3) + (equal? (list-ref l 0) 'language) + (equal? (list-ref l 1) 'python) + (equal? (list-ref l 2) 'module)) + (Module (reverse l) (reverse (cdddr l))) + l))) + + (define parents (filter-parents supers)) + (define cparents (get-cparents supers)) + + (define (filt-bases x) + (let lp ((x x)) + (if (pair? x) + (let ((y (car x))) + (if (is-a? y <p>) + (cons y (lp (cdr x))) + (lp (cdr x)))) + '()))) + + (pylist-set! dict '__goops__ goops) + (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table)) + (pylist-set! dict '__module__ (make-module)) + (pylist-set! dict '__bases__ (filt-bases parents)) + (pylist-set! dict '__name__ name) + (pylist-set! dict '__qualname__ name) + (pylist-set! dict '__mro__ (get-mro cparents)) + (if doc (pylist-set! dict '__doc__ doc)) + (pylist-set! dict '__class__ meta)) + (define (new-class0 meta name parents dict . kw) - (let* ((goops (pylist-ref dict '__goops__)) + (set! name (if (symbol? name) name (string->symbol name))) + (let* ((raw? #f) + (goops (catch #t + (lambda () (pylist-ref dict '__goops__)) + (lambda x + (set! raw? #t) + (get-goops meta name parents kw)))) (p (kwclass->class kw meta)) (class (make-p p))) @@ -320,7 +428,10 @@ explicitly tell it to not update etc. (create-object class x))) (when class - (let lp ((mro (pylist-ref dict '__mro__))) + (let lp ((mro (catch #t + (lambda () (pylist-ref dict '__mro__)) + (lambda x (get-mros parents))))) + (if (pair? mro) (let ((p (car mro))) (aif it (find-in-class p '__zub_classes__ #f) @@ -332,22 +443,37 @@ explicitly tell it to not update etc. #f) (lp (cdr mro))))) - - + (hash-for-each* (lambda (k v) (let ((k (if (string? k) (string->symbol k) k))) (rawset class k v))) dict) - - (rawset class '__goops__ goops) - (let ((mro (add-default class (pylist-ref dict '__mro__)))) + (if raw? + (begin + (add-specials rawset class name goops parents meta + (catch #t + (lambda () (pylist-ref kw "doc")) + (lambda x #f))) + (set (rawref class '__module__) + (if (string? name) (string->symbol name) name) + class)) + (rawset class '__goops__ goops)) + + (let ((mro (add-default class + (catch #t + (lambda () (pylist-ref dict '__mro__)) + (lambda x (get-mros parents)))))) (rawset class '__mro__ mro)) - - (if (not (ficap-raw class '__getattribute__ #f)) - (rawset class '__getattribute__ attr))) - + + (catch #t + (lambda () + (if (not (ficap-raw class '__getattribute__ #f)) + (rawset class '__getattribute__ attr))) + (lambda x + (rawset class '__getattribute__ attr)))) + class)) (define (new-class meta name parents dict kw) @@ -398,7 +524,15 @@ explicitly tell it to not update etc. (if (pytype? class) (apply (case-lambda ((meta obj) - (and obj (find-in-class-raw obj '__class__ 'None))) + (catch #t + (lambda () + (aif it (find-in-class-raw obj '__class__ #f) + it + type)) + (lambda x + (warn x) + type))) + ((meta name bases dict . keys) (type- meta name bases dict keys))) class l) @@ -803,39 +937,7 @@ explicitly tell it to not update etc. ;; it's good to have a null object so we don't need to construct it all the ;; time because it is functional we can get away with this. (define null (make-p <pf>)) - -(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 (kw->class kw meta) - (if (memq #:functional kw) - (if (memq #:fast kw) - <pf> - (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>)) - <pyf> - <pf>)) - (if (memq #:fast kw) - (if (or (is-a? meta <pyf>) (is-a? meta <pf>)) - <pf> - <p>) - (cond - ((is-a? meta <pyf>) - <pyf>) - ((is-a? meta <py>) - <py>) - ((is-a? meta <pf>) - <pf>) - ((is-a? meta <p>) - <p>) - (else - <py>))))) - (define (defaulter d) (if d (aif it (ref d '__goops__) @@ -874,6 +976,7 @@ explicitly tell it to not update etc. (define type #f) (define object #f) + (define make-p-class (case-lambda ((name supers.kw methods) @@ -881,22 +984,9 @@ explicitly tell it to not update etc. ((name doc supers.kw methods) (define s.kw supers.kw) (define kw (cdr s.kw)) - (define supers (car s.kw)) - (define goopses (map (lambda (sups) - (aif it (find-in-class sups '__goops__ #f) - it - sups)) - supers)) - - (define parents (let ((p (filter-parents supers))) - p)) - - (define cparents (if (null? parents) - (if object - (list object) - '()) - parents)) - + (define supers (car s.kw)) + (define parents (filter-parents supers)) + (define cparents (get-cparents supers)) (define meta (aif it (memq #:metaclass kw) (cadr it) (if (null? cparents) @@ -918,55 +1008,12 @@ explicitly tell it to not update etc. (lp l m mro)) (lp l m mro))) (() m))))))) - - (define (unique l) - (define t (make-hash-table)) - (let lp ((l l)) - (if (pair? l) - (let ((c (car l))) - (if (hashq-ref t c) - (lp (cdr l)) - (begin - (hashq-set! t c #t) - (cons c (lp (cdr l)))))) - '()))) - - (define goops (make-class (unique - (append goopses - (list (kw->class kw meta)))) - '() #:name name)) - - (define (make-module) - (let ((l (module-name (current-module)))) - (if (and (>= (length l) 3) - (equal? (list-ref l 0) 'language) - (equal? (list-ref l 1) 'python) - (equal? (list-ref l 2) 'module)) - (string-join - (map symbol->string (cdddr l)) - ".") - l))) + + (define goops (get-goops meta name supers kw)) - (define (gen-methods dict) - (define (filt-bases x) - (let lp ((x x)) - (if (pair? x) - (let ((y (car x))) - (if (is-a? y <p>) - (cons y (lp (cdr x))) - (lp (cdr x)))) - '()))) - + (define (gen-methods dict) (methods dict) - (pylist-set! dict '__goops__ goops) - (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table)) - (pylist-set! dict '__module__ (make-module)) - (pylist-set! dict '__bases__ (filt-bases parents)) - (pylist-set! dict '__name__ name) - (pylist-set! dict '__qualname__ name) - (pylist-set! dict '__mro__ (get-mro cparents)) - (pylist-set! dict '__doc__ doc) - (pylist-set! dict '__class__ meta) + (add-specials pylist-set! dict name goops supers meta doc) dict) (let ((cl (with-fluids ((*make-class* #t)) |