[Guile-commits] 23/25: Use a vtable bit to mark <slot> instances

[Andy Wingo]

wingo pushed a commit to branch wip-goops-refactor
in repository guile.

commit dea7001663a2479f00a33c124a0e8923933861ae
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 18 21:01:31 2015 +0100

    Use a vtable bit to mark <slot> instances
    
    * libguile/goops.h (SCM_VTABLE_FLAG_GOOPS_SLOT): Allocate another vtable
      flag to indicate that instances of this vtable are slots.
    * libguile/goops.c (scm_init_goops_builtins): Export
      vtable-flag-goops-slot to Scheme.
    
    * module/oop/goops.scm (<slot>, slot?, make-standard-class, initialize):
      Arrange for <slot> classes to have the vtable-flag-goops.slot.
      (build-slots-list): Ensure that <slot> slots are statically laid out.
---
 libguile/goops.c     |    2 +
 libguile/goops.h     |    1 +
 module/oop/goops.scm |   51 +++++++++++++++++++++++++++++++------------------
 3 files changed, 35 insertions(+), 19 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 9cce078..d3561e8 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1047,6 +1047,8 @@ scm_init_goops_builtins (void *unused)
                 scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS));
   scm_c_define ("vtable-flag-goops-valid",
                 scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID));
+  scm_c_define ("vtable-flag-goops-slot",
+                scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT));
 }
 
 void
diff --git a/libguile/goops.h b/libguile/goops.h
index 3dd3f3e..daa2a9e 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -42,6 +42,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_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 ddb7995..3f38d01 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -412,6 +412,7 @@ followed by its associated value.  If @var{l} does not hold 
a value for
            (nfields (/ (string-length layout) 2))
            (<slot> (make-struct/no-tail <class> (make-struct-layout layout))))
       (class-add-flags! <slot> (logior vtable-flag-goops-class
+                                       vtable-flag-goops-slot
                                        vtable-flag-goops-valid))
       (struct-set! <slot> class-index-name '<slot>)
       (struct-set! <slot> class-index-nfields nfields)
@@ -424,8 +425,9 @@ followed by its associated value.  If @var{l} does not hold 
a value for
       (struct-set! <slot> class-index-redefined #f)
       <slot>)))
 
-(define (slot? obj)
-  (is-a? obj <slot>))
+(define-inlinable (slot? obj)
+  (and (struct? obj)
+       (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
 
 (define-syntax-rule (define-slot-accessor name docstring field)
   (define (name obj)
@@ -631,10 +633,10 @@ followed by its associated value.  If @var{l} does not 
hold a value for
           (() #f)
           ((slot . slots)
            (or (eq? (slot-definition-name slot) name) (lp slots)))))))
-  (define (check-cpl slots class-slots )
-    (when (or-map (lambda (slot) (slot-memq slot slots)) class-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 <class> inherited field cannot be redefined"
+                 "a predefined static inherited field cannot be redefined"
                  '() '())))
   (define (remove-duplicate-slots slots)
     (let lp ((slots (reverse slots)) (res '()) (seen '()))
@@ -645,26 +647,31 @@ followed by its associated value.  If @var{l} does not 
hold a value for
            (if (memq name seen)
                (lp slots res seen)
                (lp slots (cons slot res) (cons name seen))))))))
-  ;; FIXME: the thing we do for <class> ensures static slot allocation.
-  ;; do the same thing for <slot>.
-  (let* ((class-slots (and (memq <class> cpl)
-                           (struct-ref <class> class-index-slots))))
-    (when class-slots
-      (check-cpl dslots class-slots))
-    (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
+  ;; 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))))
+    (when static-slots
+      (check-cpl dslots static-slots))
+    (let lp ((cpl (cdr cpl)) (res dslots) (static-slots '()))
       (match cpl
-        (() (remove-duplicate-slots (append class-slots res)))
+        (() (remove-duplicate-slots (append static-slots res)))
         ((head . cpl)
          (let ((new-slots (struct-ref head class-index-direct-slots)))
            (cond
-            ((not class-slots)
-             (lp cpl (append new-slots res) class-slots))
-            ((eq? head <class>)
-             ;; Move class slots to the head of the list.
+            ((not static-slots)
+             (lp cpl (append new-slots res) static-slots))
+            ((or (eq? head <class>) (eq? head <slot>))
+             ;; Move static slots to the head of the list.
              (lp cpl res new-slots))
             (else
-             (check-cpl new-slots class-slots)
-             (lp cpl (append new-slots res) class-slots)))))))))
+             (check-cpl new-slots static-slots)
+             (lp cpl (append new-slots res) static-slots)))))))))
 
 ;; Boot definition.
 (define (compute-get-n-set class slot)
@@ -768,6 +775,8 @@ slots as we go."
     (struct-set! z class-index-redefined #f)
     (let ((cpl (compute-cpl z)))
       (struct-set! z class-index-cpl cpl)
+      (when (memq <slot> cpl)
+        (class-add-flags! z vtable-flag-goops-slot))
       (let* ((dslots (map make-direct-slot-definition dslots))
              (slots (allocate-slots z (build-slots-list dslots cpl))))
         (struct-set! z class-index-direct-slots dslots)
@@ -2754,6 +2763,10 @@ var{initargs}."
   (struct-set! class class-index-slots
                (allocate-slots class (compute-slots class)))
 
+  ;; This is a hack.
+  (when (memq <slot> (struct-ref class class-index-cpl))
+    (class-add-flags! class vtable-flag-goops-slot))
+
   ;; Build getters - setters - accessors
   (compute-slot-accessors class (struct-ref class class-index-slots))