[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Fix class slot allocation since GOOPS rewrite
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: Fix class slot allocation since GOOPS rewrite |
Date: |
Wed, 1 Mar 2017 09:38:31 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 77cfd7e4bfbf8271a5b75a62bbad3ce0bf79f209
Author: Andy Wingo <address@hidden>
Date: Wed Mar 1 15:37:05 2017 +0100
Fix class slot allocation since GOOPS rewrite
* 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.
---
module/oop/goops.scm | 2 +-
test-suite/tests/goops.test | 9 +++++++++
2 files changed, 10 insertions(+), 1 deletion(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index ece03c6..b7d980d 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -765,7 +765,7 @@ slots as we go."
(define (slot-protection-and-kind slot)
(define (subclass? class parent)
(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>))
(values (cond
((subclass? type <self-slot>) #\s)
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 259eba8..6c66604 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -572,6 +572,15 @@
exception:out-of-range
(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"
(let* ((<subclass-allocation-test>
(class ()