[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] branch master updated: goops: Preserve all slot options
From: |
Andy Wingo |
Subject: |
[Guile-commits] branch master updated: goops: Preserve all slot options in redefinable classes. |
Date: |
Fri, 19 Mar 2021 16:46:06 -0400 |
This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch master
in repository guile.
The following commit(s) were added to refs/heads/master by this push:
new 498564e goops: Preserve all slot options in redefinable classes.
498564e is described below
commit 498564e3e3698565ed5e7697096dd57829d4b686
Author: David Thompson <dthompson@vistahigherlearning.com>
AuthorDate: Fri Jan 29 11:04:56 2021 -0500
goops: Preserve all slot options in redefinable classes.
* module/goops.scm (compute-slots): Fix <redefinable-class> slot
transformation.
* test-suite/tests/goops.test ("slot options on redefinable classes"):
Add a test.
---
module/oop/goops.scm | 16 +++++++++-------
test-suite/tests/goops.test | 44 +++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 52 insertions(+), 8 deletions(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 9edc16b..de5e890 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)
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 4536a46..b06ba98 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,6 +1,6 @@
;;;; goops.test --- test suite for GOOPS -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015,
2017 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015,
2017, 2021 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -719,3 +719,45 @@
;; that the multi-arity dispatcher works:
(dispatch 1 2 3))
(current-module))))
+
+;; The defined? check in define-accessor prevents a local definition of
+;; get-the-bar, sadly!
+(define-accessor get-the-bar)
+(with-test-prefix "slot options on redefinable classes"
+ (let ((<meta> (class (<class>)))
+ (box make-variable)
+ (unbox variable-ref))
+ (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)))
+
+ (let* ((<redefinable-meta> (class (<meta> <redefinable-class>)))
+ (<foo>
+ (class ()
+ (bar #:accessor get-the-bar #:box? #t #:init-form (box 123))
+ #:metaclass <meta>))
+ (<redefinable-foo>
+ (class ()
+ (bar #:accessor get-the-bar #:box? #t #:init-form (box 123))
+ #:metaclass <redefinable-meta>)))
+ (pass-if-equal 123 (get-the-bar (make <foo>)))
+ (pass-if-equal 123 (get-the-bar (make <redefinable-foo>))))))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] branch master updated: goops: Preserve all slot options in redefinable classes.,
Andy Wingo <=