Subject: bug#46175: closed (Re: bug#46175: Redefinable classes clobber custom slot options)

From: [email-masked] (GNU bug Tracking System)
Date: Sat, 20 Mar 2021 19:03:02 +0000

Your bug report

#46175: Redefinable classes clobber custom slot options

which was filed against the guile package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
46175: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=46175
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: bug#46175: Redefinable classes clobber custom slot options
From: Andy Wingo <[email-masked]>
To: "Thompson, David" <[email-masked]>
Cc: [email-masked]
Date: Sat, 20 Mar 2021 20:02:29 +0100
List-Id: <debbugs-submit.debbugs.gnu.org>

On Fri 29 Jan 2021 17:43, "Thompson, David" <[email-masked]> writes:

> 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.

Thanks for the report; patch applied!

Andy

Subject: Redefinable classes clobber custom slot options
From: "Thompson, David" <[email-masked]>
To: [email-masked]
Date: Fri, 29 Jan 2021 11:43:35 -0500
List-Id: <debbugs-submit.debbugs.gnu.org>

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
From cbc434527938182389ebe72c258587d137a85891 Mon Sep 17 00:00:00 2001
From: David Thompson <[email-masked]>
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