[Guile-commits] 51/87: goops.c no longer knows about <class> slot allocation

[Andy Wingo]

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

commit 3e7fb22b8077add96b0c56115386aedacd8b07cf
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 11 21:31:51 2015 +0100

    goops.c no longer knows about <class> slot allocation
    
    * libguile/goops.c (scm_class_of): Access "redefined" slot by name in
      the case where we need to change the class of an instance.
      (scm_sys_goops_early_init): Move up capture of class-precedence-list
      so SCM_SUBCLASSP can use it.
    
    * libguile/goops.h (SCM_CLASS_CLASS_LAYOUT, scm_si_redefined)
      (scm_si_direct_supers, scm_si_direct_slots, scm_si_direct_subclasses)
      (scm_si_direct_methods, scm_si_cpl scm_si_slots)
      (scm_si_getters_n_setters, SCM_N_CLASS_SLOTS, SCM_OBJ_CLASS_REDEF):
      Remove.  Now C code has no special knowledge about the layout of
      GOOPS classes.
      (SCM_SUBCLASSP): Use scm_class_precedence_list to get CPL.
      (SCM_INST, SCM_ACCESSORS_OF): Remove unused macros that were
      undocumented and nonsensical.
---
 libguile/goops.c |   17 +++++++++++------
 libguile/goops.h |   32 ++------------------------------
 2 files changed, 13 insertions(+), 36 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 6e946a1..ef21184 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -69,6 +69,7 @@
 
 SCM_KEYWORD (k_name, "name");
 SCM_KEYWORD (k_setter, "setter");
+SCM_SYMBOL (sym_redefined, "redefined");
 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
 
 static int goops_loaded_p = 0;
@@ -254,14 +255,16 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
                                    : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
        case scm_tcs_struct:
          if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
+            /* A GOOPS object with a valid class.  */
            return SCM_CLASS_OF (x);
          else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
+            /* A GOOPS object whose class might have been redefined.  */
            {
-             /* Goops object */
-             if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
-               scm_change_object_class (x,
-                                        SCM_CLASS_OF (x),         /* old */
-                                        SCM_OBJ_CLASS_REDEF (x)); /* new */
+              SCM class = SCM_CLASS_OF (x);
+              SCM new_class = scm_slot_ref (class, sym_redefined);
+              if (!scm_is_false (new_class))
+               scm_change_object_class (x, class, new_class);
+              /* Re-load class from instance.  */
              return SCM_CLASS_OF (x);
            }
          else
@@ -1060,6 +1063,9 @@ SCM_DEFINE (scm_sys_goops_early_init, 
"%goops-early-init", 0, 0, 0,
   var_make = scm_c_lookup ("make");
   var_inherit_applicable = scm_c_lookup ("inherit-applicable!");
 
+  /* For SCM_SUBCLASSP.  */
+  var_class_precedence_list = scm_c_lookup ("class-precedence-list");
+
   var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
   var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
   var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
@@ -1159,7 +1165,6 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 
0,
   var_class_direct_slots = scm_c_lookup ("class-direct-slots");
   var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses");
   var_class_direct_methods = scm_c_lookup ("class-direct-methods");
-  var_class_precedence_list = scm_c_lookup ("class-precedence-list");
   var_class_slots = scm_c_lookup ("class-slots");
 
   var_generic_function_methods = scm_c_lookup ("generic-function-methods");
diff --git a/libguile/goops.h b/libguile/goops.h
index f7233cb..fafd7fa 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -54,36 +54,7 @@
 #define SCM_CLASSF_GOOPS         SCM_VTABLE_FLAG_GOOPS_CLASS
 #define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
 
-/*
- * scm_class_class
- */
-
-/* see also, SCM_VTABLE_BASE_LAYOUT, and build_class_class_slots */
-#define SCM_CLASS_CLASS_LAYOUT                  \
-  "pw" /* redefined */                          \
-  "pw" /* direct supers */                      \
-  "pw" /* direct slots */                       \
-  "pw" /* direct subclasses */                  \
-  "pw" /* direct methods */                     \
-  "pw" /* cpl */                                \
-  "pw" /* slots */                              \
-  "pw" /* getters-n-setters */
-
-#define scm_si_redefined         (scm_vtable_offset_user + 0)
-#define scm_si_direct_supers    (scm_vtable_offset_user + 1) /* (class ...) */
-#define scm_si_direct_slots     (scm_vtable_offset_user + 2) /* ((name . 
options) ...) */
-#define scm_si_direct_subclasses (scm_vtable_offset_user + 3) /* (class ...) */
-#define scm_si_direct_methods   (scm_vtable_offset_user + 4) /* (methods ...) 
*/
-#define scm_si_cpl              (scm_vtable_offset_user + 5) /* (class ...) */
-#define scm_si_slots            (scm_vtable_offset_user + 6) /* ((name . 
options) ...) */
-#define scm_si_getters_n_setters (scm_vtable_offset_user + 7)
-#define SCM_N_CLASS_SLOTS       (scm_vtable_offset_user + 8)
-
-#define SCM_OBJ_CLASS_REDEF(x)  (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x) 
[scm_si_redefined]))
-#define SCM_INST(x)           SCM_STRUCT_DATA (x)
-
 #define SCM_CLASS_OF(x)        SCM_STRUCT_VTABLE (x)
-#define SCM_ACCESSORS_OF(x)    (SCM_PACK (SCM_STRUCT_VTABLE_DATA 
(x)[scm_si_getters_n_setters]))
 
 #define SCM_CLASSP(x) \
   (SCM_STRUCTP (x) && SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_METACLASS)
@@ -96,7 +67,8 @@
 #define SCM_SLOT(x, i)         (SCM_STRUCT_SLOT_REF (x, i))
 #define SCM_SET_SLOT(x, i, v)  (SCM_STRUCT_SLOT_SET (x, i, v))
 
-#define SCM_SUBCLASSP(c1, c2)  (scm_is_true (scm_c_memq (c2, SCM_SLOT (c1, 
scm_si_cpl))))
+#define SCM_SUBCLASSP(c1, c2) \
+  (scm_is_true (scm_c_memq (c2, scm_class_precedence_list (c1))))
 #define SCM_IS_A_P(x, c) \
   (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), c))