unofficial mirror of bug-guile@gnu.org 
 help / color / mirror / Atom feed
From: "Thompson, David" <dthompson2@worcester.edu>
To: 46175@debbugs.gnu.org
Subject: bug#46175: Redefinable classes clobber custom slot options
Date: Fri, 29 Jan 2021 11:43:35 -0500	[thread overview]
Message-ID: <CAJ=Rwfb6q=zccBaD_fxY54W=gxJo8+ATYCAuvevF2a6itdbuzw@mail.gmail.com> (raw)

[-- Attachment #1: Type: text/plain, Size: 1883 bytes --]

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

[-- Attachment #2: 0001-goops-Preserve-all-slot-options-in-redefinable-class.patch --]
[-- Type: text/x-patch, Size: 2006 bytes --]

From cbc434527938182389ebe72c258587d137a85891 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
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


             reply	other threads:[~2021-01-29 16:43 UTC|newest]

Thread overview: 2+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2021-01-29 16:43 Thompson, David [this message]
2021-03-20 19:02 ` bug#46175: Redefinable classes clobber custom slot options Andy Wingo

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to='CAJ=Rwfb6q=zccBaD_fxY54W=gxJo8+ATYCAuvevF2a6itdbuzw@mail.gmail.com' \
    --to=dthompson2@worcester.edu \
    --cc=46175@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).