diff options
Diffstat (limited to 'modules/oop/pf-objects.scm')
-rw-r--r-- | modules/oop/pf-objects.scm | 86 |
1 files changed, 61 insertions, 25 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 9101415..761d44c 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -1,9 +1,10 @@ (define-module (oop pf-objects) #:use-module (oop goops) #:use-module (ice-9 vlist) + #:use-module (ice-9 match) #:export (set ref make-pf <p> <py> <pf> <pyf> call with copy fset fcall make-p put put! - pcall pcall! get next + pcall pcall! get next fset-x mk def-pf-class mk-pf-class make-pf-class def-p-class mk-p-class make-p-class @@ -47,35 +48,55 @@ explicitly tell it to not update etc. (slot-set! r 'h (make-hash-table)) r) +(define-syntax-rule (hif it (k h) x y) + (let ((a (vhash-assq k h))) + (if (pair? a) + (let ((it (cdr a))) + x) + y))) + +(define-syntax-rule (cif (it h) (k cl) x y) + (let* ((h (slot-ref cl 'h)) + (a (vhash-assq k h))) + (if (pair? a) + (let ((it (cdr a))) + x) + y))) + (define fail (cons 'fail '())) (define-syntax-rule (mrefx x key l) - (let ((h (slot-ref x 'h))) - (define pair (vhash-assq key h)) + (let () (define (end) (if (null? l) #f (car l))) - (define (parents) - (let ((pair (vhash-assq '__parents__ h))) - (if (pair? pair) - (let lp ((li (cdr pair))) - (if (pair? li) - (let ((r (ref (car li) key fail))) - (if (eq? r fail) - (lp (cdr li)) - r)) - (end))) - (end)))) - - (if pair - (cdr pair) - (let ((cl (ref x '__class__))) - (if cl - (let ((r (ref cl key fail))) - (if (eq? r fail) - (parents) - r)) - (parents)))))) + + (define (parents li) + (let lp ((li li)) + (if (pair? li) + (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))))) + fail))) + + (cif (it h) (key x) + it + (hif cl ('__class__ h) + (cif (it h) (key cl) + it + (hif p ('__parents__ h) + (let ((r (parents p))) + (if (eq? r fail) + (end) + r)) + (end))) + (end))))) (define-syntax-rule (mrefx- x key l) (let () @@ -275,6 +296,21 @@ explicitly tell it to not update etc. (mset x key val) x)) +(define (fset-x obj l val) + (let lp ((obj obj) (l l) (r '())) + (match l + (() + (let lp ((v val) (r r)) + (if (pair? r) + (lp (fset (caar r) (cdar r) v) (cdr r)) + v))) + ((k . l) + (lp (ref obj k #f) l (cons (cons obj k) r)))))) + + + + + ;; a functional call will keep x untouched and return (values fknval newx) ;; e.g. we get both the value of the call and the new version of x with ;; perhaps new bindings added @@ -434,7 +470,7 @@ explicitly tell it to not update etc. #'(supers (... ...))))) #'(let ((sups supers) (... ...)) (define class dynamic) - (define name (make-class (list sups (... ...) <p>) '())) + (define name (make-class (list sups (... ...) <pf>) '())) (put! class.__const__ (union const |