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.

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index ece03c6e06da5287b6b1c324266e42eee76d39a1..b7d980dceeea545e09eba4dae932adf1d19ea89d 100644 (file)
--- 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 259eba84bdc66ce85a83920f1f62e8d04419ade4..6c66604783f7d72428b85a21b415acc7077f036e 100644 (file)
--- 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 ()