Manipulate GOOPS vtable flags from Scheme, for speed

* libguile/goops.h: Remove unimplemented declarations of
  scm_make_next_method, scm_sys_invalidate_method_cache_x, and
  stklos_version.
  (scm_sys_invalidate_class_x): Remove helper definition.  This was
  exported in the past but shouldn't have been.

* libguile/goops.c (scm_sys_make_vtable_vtable): Rename from
  scm_sys_make_root_class, and don't do anything about flags.
  (scm_sys_bless_applicable_struct_vtables_x, scm_class_p)
  (scm_sys_invalidate_class_x): Remove; we do these in Scheme now.
  (scm_init_goops_builtins): Define Scheme values for vtable flags.

* module/oop/goops.scm (vtable-flag-goops-metaclass)
  (class-add-flags!, class-clear-flags!, class-has-flags?)
  (class?, instance?): New definitions.
  (<class>): Add GOOPS metaclass flags from Scheme.
  (<applicable-struct-class>, <applicable-struct-with-setter-class>):
  Add flags from Scheme.
  (make, initialize): Add class flags as appropriate.
  (class-redefinition): Clear the "valid" flag on the old class.
  (check-slot-args): Use instance? instead of a CPL check.

diff --git a/libguile/goops.c b/libguile/goops.c
index f2ca981..42b7a1b 100644 (file)
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -156,10 +156,7 @@ SCM scm_module_goops;
 
 static SCM scm_make_unbound (void);
 static SCM scm_unbound_p (SCM obj);
-static SCM scm_class_p (SCM obj);
-static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable,
-                                                      SCM setter);
-static SCM scm_sys_make_root_class (SCM layout);
+static SCM scm_sys_make_vtable_vtable (SCM layout);
 static SCM scm_sys_init_layout_x (SCM class, SCM layout);
 static SCM scm_sys_clear_fields_x (SCM obj);
 static SCM scm_sys_goops_early_init (void);
@@ -168,30 +165,12 @@ static SCM scm_sys_goops_loaded (void);
 
 \f
 
-SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0,
+SCM_DEFINE (scm_sys_make_vtable_vtable, "%make-vtable-vtable", 1, 0, 0,
             (SCM layout),
            "")
-#define FUNC_NAME s_scm_sys_make_root_class
+#define FUNC_NAME s_scm_sys_make_vtable_vtable
 {
-  SCM z;
-
-  z = scm_i_make_vtable_vtable (layout);
-  SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS));
-
-  return z;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0,
-           (SCM applicable, SCM setter),
-           "")
-#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x
-{
-  SCM_VALIDATE_CLASS (1, applicable);
-  SCM_VALIDATE_CLASS (2, setter);
-  SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
-  SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE);
-  return SCM_UNSPECIFIED;
+  return scm_i_make_vtable_vtable (layout);
 }
 #undef FUNC_NAME
 
@@ -357,15 +336,6 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_class_p, "class?", 1, 0, 0,
-           (SCM obj),
-           "Return @code{#t} if @var{obj} is a class.")
-#define FUNC_NAME s_scm_class_p
-{
-  return scm_from_bool (SCM_CLASSP (obj));
-}
-#undef FUNC_NAME
-
 int
 scm_is_generic (SCM x)
 {
@@ -617,17 +587,6 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
-           (SCM class),
-           "")
-#define FUNC_NAME s_scm_sys_invalidate_class
-{
-  SCM_VALIDATE_CLASS (1, class);
-  SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
-  return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
 /* When instances change class, they finally get a new body, but
  * before that, they go through purgatory in hell.  Odd as it may
  * seem, this data structure saves us from eternal suffering in
@@ -1143,6 +1102,19 @@ scm_init_goops_builtins (void *unused)
   hell_mutex = scm_make_mutex ();
 
 #include "libguile/goops.x"
+
+  scm_c_define ("vtable-flag-vtable",
+                scm_from_int (SCM_VTABLE_FLAG_VTABLE));
+  scm_c_define ("vtable-flag-applicable-vtable",
+                scm_from_int (SCM_VTABLE_FLAG_APPLICABLE_VTABLE));
+  scm_c_define ("vtable-flag-setter-vtable",
+                scm_from_int (SCM_VTABLE_FLAG_SETTER_VTABLE));
+  scm_c_define ("vtable-flag-validated",
+                scm_from_int (SCM_VTABLE_FLAG_VALIDATED));
+  scm_c_define ("vtable-flag-goops-class",
+                scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS));
+  scm_c_define ("vtable-flag-goops-valid",
+                scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID));
 }
 
 void

diff --git a/libguile/goops.h b/libguile/goops.h
index ca9c41b..e83bf09 100644 (file)
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -93,7 +93,6 @@ SCM_API SCM scm_ensure_accessor (SCM name);
 SCM_API SCM scm_class_of (SCM obj);
 
 /* Low level functions exported */
-SCM_API SCM scm_make_next_method (SCM methods, SCM args, SCM gf);
 SCM_INTERNAL SCM scm_make_standard_class (SCM meta, SCM name, SCM dsupers,
                                           SCM dslots);
 
@@ -125,13 +124,10 @@ SCM_API SCM scm_slot_bound_p (SCM obj, SCM slot_name);
 SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name);
 SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst);
 SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls);
