diff options
author | David Thompson <dthompson@vistahigherlearning.com> | 2021-01-29 11:04:56 -0500 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-03-19 21:45:53 +0100 |
commit | 498564e3e3698565ed5e7697096dd57829d4b686 (patch) | |
tree | 8098fd0f7aa0aa7c520339c82a9e3ba83795c666 | |
parent | c92f2c7df0532b9f44dea59e68e1079e9504371b (diff) | |
download | guile-498564e3e3698565ed5e7697096dd57829d4b686.tar.gz |
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.
-rw-r--r-- | module/oop/goops.scm | 16 | ||||
-rw-r--r-- | 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 9edc16b07..de5e8907d 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 4536a468d..b06ba98b2 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>)))))) |