mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

goops: Preserve all slot options in redefinable classes.

Browse source 
* module/goops.scm (compute-slots): Fix <redefinable-class> slot
transformation.
* test-suite/tests/goops.test ("slot options on redefinable classes"):
Add a test.
This commit is contained in:
David Thompson 2021-01-29 11:04:56 -05:00 • committed by Andy Wingo
parent c92f2c7df0
commit 498564e3e3
2 changed files with 52 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

16
module/oop/goops.scm
View file

@ -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)

44
test-suite/tests/goops.test
View file

@ -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>))))))