diff options
| author | Andy Wingo <wingo@pobox.com> | 2015-01-16 13:02:31 +0100 |
|---|---|---|
| committer | Andy Wingo <wingo@pobox.com> | 2015-01-23 16:16:03 +0100 |
| commit | 9539b20ba92c84296f6e453175844d5a5614d307 (patch) | |
| tree | 86a6fb4597c923de4557dc76913effa57503eacb | |
| parent | f15c0f545be3dd4b1da92824b1bf782e3571b4a6 (diff) | |
| download | guile-9539b20ba92c84296f6e453175844d5a5614d307.tar.gz | |
change-object-class refactor
* module/oop/goops.scm (change-object-class): Refactor to use slot-ref,
slot-bound?, and slot-set! instead of the using-class? variants.
| -rw-r--r-- | module/oop/goops.scm | 35 |
1 files changed, 14 insertions, 21 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 1babb09f8..35be172c8 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -2680,27 +2680,20 @@ var{initargs}." (define (change-object-class old-instance old-class new-class) (let ((new-instance (allocate-instance new-class '()))) ;; Initialize the slots of the new instance - (for-each (lambda (slot) - (if (and (slot-exists-using-class? old-class old-instance slot) - (eq? (slot-definition-allocation - (class-slot-definition old-class slot)) - #:instance) - (slot-bound-using-class? old-class old-instance slot)) - ;; Slot was present and allocated in old instance; copy it - (slot-set-using-class! - new-class - new-instance - slot - (slot-ref-using-class old-class old-instance slot)) - ;; slot was absent; initialize it with its default value - (let ((init (slot-init-function new-class slot))) - (if init - (slot-set-using-class! - new-class - new-instance - slot - (apply init '())))))) - (map slot-definition-name (class-slots new-class))) + (for-each + (lambda (slot) + (if (and (slot-exists? old-instance slot) + (eq? (slot-definition-allocation + (class-slot-definition old-class slot)) + #:instance) + (slot-bound? old-instance slot)) + ;; Slot was present and allocated in old instance; copy it + (slot-set! new-instance slot (slot-ref old-instance slot)) + ;; slot was absent; initialize it with its default value + (let ((init (slot-init-function new-class slot))) + (when init + (slot-set! new-instance slot (init)))))) + (map slot-definition-name (class-slots new-class))) ;; Exchange old and new instance in place to keep pointers valid (%modify-instance old-instance new-instance) ;; Allow class specific updates of instances (which now are swapped) |