-SCM_API SCM scm_sys_invalidate_class (SCM cls);
-SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf);
 SCM_API SCM scm_generic_capability_p (SCM proc);
 SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
 SCM_INTERNAL SCM scm_set_primitive_generic_x (SCM subr, SCM generic);
 SCM_API SCM scm_primitive_generic_generic (SCM subr);
-SCM_API SCM stklos_version (void);
 SCM_API SCM scm_make (SCM args);
 SCM_API void scm_change_object_class (SCM, SCM, SCM);
 

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 41b4226..4464daa 100644 (file)
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -216,6 +216,36 @@
                        tail))))))
   (fold-class-slots macro-fold-left define-class-index (begin)))
 
+;;;
+;;; Structs that are vtables have a "flags" slot, which corresponds to
+;;; class-index-flags.  `vtable-flag-vtable' indicates that instances of
+;;; a vtable are themselves vtables, and `vtable-flag-validated'
+;;; indicates that the struct's layout has been validated.  goops.c
+;;; defines a couple of additional flags: one to indicate that a vtable
+;;; is actually a class, and one to indicate that the class is "valid",
+;;; meaning that it hasn't been redefined.
+;;;
+(define vtable-flag-goops-metaclass
+  (logior vtable-flag-vtable vtable-flag-goops-class))
+
+(define-inlinable (class-add-flags! class flags)
+  (struct-set! class class-index-flags
+               (logior flags (struct-ref class class-index-flags))))
+
+(define-inlinable (class-clear-flags! class flags)
+  (struct-set! class class-index-flags
+               (logand (lognot flags) (struct-ref class class-index-flags))))
+
+(define-inlinable (class-has-flags? class flags)
+  (eqv? flags
+        (logand (struct-ref class class-index-flags) flags)))
+
+(define-inlinable (class? obj)
+  (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
+
+(define-inlinable (instance? obj)
+  (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
+
 ;;;
 ;;; Now that we know the slots that must be present in classes, and
 ;;; their offsets, we can create the root of the class hierarchy.
@@ -249,7 +279,9 @@
                   ((_ (name class) tail) (cons (list 'name) tail)))))
     (let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
            (slots (fold-class-slots macro-fold-right cons-slot '()))
-           (<class> (%make-root-class layout)))
+           (<class> (%make-vtable-vtable layout)))
+      (class-add-flags! <class> (logior vtable-flag-goops-class
+                                        vtable-flag-goops-valid))
       (struct-set! <class> class-index-name '<class>)
       (struct-set! <class> class-index-nfields (length slots))
       (struct-set! <class> class-index-direct-supers '())
@@ -593,12 +625,16 @@ subclasses of @var{c}."
 ;;;
 
 (define-standard-class <procedure-class> (<class>))
+
 (define-standard-class <applicable-struct-class>
   (<procedure-class>))
+(class-add-flags! <applicable-struct-class>
+                  vtable-flag-applicable-vtable)
+
 (define-standard-class <applicable-struct-with-setter-class>
   (<applicable-struct-class>))
-(%bless-applicable-struct-vtables! <applicable-struct-class>
-                                   <applicable-struct-with-setter-class>)
+(class-add-flags! <applicable-struct-with-setter-class>
+                  vtable-flag-setter-vtable)
 
 (define-standard-class <applicable> (<top>))
 (define-standard-class <applicable-struct> (<object> <applicable>)
@@ -764,6 +800,8 @@ followed by its associated value.  If @var{l} does not hold a value for
                     (#:body body ())
                     (#:make-procedure make-procedure #f))))
        ((memq <class> (class-precedence-list class))
+        (class-add-flags! z (logior vtable-flag-goops-class
+                                    vtable-flag-goops-valid))
         (for-each (match-lambda
                    ((kw slot default)
                     (slot-set! z slot (get-keyword kw args default))))
@@ -817,7 +855,7 @@ followed by its associated value.  If @var{l} does not hold a value for
   (unless (class? class)
     (scm-error 'wrong-type-arg #f "Not a class: ~S"
                (list class) #f))
-  (unless (is-a? obj <object>)
+  (unless (instance? obj)
     (scm-error 'wrong-type-arg #f "Not an instance: ~S"
                (list obj) #f))
   (unless (symbol? slot-name)
@@ -2239,7 +2277,7 @@ followed by its associated value.  If @var{l} does not hold a value for
   ;; Invalidate class so that subsequent instances slot accesses invoke
   ;; change-object-class
   (struct-set! new class-index-redefined old)
-  (%invalidate-class new) ;must come after slot-set!
+  (class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set!
 
   old)
 
@@ -2544,6 +2582,8 @@ var{initargs}."
   (next-method)
   (let ((dslots (get-keyword #:slots initargs '()))
         (supers (get-keyword #:dsupers    initargs '())))
+    (class-add-flags! class (logior vtable-flag-goops-class
+                                    vtable-flag-goops-valid))
     (let ((name (get-keyword #:name initargs '???)))
       (struct-set! class class-index-name            name))
     (struct-set! class class-index-nfields           0)