bug#46175: Redefinable classes clobber custom slot options
"Thompson, David" <[email protected]>
| Newsgroups | gmane.lisp.guile.bugs |
|---|---|
| Message-ID | <CAJ=Rwfb6q=zccBaD_fxY54W=gxJo8+ATYCAuvevF2a6itdbuzw@mail.gmail.com> |
The compute-slots method for <redefinable-class> does a transformation
of #:allocation #:instance slots to #:allocation #:virtual slots, but
in doing so it discards all slot options besides the standard ones.
This means that a metaclass that inherits from <redefinable-class>
won't work as expected if it relies upon custom slot options.
Test case:
(use-modules (oop goops)
(srfi srfi-111))
(define-class <meta> (<class>))
(define (boxed-slot? slot)
(get-keyword #:box? (slot-definition-options slot)))
(define-method (compute-getter-method (class <meta>) slot)
(if (boxed-slot? slot)
(make <method>
#:specializers (list class)
#:procedure (let ((slot-name (slot-definition-name slot)))
(lambda (obj)
(unbox (slot-ref obj slot-name)))))
(next-method)))
(define-method (compute-setter-method (class <meta>) slot)
(if (boxed-slot? slot)
(make <method>
#:specializers (list class <top>)
#:procedure (let ((slot-name (slot-definition-name slot)))
(lambda (obj value)
(set-box! (slot-ref obj slot-name) value))))
(next-method)))
(define-class <redefinable-meta> (<meta> <redefinable-class>))
(define-class <foo> ()
(bar #:accessor bar #:box? #t #:init-form (box 123))
#:metaclass <meta>)
(define-class <redefinable-foo> ()
(bar #:accessor bar #:box? #t #:init-form (box 123))
#:metaclass <redefinable-meta>)
;; This works:
(pk (+ (bar (make <foo>)) 456))
;; This throws an error:
(pk (+ (bar (make <redefinable-foo>)) 456))
Attached is a patch that preserves all slot options that redefinable
classes do not need to alter, including custom ones. How does it
look?
- Dave
0001-goops-Preserve-all-slot-options-in-redefinable-class.patch
(text/x-patch, 2 KB)
From cbc434527938182389ebe72c258587d137a85891 Mon Sep 17 00:00:00 2001 From: David Thompson <[email protected]> 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 <redefinable-class> 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