Add #:static-slot-allocation?

* libguile/goops.h (SCM_VTABLE_FLAG_GOOPS_STATIC): Reserve the fourth
  GOOPS flag to indicate that a class has static slot allocation.

* libguile/goops.c (scm_init_goops_builtins): Define
  vtable-flag-goops-static for goops.scm.

* module/oop/goops.scm (class-has-statically-allocated-slots?): New
  helper.
  (build-slots-list): Instead of the ad-hoc checks for <class> or
  <slot>, use the new helper.
  (initialize): Accept #:static-slot-allocation? keyword.

* module/system/foreign-object.scm (make-foreign-object-type): Declare
  foreign object classes as having static slot allocation.

* test-suite/tests/goops.test ("static slot allocation"): Add tests.

5 files changed, 60 insertions, 13 deletions

diff --git a/libguile/goops.c b/libguile/goops.c
index d5c743559..1f7ec90c8 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1055,6 +1055,8 @@ scm_init_goops_builtins (void *unused)
                 scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID));
   scm_c_define ("vtable-flag-goops-slot",
                 scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT));
+  scm_c_define ("vtable-flag-goops-static",
+                scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC));
 }
 
 void
diff --git a/libguile/goops.h b/libguile/goops.h
index daa2a9e1a..cc743a685 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -43,6 +43,7 @@
 #define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0
 #define SCM_VTABLE_FLAG_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_1
 #define SCM_VTABLE_FLAG_GOOPS_SLOT SCM_VTABLE_FLAG_GOOPS_2
+#define SCM_VTABLE_FLAG_GOOPS_STATIC SCM_VTABLE_FLAG_GOOPS_3
 
 #define SCM_CLASS_OF(x)         SCM_STRUCT_VTABLE (x)
 #define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index b79b79f37..5a5d469eb 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -277,6 +277,9 @@
 (define-inlinable (instance? obj)
   (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
 
+(define (class-has-statically-allocated-slots? class)
+  (class-has-flags? class vtable-flag-goops-static))
+
 ;;;
 ;;; Now that we know the slots that must be present in classes, and
 ;;; their offsets, we can create the root of the class hierarchy.
@@ -638,10 +641,14 @@ followed by its associated value.  If @var{l} does not hold a value for
           ((slot . slots)
            (or (eq? (%slot-definition-name slot) name) (lp slots)))))))
   (define (check-cpl slots static-slots)
-    (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
-      (scm-error 'misc-error #f
-                 "a predefined static inherited field cannot be redefined"
-                 '() '())))
+    (match static-slots
+      (() #t)
+      ((static-slot . static-slots)
+       (when (slot-memq static-slot slots)
+         (scm-error 'misc-error #f
+                    "statically allocated inherited field cannot be redefined: ~a"
+                    (list (%slot-definition-name static-slot)) '()))
+       (check-cpl slots static-slots))))
   (define (remove-duplicate-slots slots)
     (let lp ((slots (reverse slots)) (res '()) (seen '()))
       (match slots
@@ -653,13 +660,13 @@ followed by its associated value.  If @var{l} does not hold a value for
                (lp slots (cons slot res) (cons name seen))))))))
   ;; For subclases of <class> and <slot>, we need to ensure that the
   ;; <class> or <slot> slots come first.
-  (let* ((static-slots (cond
-                        ((memq <class> cpl)
-                         (when (memq <slot> cpl) (error "invalid class"))
-                         (struct-ref <class> class-index-slots))
-                        ((memq <slot> cpl)
-                         (struct-ref <slot> class-index-slots))
-                        (else #f))))
+  (let ((static-slots
+         (match (filter class-has-statically-allocated-slots? (cdr cpl))
+           (() #f)
+           ((class) (struct-ref class class-index-direct-slots))
+           (classes
+            (error "can't subtype multiple classes with static slot allocation"
+                   classes)))))
     (when static-slots
       (check-cpl dslots static-slots))
     (let lp ((cpl (cdr cpl)) (res dslots) (static-slots '()))
@@ -670,7 +677,7 @@ followed by its associated value.  If @var{l} does not hold a value for
            (cond
             ((not static-slots)
              (lp cpl (append new-slots res) static-slots))
-            ((or (eq? head <class>) (eq? head <slot>))
+            ((class-has-statically-allocated-slots? head)
              ;; Move static slots to the head of the list.
              (lp cpl res new-slots))
             (else
@@ -912,7 +919,12 @@ slots as we go."
   (initialize-direct-slots! <class> fold-class-slots)
 
   (initialize-slots! <class>)
-  (initialize-slots! <slot>))
+  (initialize-slots! <slot>)
+
+  ;; Now that we're all done with that, mark <class> and <slot> as
+  ;; static.
+  (class-add-flags! <class> vtable-flag-goops-static)
+  (class-add-flags! <slot> vtable-flag-goops-static))
 
 
 
@@ -2834,6 +2846,13 @@ var{initargs}."
   (struct-set! class class-index-direct-methods '())
   (struct-set! class class-index-redefined #f)
   (struct-set! class class-index-cpl (compute-cpl class))
+  (when (get-keyword #:static-slot-allocation? initargs #f)
+    (match (filter class-has-statically-allocated-slots?
+                   (class-precedence-list class))
+      (()
+       (class-add-flags! class vtable-flag-goops-static))
+      (classes
+       (error "Class has superclasses with static slot allocation" classes))))
   (struct-set! class class-index-direct-slots
                (map (lambda (slot)
                       (if (slot? slot)
diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm
index f7bfc946f..a8022b9c0 100644
--- a/module/system/foreign-object.scm
+++ b/module/system/foreign-object.scm
@@ -63,8 +63,10 @@
     (if finalizer
         (make-class '() dslots #:name name
                     #:finalizer finalizer
+                    #:static-slot-allocation? #t
                     #:metaclass <foreign-class-with-finalizer>)
         (make-class '() dslots #:name name
+                    #:static-slot-allocation? #t
                     #:metaclass <foreign-class>))))
 
 (define-syntax define-foreign-object-type
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 5b26cb83f..087b6a90a 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -657,3 +657,26 @@
     (pass-if-equal "b accessor on ba" 'b (b-accessor ba))
     (pass-if-equal "b accessor on cab" 'b (b-accessor cab))
     (pass-if-equal "b accessor on cba" 'b (b-accessor cba))))
+
+(with-test-prefix "static slot allocation"
+  (let* ((<a> (class () (a) #:name '<a> #:static-slot-allocation? #t))
+         (<b> (class () (b) #:name '<b> #:static-slot-allocation? #t))
+         (<c> (class () (c) #:name '<c>))
+         (<ac> (class (<a> <c>) #:name '<ac>))
+         (<ca> (class (<c> <a>) #:name '<ca>)))
+    (pass-if-equal "slots of <ac>" '(a c)
+      (map slot-definition-name (class-slots <ac>)))
+    (pass-if-equal "slots of <ca>" '(a c)
+      (map slot-definition-name (class-slots <ca>)))
+    (pass-if-exception "can't make <ab>"
+        '(misc-error . "static slot")
+      (class (<a> <b>) #:name '<ab>))
+    ;; It should be possible to create subclasses of static classes
+    ;; whose slots are statically allocated, as long as there is no
+    ;; diamond inheritance among static superclasses, but for now we
+    ;; don't support it at all.
+    (pass-if-exception "static subclass"
+        '(misc-error . "static slot")
+      (class (<a>) (slot) #:name '<static-sub> #:static-slot-allocation? #t))
+    (pass-if-equal "non-static subclass" '(a d)
+      (map slot-definition-name (class-slots (class (<a>) (d) #:name '<ad>))))))