From cbc434527938182389ebe72c258587d137a85891 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 29 Jan 2021 11:04:56 -0500 Subject: [PATCH] goops: Preserve all slot options in redefinable classes. * module/goops.scm (compute-slots): Fix slot transformation. --- module/oop/goops.scm | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index df6df4f7b..a80be6a7a 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -3081,18 +3081,20 @@ var{initargs}." (slot-definition-name s))) (ref (slot-definition-slot-ref/raw s*)) (set! (slot-definition-slot-set! s*))) - (make (class-of s) #:name (slot-definition-name s) - #:getter (slot-definition-getter s) - #:setter (slot-definition-setter s) - #:accessor (slot-definition-accessor s) - #:init-keyword (slot-definition-init-keyword s) - #:init-thunk (slot-definition-init-thunk s) + (apply make (class-of s) #:allocation #:virtual ;; TODO: Make faster. #:slot-ref (lambda (o) (ref (slot-ref o 'indirect-slots))) #:slot-set! (lambda (o v) - (set! (slot-ref o 'indirect-slots) v))))) + (set! (slot-ref o 'indirect-slots) v)) + (let loop ((options (slot-definition-options s))) + (match options + (() '()) + (((or #:allocation #:slot-ref #:slot-set!) _ . rest) + (loop rest)) + ((kw arg . rest) + (cons* kw arg (loop rest)))))))) (else s))) (unless (equal? (list-head slots (length static-slots)) static-slots) -- 2.25.1