mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Fix class slot allocation since GOOPS rewrite

Browse source 
* module/oop/goops.scm (%compute-layout): Fix class slot layout.
  Before, a #:class that was an argument to #:allocation was getting
  interpreted as a keyword with a value.
* test-suite/tests/goops.test ("#:class slot allocation"): Add test.
This commit is contained in:
Andy Wingo 2017-03-01 15:37:05 +01:00
parent a86bb2e613
commit 77cfd7e4bf
2 changed files with 10 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

2
module/oop/goops.scm
View file

@ -765,7 +765,7 @@ slots as we go."
(define (slot-protection-and-kind slot) (define (slot-protection-and-kind slot)
(define (subclass? class parent) (define (subclass? class parent)
(memq parent (class-precedence-list class))) (memq parent (class-precedence-list class)))
(let ((type (kw-arg-ref (%slot-definition-options slot) #:class))) (let ((type (get-keyword #:class (%slot-definition-options slot))))
(if (and type (subclass? type <foreign-slot>)) (if (and type (subclass? type <foreign-slot>))
(values (cond (values (cond
((subclass? type <self-slot>) #\s) ((subclass? type <self-slot>) #\s)

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

@ -572,6 +572,15 @@
exception:out-of-range exception:out-of-range
(make <foreign-test> #:a (ash 1 64)))) (make <foreign-test> #:a (ash 1 64))))
(with-test-prefix "#:class slot allocation"
(pass-if-equal "basic class slot allocation" #:class
(eval '(begin
(define-class <has-a-class-slot> ()
(bar #:allocation #:class #:init-value 'baz))
(slot-definition-allocation
(class-slot-definition <has-a-class-slot> 'bar)))
(current-module))))
(with-test-prefix "#:each-subclass" (with-test-prefix "#:each-subclass"
(let* ((<subclass-allocation-test> (let* ((<subclass-allocation-test>
(class () (class ()