mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +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

21
module/oop/goops.scm
View file

@ -2680,26 +2680,19 @@ 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)
(if (and (slot-exists? old-instance slot)
(eq? (slot-definition-allocation (eq? (slot-definition-allocation
(class-slot-definition old-class slot)) (class-slot-definition old-class slot))
#:instance) #:instance)
(slot-bound-using-class? old-class old-instance slot)) (slot-bound? old-instance slot))
;; Slot was present and allocated in old instance; copy it ;; Slot was present and allocated in old instance; copy it
(slot-set-using-class! (slot-set! new-instance slot (slot-ref old-instance slot))
new-class
new-instance
slot
(slot-ref-using-class old-class old-instance slot))
;; slot was absent; initialize it with its default value ;; slot was absent; initialize it with its default value
(let ((init (slot-init-function new-class slot))) (let ((init (slot-init-function new-class slot)))
(if init (when init
(slot-set-using-class! (slot-set! new-instance slot (init))))))
new-class
new-instance
slot
(apply init '()))))))
(map slot-definition-name (class-slots new-class))) (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)