mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

change-object-class refactor

Browse source 
* module/oop/goops.scm (change-object-class): Refactor to use slot-ref,
  slot-bound?, and slot-set! instead of the using-class? variants.
This commit is contained in:
Andy Wingo 2015-01-16 13:02:31 +01:00
parent f15c0f545b
commit 9539b20ba9
1 changed files with 14 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

35
module/oop/goops.scm
View file

@ -2680,27 +2680,20 @@ var{initargs}."
(define (change-object-class old-instance old-class new-class) (define (change-object-class old-instance old-class new-class)
(let ((new-instance (allocate-instance new-class '()))) (let ((new-instance (allocate-instance new-class '())))
;; Initialize the slots of the new instance ;; Initialize the slots of the new instance
(for-each (lambda (slot) (for-each
(if (and (slot-exists-using-class? old-class old-instance slot) (lambda (slot)
(eq? (slot-definition-allocation (if (and (slot-exists? old-instance slot)
(class-slot-definition old-class slot)) (eq? (slot-definition-allocation
#:instance) (class-slot-definition old-class slot))
(slot-bound-using-class? old-class old-instance slot)) #:instance)
;; Slot was present and allocated in old instance; copy it (slot-bound? old-instance slot))
(slot-set-using-class! ;; Slot was present and allocated in old instance; copy it
new-class (slot-set! new-instance slot (slot-ref old-instance slot))
new-instance ;; slot was absent; initialize it with its default value
slot (let ((init (slot-init-function new-class slot)))
(slot-ref-using-class old-class old-instance slot)) (when init
;; slot was absent; initialize it with its default value (slot-set! new-instance slot (init))))))
(let ((init (slot-init-function new-class slot))) (map slot-definition-name (class-slots new-class)))
(if init
(slot-set-using-class!
new-class
new-instance
slot
(apply init '()))))))
(map slot-definition-name (class-slots new-class)))
;; Exchange old and new instance in place to keep pointers valid ;; Exchange old and new instance in place to keep pointers valid
(%modify-instance old-instance new-instance) (%modify-instance old-instance new-instance)
;; Allow class specific updates of instances (which now are swapped) ;; Allow class specific updates of instances (which now are swapped)