summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--starling/node.scm39
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)