* MOP issues with <redefinable-class>
@ 2021-01-29 13:29 Thompson, David
2021-01-29 16:07 ` Thompson, David
0 siblings, 1 reply; 2+ messages in thread
From: Thompson, David @ 2021-01-29 13:29 UTC (permalink / raw)
To: Guile User
I've been playing around with GOOPS and the metaobject protocol
lately. It has been fun, but I've hit a snag with redefinable classes.
Here's a contrived example program that demonstrates my problem:
(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 <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-class>)
;; This works:
(pk (+ (bar (make <foo>)) 456))
;; This throws an error:
(pk (+ (bar (make <redefinable-foo>)) 456))
The above code introduces a metaclass, <meta>, that supports a special
slot option: #:box? The metaclass arranges for boxed slots to be
boxed/unboxed transparently via the slot's accessor methods when it
detects the presence of #:box? #t in the slot options. However, the
redefinable class implementation does a transformation of the slot
definitions in its compute-slot method and discards all non-standard
slot options, so the final line throws an error because the bar method
returns a box, not a number.
I see two possibilities:
1) Slots are not designed to be extended with custom options, but it
just happens to work in the case of <class>
2) There's a bug in compute-slots for <redefinable-class>
Is this a bug or as-designed?
Thanks,
- Dave
^ permalink raw reply [flat|nested] 2+ messages in thread
* Re: MOP issues with <redefinable-class>
2021-01-29 13:29 MOP issues with <redefinable-class> Thompson, David
@ 2021-01-29 16:07 ` Thompson, David
0 siblings, 0 replies; 2+ messages in thread
From: Thompson, David @ 2021-01-29 16:07 UTC (permalink / raw)
To: Guile User
[-- Attachment #1: Type: text/plain, Size: 1554 bytes --]
Sigh... I screwed up the example code. Here's a fixed version:
(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 quick patch I threw together that makes the example code
work. Did I find a bug???
- Dave
[-- Attachment #2: 0001-goops-Preserve-all-slot-options-in-redefinable-class.patch --]
[-- Type: text/x-patch, Size: 1923 bytes --]
From 04abf8eb62dd58fa3d7ff3f0924a4aff2cf000c4 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/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
^ permalink raw reply related [flat|nested] 2+ messages in thread
end of thread, other threads:[~2021-01-29 16:07 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-01-29 13:29 MOP issues with <redefinable-class> Thompson, David
2021-01-29 16:07 ` Thompson, David
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).