diff options
| -rw-r--r-- | starling/node.scm | 39 |
1 files changed, 23 insertions, 16 deletions
diff --git a/starling/node.scm b/starling/node.scm index 578ce2c..7e5933e 100644 --- a/starling/node.scm +++ b/starling/node.scm @@ -72,11 +72,14 @@ (define-method (compute-getter-method (class <meta-node>) slot) (if (asset-slot? slot) + ;; Wrap the original getter procedure with a new procedure that + ;; extracts the current value from the asset object. (make <method> #:specializers (list class) - #:procedure (let ((slot-name (slot-definition-name slot))) + #:procedure (let ((slot-name (slot-definition-name slot)) + (proc (method-procedure (next-method)))) (lambda (obj) - (let ((value (slot-ref obj slot-name))) + (let ((value (proc obj))) (if (is-a? value <asset>) (asset-ref value) value))))) @@ -85,26 +88,30 @@ (define-generic on-change) (define-method (compute-setter-method (class <meta-node>) slot) - (let ((method (next-method))) - (if (watch-slot? slot) - (let ((slot-name (slot-definition-name slot)) - (proc (method-procedure method))) - (make <method> - #:specializers (list class <top>) - #:procedure (lambda (obj new) - (let ((old (and (slot-bound? obj slot-name) - (slot-ref obj slot-name)))) - (proc obj new) - (on-change obj slot-name old new))))) - method))) + (if (watch-slot? slot) + ;; Wrap the original setter procedure with a new procedure that + ;; calls the on-change method. + (make <method> + #:specializers (list class <top>) + #:procedure (let ((slot-name (slot-definition-name slot)) + (proc (method-procedure (next-method)))) + (lambda (obj new) + (let ((old (and (slot-bound? obj slot-name) + (slot-ref obj slot-name)))) + (proc obj new) + (on-change obj slot-name old new))))) + (next-method))) (define-class <developer-meta-node> (<meta-node> <redefinable-class>)) (define-method (compute-setter-method (class <developer-meta-node>) slot) (if (asset-slot? slot) + ;; Wrap the original setter procedure with a new procedure that + ;; manages asset update notifications. (make <method> #:specializers (list class <top>) - #:procedure (let ((slot-name (slot-definition-name slot))) + #:procedure (let ((slot-name (slot-definition-name slot)) + (proc (method-procedure (next-method)))) (lambda (obj new) (let ((old (and (slot-bound? obj slot-name) (slot-ref obj slot-name)))) @@ -112,7 +119,7 @@ (remove-subscriber old obj slot-name)) (when (is-a? new <asset>) (add-subscriber new obj slot-name)) - (slot-set! obj slot-name new))))) + (proc obj new))))) (next-method))) (define-method (make (class <developer-meta-node>) . initargs) |