diff options
Diffstat (limited to 'modules/oop')
| -rw-r--r-- | modules/oop/pf-objects.scm | 76 |
1 files changed, 56 insertions, 20 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index fd11182..0e2f1d9 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -35,10 +35,35 @@ The datastructure is functional but the objects mutate. So one need to explicitly tell it to not update etc. |# +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) + ;; this is mutated by the dict class (define dictNs '(dictNs)) (define dictRNs '(dictRNs)) +(define prophash (make-hash-table)) + +(define (procedure-property- o key . l) + (define ret (if (pair? l) (car l) #f)) + (aif props (hashq-ref prophash o) + (aif it (assq key props) + (cdr it) + ret) + ret)) + +(define (procedure-properties- o) + (define ret #f) + (aif props (hashq-ref prophash o) + props + ret)) + +(define (set-procedure-property!- o key v) + (hashq-set! prophash + o + (aif props (hashq-ref prophash o) + (cons (cons key v) props) + (list (cons key v))))) + #; (define (pkk . l) (let* ((r (reverse l)) @@ -51,9 +76,6 @@ explicitly tell it to not update etc. (define (pkk . l) (car (reverse l))) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - (define (pk-obj o) (pk 'start-pk-obj) (let ((h (slot-ref o 'h))) @@ -64,7 +86,7 @@ explicitly tell it to not update etc. (pk 'finished-obj) - (let lp ((l (pk 'mro (ref o '__mro__ '())))) + (let lp ((l (pk 'mro (rawref o '__mro__ '())))) (if (pair? l) (let ((cl (car l))) (if (is-a? cl <p>) @@ -133,24 +155,24 @@ explicitly tell it to not update etc. (next-method))) (define-method (ref (o <procedure>) key . l) - (aif it (procedure-property o key) + (aif it (procedure-property- o key) it (if (pair? l) (car l) #f))) (define-method (rawref (o <procedure>) key . l) - (aif it (procedure-property o key) + (aif it (procedure-property- o key) it (if (pair? l) (car l) #f))) (define-method (set (o <procedure>) key val) - (set-procedure-property! o key val)) + (set-procedure-property!- o key val)) (define-method (rawset (o <procedure>) key val) - (set-procedure-property! o key val)) + (set-procedure-property!- o key val)) (define-method (find-in-class x key fail) fail) (define-method (find-in-class (klass <pf>) key fail) @@ -520,6 +542,7 @@ explicitly tell it to not update etc. (apply it class x) (the-create-object class x)))))) +;; This are finished in the _python.scm module (define int-cls #f) (define int? #f) (define tuple-cls #f) @@ -706,8 +729,14 @@ explicitly tell it to not update etc. (else #f))) -(define-method (ref (x <pf> ) key . l) (mref x key l)) -(define-method (ref (x <p> ) key . l) (mref x key l)) +(define-syntax-rule (mox o x) + (if (procedure? x) + (aif it (procedure-property- x '__get__) + (it x o (fluid-ref *location*)) + x))) + +(define-method (ref (x <pf> ) key . l) (mox x (mref x key l))) +(define-method (ref (x <p> ) key . l) (mox x (mref x key l))) (define-method (ref (x <pyf>) key . l) (mref-py x key l)) (define-method (ref (x <py> ) key . l) (mref-py x key l)) @@ -717,10 +746,10 @@ explicitly tell it to not update etc. (define-method (set (f <procedure>) key val) - (set-procedure-property! f key val)) + (set-procedure-property!- f key val)) (define-method (ref (f <procedure>) key . l) - (aif it (assoc key (procedure-properties f)) + (aif it (assoc key (procedure-properties- f)) (cdr it) (if (pair? l) (car l) #f))) @@ -1274,16 +1303,23 @@ explicitly tell it to not update etc. cl))))) (define type-goops #f) +(define kind-cache (make-hash-table)) +(define (kind-cache-it type it) + (hashq-set! kind-cache type it) + type) + (define (kind x) (if (not type-goops) (set! type-goops (rawref type '__goops__))) (and (is-a? x <p>) - (aif it (find-in-class x '__goops__ #f) - (if (or - (not type-goops) - (eq? it type-goops) - (member it (class-subclasses type-goops))) - 'type - 'class) + (aif it (find-in-class-raw x '__goops__ #f) + (aif it2 (hashq-ref kind-cache it) + it2 + (if (or + (not type-goops) + (eq? it type-goops) + (member it (class-subclasses type-goops))) + (kind-cache-it 'type it) + (kind-cache-it 'class it))) 'object))) (define (pyobject? x) (eq? (kind x) 'object)) @@ -1291,7 +1327,7 @@ explicitly tell it to not update etc. (define (pytype? x) (eq? (kind x) 'type)) (define (mark-fkn tag f) - (set-procedure-property! f 'py-special tag) + (set-procedure-property!- f 'py-special tag) f) (define-syntax-parameter |