guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 11/87: Move GOOPS boot to Scheme


From: Andy Wingo
Subject: [Guile-commits] 11/87: Move GOOPS boot to Scheme
Date: Thu, 22 Jan 2015 17:29:43 +0000

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

commit 29178cd860b5e81195428829fd2d710c8f1f05f7
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 4 13:41:09 2015 -0500

    Move GOOPS boot to Scheme
    
    * module/oop/goops.scm (build-<class>-slots): New helper, replacing
      build_class_class_slots.
      (build-slots-list, %compute-getters-n-setters, %compute-layout): New
      private helpers, moved here from C.
      (%prep-layout!): Reimplement in Scheme.
      (make-standard-class): New private helper, replacing
      scm_basic_make_class.
      (<class>, <top>, <object>): Define in Scheme.
    
      (<foreign-slot>, <protected-slot>, <hidden-slot>, <opaque-slot>,
       <read-only-slot>, <self-slot>, <protected-opaque-slot>,
       <protected-hidden-slot>, <protected-read-only-slot>, <scm-slot>,
       <int-slot>, <float-slot>, <double-slot>, <procedure-class>,
       <applicable-struct-class>, <method>, <accessor-method>, <applicable>,
       <applicable-struct>, <generic>, <extended-generic>,
       <generic-with-setter>, <accessor>, <extended-generic-with-setter>,
       <extended-accessor>): Define in Scheme.
    
      (<boolean>, <char>, <list>, <pair>, <null>, <string>, <symbol>,
       <vector>, <foreign>, <hashtable>, <fluid>, <dynamic-state>, <frame>,
       <vm-continuation>, <bytevector>, <uvec>, <array>, <bitvector>,
       <number>, <complex>, <real>, <integer>, <fraction>, <keyword>,
       <unknown>, <procedure>, <primitive-generic>, <port>, <input-port>,
       <output-port>, <input-output-port>): Define in Scheme.
    
      (compute-slots): Use build-slots-list helper.
    
    * libguile/goops.h:
    * libguile/goops.c (scm_basic_basic_make_class, scm_sys_compute_slots)
      (scm_sys_prep_layout_x): Remove.  These were available to C, but were
      undocumented internals that were dangerous, confusing, and
      unnecessary.
    
    * libguile/goops.c: Add note about variable versus value references.
      Remove internal C routines that were just used during boot, as they
      have been moved to Scheme.
      (scm_basic_make_class): Change to call out to make-standard-class in
      Scheme.
      (scm_sys_make_root_class, scm_sys_bless_applicable_struct_vtable_x)
      (scm_sys_bless_pure_generic_vtable_x, scm_sys_init_layout_x): New
      private helpers.
      (scm_sys_goops_early_init): Change to capture values defined in
      Scheme.
---
 libguile/goops.c     |  809 ++++++++++----------------------------------------
 libguile/goops.h     |    5 +-
 module/oop/goops.scm |  313 +++++++++++++++++++-
 3 files changed, 467 insertions(+), 660 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 56365ea..9e9a514 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -63,18 +63,23 @@
 #define SCM_OUT_PCLASS_INDEX      SCM_I_MAX_PORT_TYPE_COUNT
 #define SCM_INOUT_PCLASS_INDEX    (2 * SCM_I_MAX_PORT_TYPE_COUNT)
 
-/* this file is a mess. in theory, though, we shouldn't have many SCM 
references
-   -- most of the references should be to vars. */
+/* Objects have identity, so references to classes and instances are by
+   value, not by reference.  Redefinition of a class or modification of
+   an instance causes in-place update; you can think of GOOPS as
+   building in its own indirection, and for that reason referring to
+   GOOPS values by variable reference is unnecessary.
 
+   References to ordinary procedures is by reference (by variable),
+   though, as in the rest of Guile.  */
+
+static SCM var_make_standard_class = SCM_BOOL_F;
 static SCM var_slot_unbound = SCM_BOOL_F;
 static SCM var_slot_missing = SCM_BOOL_F;
-static SCM var_compute_cpl = SCM_BOOL_F;
 static SCM var_no_applicable_method = SCM_BOOL_F;
 static SCM var_change_class = SCM_BOOL_F;
 
 SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
 SCM_SYMBOL (sym_slot_missing, "slot-missing");
-SCM_SYMBOL (sym_compute_cpl, "compute-cpl");
 SCM_SYMBOL (sym_no_applicable_method, "no-applicable-method");
 SCM_SYMBOL (sym_memoize_method_x, "memoize-method!");
 SCM_SYMBOL (sym_change_class, "change-class");
@@ -172,6 +177,11 @@ static SCM scm_make_unbound (void);
 static SCM scm_unbound_p (SCM obj);
 static SCM scm_assert_bound (SCM value, SCM obj);
 static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
+static SCM scm_sys_bless_applicable_struct_vtable_x (SCM vtable);
+static SCM scm_sys_bless_pure_generic_vtable_x (SCM vtable);
+static SCM scm_sys_make_root_class (SCM name, SCM dslots,
+                                    SCM getters_n_setters);
+static SCM scm_sys_init_layout_x (SCM class, SCM layout);
 static SCM scm_sys_goops_early_init (void);
 static SCM scm_sys_goops_loaded (void);
 static SCM scm_make_extended_class_from_symbol (SCM type_name_sym, 
@@ -339,170 +349,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 
 /******************************************************************************
  *
- * compute-slots
- *
- 
******************************************************************************/
-
-static SCM
-remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
-{
-  SCM tmp;
-
-  if (!scm_is_pair (l))
-    return res;
-
-  tmp = SCM_CAAR (l);
-  if (!scm_is_symbol (tmp))
-    scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
-
-  if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) {
-    res               = scm_cons (SCM_CAR (l), res);
-    slots_already_seen = scm_cons (tmp, slots_already_seen);
-  }
-
-  return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
-}
-
-static void 
-check_cpl (SCM slots, SCM bslots)
-{
-  for (; scm_is_pair (bslots); bslots = SCM_CDR (bslots))
-    if (scm_is_true (scm_assq (SCM_CAAR (bslots), slots)))
-      scm_misc_error ("init-object", "a predefined <class> inherited "
-                      "field cannot be redefined", SCM_EOL);  
-}
-
-enum build_class_class_slots_mode { BOOT_SLOTS, FINAL_SLOTS };
-static SCM build_class_class_slots (enum build_class_class_slots_mode mode);
-
-static SCM
-build_slots_list (SCM dslots, SCM cpl)
-{
-  SCM bslots, class_slots;
-  int classp;
-  SCM res = dslots;
-
-  class_slots = SCM_EOL;  
-  classp = scm_is_true (scm_memq (scm_class_class, cpl));
-  
-  if (classp) 
-    {
-      bslots = build_class_class_slots (FINAL_SLOTS);
-      check_cpl (res, bslots);
-    }
-  else
-    bslots = SCM_EOL;
-
-  if (scm_is_pair (cpl))
-    {      
-      for (cpl = SCM_CDR (cpl); scm_is_pair (cpl); cpl = SCM_CDR (cpl))
-        {
-          SCM new_slots = SCM_SLOT (SCM_CAR (cpl),
-                                    scm_si_direct_slots);
-          if (classp)
-            {
-              if (!scm_is_eq (SCM_CAR (cpl), scm_class_class))
-                check_cpl (new_slots, bslots);
-              else
-                {
-                  /* Move class slots to the head of the list. */
-                  class_slots = new_slots;
-                  continue;
-                }
-            }   
-          res = scm_append (scm_list_2 (new_slots, res));
-        }
-    }
-  else
-    scm_misc_error ("%compute-slots", "malformed cpl argument in "
-                    "build_slots_list", SCM_EOL);
-
-  /* make sure to add the <class> slots to the head of the list */
-  if (classp)
-    res = scm_append (scm_list_2 (class_slots, res));
-
-  /* res contains a list of slots. Remove slots which appears more than once */
-  return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL);
-}
-
-static SCM
-maplist (SCM ls)
-{
-  SCM orig = ls;
-  while (!scm_is_null (ls))
-    {
-      if (!scm_is_pair (ls))
-        scm_misc_error ("%compute-slots", "malformed ls argument in "
-                        "maplist", SCM_EOL);
-      if (!scm_is_pair (SCM_CAR (ls)))
-        SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
-      ls = SCM_CDR (ls);
-    }
-  return orig;
-}
-
-
-SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
-           (SCM class),
-           "Return a list consisting of the names of all slots belonging to\n"
-           "class @var{class}, i. e. the slots of @var{class} and of all of\n"
-           "its superclasses.")
-#define FUNC_NAME s_scm_sys_compute_slots
-{
-  SCM_VALIDATE_CLASS (1, class);
-  return build_slots_list (SCM_SLOT (class, scm_si_direct_slots),
-                          SCM_SLOT (class, scm_si_cpl));
-}
-#undef FUNC_NAME
-
-
-/******************************************************************************
- *
- * compute-getters-n-setters
- *
- *   This version doesn't handle slot options. It serves only for booting
- * classes and will be overloaded in Scheme.
- *
- 
******************************************************************************/
-
-SCM_KEYWORD (k_init_value, "init-value");
-SCM_KEYWORD (k_init_thunk, "init-thunk");
-
-static SCM
-compute_getters_n_setters (SCM slots)
-{
-  SCM res = SCM_EOL;
-  SCM *cdrloc = &res;
-  long i   = 0;
-
-  for (  ; !scm_is_null (slots); slots = SCM_CDR (slots))
-    {
-      SCM init = SCM_BOOL_F;
-      SCM options = SCM_CDAR (slots);
-      if (!scm_is_null (options))
-       {
-         init = scm_get_keyword (k_init_value, options, SCM_PACK (0));
-         if (SCM_UNPACK (init))
-            {
-              init = scm_primitive_eval (scm_list_3 (scm_sym_lambda,
-                                                     SCM_EOL,
-                                                     scm_list_2 (scm_sym_quote,
-                                                                 init)));
-            }
-         else
-           init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
-       }
-      *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots),
-                                   scm_cons (init,
-                                             scm_from_int (i++))),
-                         SCM_EOL);
-      cdrloc = SCM_CDRLOC (*cdrloc);
-    }
-  return res;
-}
-
-/******************************************************************************
- *
  * initialize-object
  *
  
******************************************************************************/
@@ -627,122 +473,16 @@ SCM_DEFINE (scm_sys_initialize_object, 
"%initialize-object", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-/* NOTE: The following macros are interdependent with code
- *       in goops.scm:compute-getters-n-setters
- */
-#define SCM_GNS_INSTANCE_ALLOCATED_P(gns)      \
-  (SCM_I_INUMP (SCM_CDDR (gns))                        \
-   || (scm_is_pair (SCM_CDDR (gns))            \
-       && scm_is_pair (SCM_CDDDR (gns))                \
-       && scm_is_pair (SCM_CDDDDR (gns))))
-#define SCM_GNS_INDEX(gns)                     \
-  (SCM_I_INUMP (SCM_CDDR (gns))                        \
-   ? SCM_I_INUM (SCM_CDDR (gns))               \
-   : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
-#define SCM_GNS_SIZE(gns)                      \
-  (SCM_I_INUMP (SCM_CDDR (gns))                        \
-   ? 1                                         \
-   : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
-
-SCM_KEYWORD (k_class, "class");
-SCM_KEYWORD (k_allocation, "allocation");
-SCM_KEYWORD (k_instance, "instance");
-
-SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
-           (SCM class),
+SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
+           (SCM class, SCM layout),
            "")
-#define FUNC_NAME s_scm_sys_prep_layout_x
+#define FUNC_NAME s_scm_sys_init_layout_x
 {
-  SCM slots, getters_n_setters, nfields;
-  unsigned long int n, i;
-  char *s;
-  SCM layout;
-
   SCM_VALIDATE_INSTANCE (1, class);
-  slots = SCM_SLOT (class, scm_si_slots);
-  getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
-  nfields = SCM_SLOT (class, scm_si_nfields);
-  if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0)
-    SCM_MISC_ERROR ("bad value in nfields slot: ~S",
-                   scm_list_1 (nfields));
-  n = 2 * SCM_I_INUM (nfields);
-  if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1
-      && SCM_SUBCLASSP (class, scm_class_class))
-    SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
-                   scm_list_1 (nfields));
-
-  layout = scm_i_make_string (n, &s, 0);
-  i = 0;
-  while (scm_is_pair (getters_n_setters))
-    {
-      if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
-       {
-         SCM type;
-         int len, index, size;
-         char p, a;
-
-         if (i >= n || !scm_is_pair (slots))
-           goto inconsistent;
-         
-         /* extract slot type */
-         len = scm_ilength (SCM_CDAR (slots));
-         type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
-                                   len, SCM_BOOL_F, FUNC_NAME);
-         /* determine slot GC protection and access mode */
-         if (scm_is_false (type))
-           {
-             p = 'p';
-             a = 'w';
-           }
-         else
-           {
-             if (!SCM_CLASSP (type))
-               SCM_MISC_ERROR ("bad slot class", SCM_EOL);
-             else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
-               {
-                 if (SCM_SUBCLASSP (type, scm_class_self))
-                   p = 's';
-                 else if (SCM_SUBCLASSP (type, scm_class_protected))
-                   p = 'p';
-                 else
-                   p = 'u';
-
-                 if (SCM_SUBCLASSP (type, scm_class_opaque))
-                   a = 'o';
-                 else if (SCM_SUBCLASSP (type, scm_class_read_only))
-                   a = 'r';
-                 else if (SCM_SUBCLASSP (type, scm_class_hidden))
-                   a = 'h';
-                 else
-                   a = 'w';
-               }
-             else
-               {
-                 p = 'p';
-                 a = 'w';
-               }
-           }
-      
-         index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
-         if (index != (i >> 1))
-           goto inconsistent;
-         size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
-         while (size)
-           {
-             s[i++] = p;
-             s[i++] = a;
-             --size;
-           }
-       }
-      slots = SCM_CDR (slots);
-      getters_n_setters = SCM_CDR (getters_n_setters);
-    }
-  if (!scm_is_null (slots))
-    {
-    inconsistent:
-      SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
-    }
-  SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout));
+  SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME);
+  SCM_VALIDATE_STRING (2, layout);
+
+  SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -776,174 +516,42 @@ prep_hashsets (SCM class)
 
/******************************************************************************/
 
 SCM
-scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
-{
-  SCM z, cpl, slots, nfields, g_n_s;
-
-  /* Allocate one instance */
-  z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
-
-  /* Initialize its slots */
-  SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
-  cpl   = scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), z);
-  slots = build_slots_list (maplist (dslots), cpl);
-  nfields = scm_from_int (scm_ilength (slots));
-  g_n_s = compute_getters_n_setters (slots);
-
-  SCM_SET_SLOT (z, scm_vtable_index_name, name);
-  SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
-  SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
-  SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
-  SCM_SET_SLOT (z, scm_si_cpl, cpl);
-  SCM_SET_SLOT (z, scm_si_slots, slots);
-  SCM_SET_SLOT (z, scm_si_nfields, nfields);
-  SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
-  SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
-
-  /* Add this class in the direct-subclasses slot of dsupers */
-  {
-    SCM tmp;
-    for (tmp = dsupers; !scm_is_null (tmp); tmp = SCM_CDR (tmp))
-      SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses,
-                   scm_cons (z, SCM_SLOT (SCM_CAR (tmp),
-                                          scm_si_direct_subclasses)));
-  }
-
-  return z;
-}
-
-SCM
 scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
 {
-  SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
-  scm_sys_prep_layout_x (z);
-  scm_sys_inherit_magic_x (z, dsupers);
-  return z;
+  return scm_call_4 (scm_variable_ref (var_make_standard_class),
+                     class, name, dsupers, dslots);
 }
 
 
/******************************************************************************/
 
-SCM_SYMBOL (sym_layout, "layout");
-SCM_SYMBOL (sym_flags, "flags");
-SCM_SYMBOL (sym_self, "%self");
-SCM_SYMBOL (sym_instance_finalizer, "instance-finalizer");
-SCM_SYMBOL (sym_reserved_0, "%reserved-0");
-SCM_SYMBOL (sym_reserved_1, "%reserved-1");
-SCM_SYMBOL (sym_print, "print");
-SCM_SYMBOL (sym_procedure, "procedure");
-SCM_SYMBOL (sym_setter, "setter");
-SCM_SYMBOL (sym_redefined, "redefined");
-SCM_SYMBOL (sym_h0, "h0");
-SCM_SYMBOL (sym_h1, "h1");
-SCM_SYMBOL (sym_h2, "h2");
-SCM_SYMBOL (sym_h3, "h3");
-SCM_SYMBOL (sym_h4, "h4");
-SCM_SYMBOL (sym_h5, "h5");
-SCM_SYMBOL (sym_h6, "h6");
-SCM_SYMBOL (sym_h7, "h7");
-SCM_SYMBOL (sym_name, "name");
-SCM_SYMBOL (sym_direct_supers, "direct-supers");
-SCM_SYMBOL (sym_direct_slots, "direct-slots");
-SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
-SCM_SYMBOL (sym_direct_methods, "direct-methods");
-SCM_SYMBOL (sym_cpl, "cpl");
-SCM_SYMBOL (sym_default_slot_definition_class, 
"default-slot-definition-class");
-SCM_SYMBOL (sym_slots, "slots");
-SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
-SCM_SYMBOL (sym_nfields, "nfields");
-
-
-static int specialized_slots_initialized = 0;
-
-static SCM
-build_class_class_slots (enum build_class_class_slots_mode mode)
-{
-#define SPECIALIZED_SLOT(name, class) \
-  (mode == BOOT_SLOTS ? scm_list_1 (name) : scm_list_3 (name, k_class, class))
-
-  if (mode == FINAL_SLOTS && !specialized_slots_initialized)
-    abort ();
-
-  /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
-     SCM_CLASS_CLASS_LAYOUT */
-  return scm_list_n (
-    SPECIALIZED_SLOT (sym_layout, scm_class_protected_read_only),
-    SPECIALIZED_SLOT (sym_flags, scm_class_hidden),
-    SPECIALIZED_SLOT (sym_self, scm_class_self),
-    SPECIALIZED_SLOT (sym_instance_finalizer, scm_class_hidden),
-    scm_list_1 (sym_print),
-    SPECIALIZED_SLOT (sym_name, scm_class_protected_hidden),
-    SPECIALIZED_SLOT (sym_reserved_0, scm_class_hidden),
-    SPECIALIZED_SLOT (sym_reserved_1, scm_class_hidden),
-    scm_list_1 (sym_redefined),
-    SPECIALIZED_SLOT (sym_h0, scm_class_int),
-    SPECIALIZED_SLOT (sym_h1, scm_class_int),
-    SPECIALIZED_SLOT (sym_h2, scm_class_int),
-    SPECIALIZED_SLOT (sym_h3, scm_class_int),
-    SPECIALIZED_SLOT (sym_h4, scm_class_int),
-    SPECIALIZED_SLOT (sym_h5, scm_class_int),
-    SPECIALIZED_SLOT (sym_h6, scm_class_int),
-    SPECIALIZED_SLOT (sym_h7, scm_class_int),
-    scm_list_1 (sym_direct_supers),
-    scm_list_1 (sym_direct_slots),
-    scm_list_1 (sym_direct_subclasses),
-    scm_list_1 (sym_direct_methods),
-    scm_list_1 (sym_cpl),
-    scm_list_1 (sym_default_slot_definition_class),
-    scm_list_1 (sym_slots),
-    scm_list_1 (sym_getters_n_setters),
-    scm_list_1 (sym_nfields),
-    SCM_UNDEFINED);
-}
-
-static void
-create_basic_classes (void)
+SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 3, 0, 0,
+           (SCM name, SCM dslots, SCM getters_n_setters),
+           "")
+#define FUNC_NAME s_scm_sys_make_root_class
 {
-  SCM slots_of_class = build_class_class_slots (BOOT_SLOTS);
-
-  /**** <class> ****/
-  SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
-  SCM name = scm_from_latin1_symbol ("<class>");
-  scm_class_class = scm_i_make_vtable_vtable (cs);
-  SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
-                                        | SCM_CLASSF_METACLASS));
-
-  SCM_SET_SLOT (scm_class_class, scm_vtable_index_name, name);
-  SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL);  /* will be 
changed */
-  SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); /* will 
be changed */
-  SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
-  SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
-  SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL);  /* will be changed */
-  SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); /* will be 
changed */
-  SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int 
(SCM_N_CLASS_SLOTS));
-  SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
-                compute_getters_n_setters (slots_of_class)); /* will be 
changed */
-  SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
-
-  prep_hashsets (scm_class_class);
-
-  scm_module_define (scm_module_goops, name, scm_class_class);
-
-  /**** <top> ****/
-  name = scm_from_latin1_symbol ("<top>");
-  scm_class_top = scm_basic_make_class (scm_class_class, name,
-                                        SCM_EOL, SCM_EOL);
-
-  scm_module_define (scm_module_goops, name, scm_class_top);
+  SCM cs, z;
 
-  /**** <object> ****/
-  name  = scm_from_latin1_symbol ("<object>");
-  scm_class_object = scm_basic_make_class (scm_class_class, name,
-                                           scm_list_1 (scm_class_top), 
SCM_EOL);
+  cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
+  z = scm_i_make_vtable_vtable (cs);
+  SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID
+                           | SCM_CLASSF_METACLASS));
 
-  scm_module_define (scm_module_goops, name, scm_class_object);
+  SCM_SET_SLOT (z, scm_vtable_index_name, name);
+  SCM_SET_SLOT (z, scm_si_direct_supers, SCM_EOL);  /* will be changed */
+  SCM_SET_SLOT (z, scm_si_direct_slots, dslots); /* will be changed */
+  SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
+  SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
+  SCM_SET_SLOT (z, scm_si_cpl, SCM_EOL);  /* will be changed */
+  SCM_SET_SLOT (z, scm_si_slots, dslots); /* will be changed */
+  SCM_SET_SLOT (z, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
+  SCM_SET_SLOT (z, scm_si_getters_n_setters, getters_n_setters); /* will be 
changed */
+  SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
 
-  /* <top> <object> and <class> were partially initialized. Correct them here 
*/
-  SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 
(scm_class_class));
+  prep_hashsets (z);
 
-  SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 
(scm_class_object));
-  SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, 
scm_class_object, scm_class_top));
+  return z;
 }
+#undef FUNC_NAME
 
 
/******************************************************************************/
 
@@ -962,13 +570,22 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
  * Meta object accessors
  *
  
******************************************************************************/
+
+SCM_SYMBOL (sym_procedure, "procedure");
+SCM_SYMBOL (sym_direct_supers, "direct-supers");
+SCM_SYMBOL (sym_direct_slots, "direct-slots");
+SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
+SCM_SYMBOL (sym_direct_methods, "direct-methods");
+SCM_SYMBOL (sym_cpl, "cpl");
+SCM_SYMBOL (sym_slots, "slots");
+
 SCM_DEFINE (scm_class_name, "class-name",  1, 0, 0,
            (SCM obj),
            "Return the class name of @var{obj}.")
 #define FUNC_NAME s_scm_class_name
 {
   SCM_VALIDATE_CLASS (1, obj);
-  return scm_slot_ref (obj, sym_name);
+  return scm_slot_ref (obj, scm_sym_name);
 }
 #undef FUNC_NAME
 
@@ -1955,206 +1572,6 @@ SCM_DEFINE (scm_make, "make",  0, 0, 1,
 #undef FUNC_NAME
 
 
-/******************************************************************************
- *
- * Initializations
- *
- 
******************************************************************************/
-
-static void
-make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
-{
-   SCM tmp = scm_from_utf8_symbol (name);
-
-   *var = scm_basic_make_class (meta, tmp,
-                                scm_is_pair (super) ? super : scm_list_1 
(super),
-                                slots);
-   scm_module_define (scm_module_goops, tmp, *var);
-}
-
-
-SCM_KEYWORD (k_slot_definition, "slot-definition");
-
-static void
-create_standard_classes (void)
-{
-  SCM slots;
-  SCM method_slots = scm_list_n (scm_from_latin1_symbol ("generic-function"),
-                                scm_from_latin1_symbol ("specializers"),
-                                sym_procedure,
-                                scm_from_latin1_symbol ("formals"),
-                                scm_from_latin1_symbol ("body"),
-                                scm_from_latin1_symbol ("make-procedure"),
-                                 SCM_UNDEFINED);
-  SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_latin1_symbol 
("slot-definition"),
-                                             k_init_keyword,
-                                             k_slot_definition));
-  SCM gf_slots = scm_list_4 (scm_from_latin1_symbol ("methods"),
-                            scm_list_3 (scm_from_latin1_symbol 
("n-specialized"),
-                                        k_init_value,
-                                        SCM_INUM0),
-                            scm_list_3 (scm_from_latin1_symbol ("extended-by"),
-                                        k_init_value,
-                                        SCM_EOL),
-                             scm_from_latin1_symbol ("effective-methods"));
-  SCM setter_slots = scm_list_1 (sym_setter);
-  SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
-                                         k_init_value,
-                                         SCM_EOL));
-  /* Foreign class slot classes */
-  make_stdcls (&scm_class_foreign_slot,           "<foreign-slot>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_protected,      "<protected-slot>",
-              scm_class_class, scm_class_foreign_slot,    SCM_EOL);
-  make_stdcls (&scm_class_hidden,         "<hidden-slot>",
-              scm_class_class, scm_class_foreign_slot,    SCM_EOL);
-  make_stdcls (&scm_class_opaque,         "<opaque-slot>",
-              scm_class_class, scm_class_foreign_slot,    SCM_EOL);
-  make_stdcls (&scm_class_read_only,      "<read-only-slot>",
-              scm_class_class, scm_class_foreign_slot,    SCM_EOL);
-  make_stdcls (&scm_class_self,                   "<self-slot>",
-              scm_class_class, scm_class_read_only,       SCM_EOL);
-  make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
-              scm_class_class,
-              scm_list_2 (scm_class_protected, scm_class_opaque),
-              SCM_EOL);
-  make_stdcls (&scm_class_protected_hidden, "<protected-hidden-slot>",
-              scm_class_class,
-              scm_list_2 (scm_class_protected, scm_class_hidden),
-              SCM_EOL);
-  make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
-              scm_class_class,
-              scm_list_2 (scm_class_protected, scm_class_read_only),
-              SCM_EOL);
-  make_stdcls (&scm_class_scm,            "<scm-slot>",
-              scm_class_class, scm_class_protected, SCM_EOL);
-  make_stdcls (&scm_class_int,            "<int-slot>",
-              scm_class_class, scm_class_foreign_slot,    SCM_EOL);
-  make_stdcls (&scm_class_float,          "<float-slot>",
-              scm_class_class, scm_class_foreign_slot,    SCM_EOL);
-  make_stdcls (&scm_class_double,         "<double-slot>",
-              scm_class_class, scm_class_foreign_slot,    SCM_EOL);
-
-  specialized_slots_initialized = 1;
-
-  /* Finish initialization of class <class> */
-
-  slots = build_class_class_slots (FINAL_SLOTS);
-  SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
-  SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
-  SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
-               compute_getters_n_setters (slots));
-
-  /* scm_class_generic functions classes */
-  make_stdcls (&scm_class_procedure_class, "<procedure-class>",
-              scm_class_class, scm_class_class, SCM_EOL);
-  make_stdcls (&scm_class_applicable_struct_class,    
"<applicable-struct-class>",
-              scm_class_class, scm_class_procedure_class, SCM_EOL);
-  SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class, 
SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
-  make_stdcls (&scm_class_method,         "<method>",
-              scm_class_class, scm_class_object,          method_slots);
-  make_stdcls (&scm_class_accessor_method, "<accessor-method>",
-              scm_class_class, scm_class_method,   amethod_slots);
-  make_stdcls (&scm_class_applicable,     "<applicable>",
-              scm_class_class, scm_class_top, SCM_EOL);
-  make_stdcls (&scm_class_applicable_struct,      "<applicable-struct>",
-              scm_class_applicable_struct_class,
-              scm_list_2 (scm_class_object, scm_class_applicable),
-              scm_list_1 (sym_procedure));
-  make_stdcls (&scm_class_generic,        "<generic>",
-              scm_class_applicable_struct_class, scm_class_applicable_struct,  
 gf_slots);
-  SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
-  make_stdcls (&scm_class_extended_generic, "<extended-generic>",
-              scm_class_applicable_struct_class, scm_class_generic, egf_slots);
-  SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
-  make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
-              scm_class_applicable_struct_class, scm_class_generic, 
setter_slots);
-  SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
-  make_stdcls (&scm_class_accessor,       "<accessor>",
-              scm_class_applicable_struct_class, 
scm_class_generic_with_setter, SCM_EOL);
-  SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
-  make_stdcls (&scm_class_extended_generic_with_setter,
-              "<extended-generic-with-setter>",
-              scm_class_applicable_struct_class,
-              scm_list_2 (scm_class_extended_generic,
-                           scm_class_generic_with_setter),
-              SCM_EOL);
-  SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
-                      SCM_CLASSF_PURE_GENERIC);
-  make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
-              scm_class_applicable_struct_class,
-              scm_list_2 (scm_class_accessor,
-                          scm_class_extended_generic_with_setter),
-              SCM_EOL);
-  SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
-
-  /* Primitive types classes */
-  make_stdcls (&scm_class_boolean,        "<boolean>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_char,                   "<char>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_list,                   "<list>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_pair,                   "<pair>",
-              scm_class_class, scm_class_list,            SCM_EOL);
-  make_stdcls (&scm_class_null,                   "<null>",
-              scm_class_class, scm_class_list,            SCM_EOL);
-  make_stdcls (&scm_class_string,         "<string>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_symbol,         "<symbol>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_vector,         "<vector>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_foreign,            "<foreign>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_hashtable,          "<hashtable>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_fluid,              "<fluid>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_dynamic_state,      "<dynamic-state>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_frame,              "<frame>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_vm_cont,            "<vm-continuation>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_bytevector,         "<bytevector>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_uvec,               "<uvec>",
-              scm_class_class, class_bytevector,          SCM_EOL);
-  make_stdcls (&class_array,              "<array>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&class_bitvector,           "<bitvector>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_number,         "<number>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_complex,        "<complex>",
-              scm_class_class, scm_class_number,          SCM_EOL);
-  make_stdcls (&scm_class_real,                   "<real>",
-              scm_class_class, scm_class_complex,         SCM_EOL);
-  make_stdcls (&scm_class_integer,        "<integer>",
-              scm_class_class, scm_class_real,            SCM_EOL);
-  make_stdcls (&scm_class_fraction,       "<fraction>",
-              scm_class_class, scm_class_real,            SCM_EOL);
-  make_stdcls (&scm_class_keyword,        "<keyword>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_unknown,        "<unknown>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_procedure,      "<procedure>",
-              scm_class_procedure_class, scm_class_applicable, SCM_EOL);
-  make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
-              scm_class_procedure_class, scm_class_procedure, SCM_EOL);
-  make_stdcls (&scm_class_port,                   "<port>",
-              scm_class_class, scm_class_top,             SCM_EOL);
-  make_stdcls (&scm_class_input_port,     "<input-port>",
-              scm_class_class, scm_class_port,            SCM_EOL);
-  make_stdcls (&scm_class_output_port,    "<output-port>",
-              scm_class_class, scm_class_port,            SCM_EOL);
-  make_stdcls (&scm_class_input_output_port, "<input-output-port>",
-              scm_class_class,
-              scm_list_2 (scm_class_input_port, scm_class_output_port),
-              SCM_EOL);
-}
-
 /**********************************************************************
  *
  * Smob classes
@@ -2164,7 +1581,8 @@ create_standard_classes (void)
 static SCM
 make_class_from_template (char const *template, char const *type_name, SCM 
supers, int applicablep)
 {
-  SCM name;
+  SCM meta, name;
+
   if (type_name)
     {
       char buffer[100];
@@ -2174,14 +1592,15 @@ make_class_from_template (char const *template, char 
const *type_name, SCM super
   else
     name = SCM_GOOPS_UNBOUND;
 
-  return scm_basic_make_class (applicablep ? scm_class_procedure_class : 
scm_class_class,
-                               name, supers, SCM_EOL);
+  meta = applicablep ? scm_class_procedure_class : scm_class_class;
+
+  return scm_basic_make_class (meta, name, supers, SCM_EOL);
 }
 
 static SCM
 make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
 {
-  SCM name;
+  SCM meta, name;
 
   if (scm_is_true (type_name_sym))
     {
@@ -2193,8 +1612,9 @@ make_class_from_symbol (SCM type_name_sym, SCM supers, 
int applicablep)
   else
     name = SCM_GOOPS_UNBOUND;
 
-  return scm_basic_make_class (applicablep ? scm_class_procedure_class : 
scm_class_class,
-                               name, supers, SCM_EOL);
+  meta = applicablep ? scm_class_procedure_class : scm_class_class;
+
+  return scm_basic_make_class (meta, name, supers, SCM_EOL);
 }
 
 SCM
@@ -2335,12 +1755,6 @@ scm_load_goops ()
 }
 
 
-SCM_SYMBOL (sym_o, "o");
-SCM_SYMBOL (sym_x, "x");
-
-SCM_KEYWORD (k_accessor, "accessor");
-SCM_KEYWORD (k_getter, "getter");
-
 SCM
 scm_ensure_accessor (SCM name)
 {
@@ -2382,13 +1796,101 @@ SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 
0,
  * Initialization
  */
 
+SCM_DEFINE (scm_sys_bless_applicable_struct_vtable_x, 
"%bless-applicable-struct-vtable!", 1, 0, 0,
+           (SCM vtable),
+           "")
+#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtable_x
+{
+  SCM_VALIDATE_CLASS (1, vtable);
+  SCM_SET_VTABLE_FLAGS (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_bless_pure_generic_vtable_x, 
"%bless-pure-generic-vtable!", 1, 0, 0,
+           (SCM vtable),
+           "")
+#define FUNC_NAME s_scm_sys_bless_pure_generic_vtable_x
+{
+  SCM_VALIDATE_CLASS (1, vtable);
+  SCM_SET_CLASS_FLAGS (vtable, SCM_CLASSF_PURE_GENERIC);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
            (),
            "")
 #define FUNC_NAME s_scm_sys_goops_early_init
 {
-  create_basic_classes ();
-  create_standard_classes ();
+  var_make_standard_class = scm_c_lookup ("make-standard-class");
+
+  scm_class_class = scm_variable_ref (scm_c_lookup ("<class>"));
+  scm_class_top = scm_variable_ref (scm_c_lookup ("<top>"));
+  scm_class_object = scm_variable_ref (scm_c_lookup ("<object>"));
+
+  scm_class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
+  scm_class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
+  scm_class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
+  scm_class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
+  scm_class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
+  scm_class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
+  scm_class_protected_opaque = scm_variable_ref (scm_c_lookup 
("<protected-opaque-slot>"));
+  scm_class_protected_hidden = scm_variable_ref (scm_c_lookup 
("<protected-hidden-slot>"));
+  scm_class_protected_read_only = scm_variable_ref (scm_c_lookup 
("<protected-read-only-slot>"));
+  scm_class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
+  scm_class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
+  scm_class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
+  scm_class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
+
+  /* scm_class_generic functions classes */
+  scm_class_procedure_class = scm_variable_ref (scm_c_lookup 
("<procedure-class>"));
+  scm_class_applicable_struct_class = scm_variable_ref (scm_c_lookup 
("<applicable-struct-class>"));
+
+  scm_class_method = scm_variable_ref (scm_c_lookup ("<method>"));
+  scm_class_accessor_method = scm_variable_ref (scm_c_lookup 
("<accessor-method>"));
+  scm_class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
+  scm_class_applicable_struct = scm_variable_ref (scm_c_lookup 
("<applicable-struct>"));
+  scm_class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
+  scm_class_extended_generic = scm_variable_ref (scm_c_lookup 
("<extended-generic>"));
+  scm_class_generic_with_setter = scm_variable_ref (scm_c_lookup 
("<generic-with-setter>"));
+  scm_class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
+  scm_class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup 
("<extended-generic-with-setter>"));
+  scm_class_extended_accessor = scm_variable_ref (scm_c_lookup 
("<extended-accessor>"));
+
+  /* Primitive types classes */
+  scm_class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
+  scm_class_char = scm_variable_ref (scm_c_lookup ("<char>"));
+  scm_class_list = scm_variable_ref (scm_c_lookup ("<list>"));
+  scm_class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
+  scm_class_null = scm_variable_ref (scm_c_lookup ("<null>"));
+  scm_class_string = scm_variable_ref (scm_c_lookup ("<string>"));
+  scm_class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
+  scm_class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
+  class_foreign = scm_variable_ref (scm_c_lookup ("<foreign>"));
+  class_hashtable = scm_variable_ref (scm_c_lookup ("<hashtable>"));
+  class_fluid = scm_variable_ref (scm_c_lookup ("<fluid>"));
+  class_dynamic_state = scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
+  class_frame = scm_variable_ref (scm_c_lookup ("<frame>"));
+  class_vm_cont = scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
+  class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
+  class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
+  class_array = scm_variable_ref (scm_c_lookup ("<array>"));
+  class_bitvector = scm_variable_ref (scm_c_lookup ("<bitvector>"));
+  scm_class_number = scm_variable_ref (scm_c_lookup ("<number>"));
+  scm_class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
+  scm_class_real = scm_variable_ref (scm_c_lookup ("<real>"));
+  scm_class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
+  scm_class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
+  scm_class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
+  scm_class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
+  scm_class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
+  scm_class_primitive_generic = scm_variable_ref (scm_c_lookup 
("<primitive-generic>"));
+  scm_class_port = scm_variable_ref (scm_c_lookup ("<port>"));
+  scm_class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
+  scm_class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
+  scm_class_input_output_port = scm_variable_ref (scm_c_lookup 
("<input-output-port>"));
+
   create_smob_classes ();
   create_struct_classes ();
   create_port_classes ();
@@ -2437,9 +1939,6 @@ scm_init_goops_builtins (void *unused)
   hell_mutex = scm_make_mutex ();
 
 #include "libguile/goops.x"
-
-  var_compute_cpl =
-    scm_module_variable (scm_module_goops, sym_compute_cpl);
 }
 
 void
diff --git a/libguile/goops.h b/libguile/goops.h
index b5f88be..a9b9921 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -3,7 +3,7 @@
 #ifndef SCM_GOOPS_H
 #define SCM_GOOPS_H
 
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011 Free 
Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011, 2015 
Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -235,7 +235,6 @@ 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_API SCM scm_basic_basic_make_class (SCM c, SCM name, SCM dsupers, SCM 
dslots);
 SCM_API SCM scm_basic_make_class (SCM c, SCM name, SCM dsupers, SCM dslots);
 
 /* Primitives exported */
@@ -248,13 +247,11 @@ SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM 
value);
 SCM_API SCM scm_pure_generic_p (SCM obj);
 #endif
 
-SCM_API SCM scm_sys_compute_slots (SCM c);
 SCM_INTERNAL void scm_i_inherit_applicable (SCM c);
 SCM_INTERNAL SCM scm_i_get_keyword (SCM key, SCM l, long len,
                                    SCM default_value, const char *subr);
 SCM_API SCM scm_get_keyword (SCM key, SCM l, SCM default_value);
 SCM_API SCM scm_sys_initialize_object (SCM obj, SCM initargs);
-SCM_API SCM scm_sys_prep_layout_x (SCM c);
 SCM_API SCM scm_sys_inherit_magic_x (SCM c, SCM dsupers);
 SCM_API SCM scm_instance_p (SCM obj);
 SCM_API SCM scm_class_name (SCM obj);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index efa9f03..79b8579 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -26,6 +26,7 @@
 
 (define-module (oop goops)
   #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
   #:export-syntax (define-class class standard-define-class
                     define-generic define-accessor define-method
                     define-extended-generic define-extended-generics
@@ -207,6 +208,315 @@
   (use-modules ((language tree-il primitives) :select 
(add-interesting-primitive!)))
   (add-interesting-primitive! 'class-of))
 
+;; During boot, the specialized slot classes aren't defined yet, so we
+;; initialize <class> with unspecialized slots.
+(define-syntax-rule (build-<class>-slots specialized?)
+  (let-syntax ((unspecialized-slot (syntax-rules ()
+                                     ((_ name) (list 'name))))
+               (specialized-slot (syntax-rules ()
+                                   ((_ name class)
+                                    (if specialized?
+                                        (list 'name #:class class)
+                                        (list 'name))))))
+    (list (specialized-slot layout <protected-read-only-slot>)
+          (specialized-slot flags <hidden-slot>)
+          (specialized-slot self <self-slot>)
+          (specialized-slot instance-finalizer <hidden-slot>)
+          (unspecialized-slot print)
+          (specialized-slot name <protected-hidden-slot>)
+          (specialized-slot reserved-0 <hidden-slot>)
+          (specialized-slot reserved-1 <hidden-slot>)
+          (unspecialized-slot redefined)
+          (specialized-slot h0 <int-slot>)
+          (specialized-slot h1 <int-slot>)
+          (specialized-slot h2 <int-slot>)
+          (specialized-slot h3 <int-slot>)
+          (specialized-slot h4 <int-slot>)
+          (specialized-slot h5 <int-slot>)
+          (specialized-slot h6 <int-slot>)
+          (specialized-slot h7 <int-slot>)
+          (unspecialized-slot direct-supers)
+          (unspecialized-slot direct-slots)
+          (unspecialized-slot direct-subclasses)
+          (unspecialized-slot direct-methods)
+          (unspecialized-slot cpl)
+          (unspecialized-slot default-slot-definition-class)
+          (unspecialized-slot slots)
+          (unspecialized-slot getters-n-setters)
+          (unspecialized-slot nfields))))
+
+(eval-when (compile load eval)
+  (define (build-slots-list dslots cpl)
+    (define (check-cpl slots class-slots)
+      (when (or-map (lambda (slot-def) (assq (car slot-def) slots))
+                    class-slots)
+        (scm-error 'misc-error #f
+                   "a predefined <class> inherited field cannot be redefined"
+                   '() '())))
+    (define (remove-duplicate-slots slots)
+      (let lp ((slots (reverse slots)) (res '()) (seen '()))
+        (cond
+         ((null? slots) res)
+         ((memq (caar slots) seen)
+          (lp (cdr slots) res seen))
+         (else
+          (lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen))))))
+    (let* ((class-slots (and (memq <class> cpl) (slot-ref <class> 'slots))))
+      (when class-slots
+        (check-cpl dslots class-slots))
+      (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
+        (if (null? cpl)
+            (remove-duplicate-slots (append class-slots res))
+            (let* ((head (car cpl))
+                   (cpl (cdr cpl))
+                   (new-slots (slot-ref head '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.
+                (lp cpl res new-slots))
+               (else
+                (check-cpl new-slots class-slots)
+                (lp cpl (append new-slots res) class-slots))))))))
+
+  (define (%compute-getters-n-setters slots)
+    (define (compute-init-thunk options)
+      (cond
+       ((kw-arg-ref options #:init-value) => (lambda (val) (lambda () val)))
+       ((kw-arg-ref options #:init-thunk))
+       (else #f)))
+    (let lp ((slots slots) (n 0))
+      (match slots
+        (() '())
+        (((name . options) . slots)
+         (cons (cons name (cons (compute-init-thunk options) n))
+               (lp slots (1+ n)))))))
+
+  (define (%compute-layout slots getters-n-setters nfields is-class?)
+    (define (instance-allocated? g-n-s)
+      (match g-n-s
+        ((name init-thunk . (? exact-integer? index)) #t)
+        ((name init-thunk getter setter index size) #t)
+        (_ #f)))
+
+    (define (allocated-index g-n-s)
+      (match g-n-s
+        ((name init-thunk . (? exact-integer? index)) index)
+        ((name init-thunk getter setter index size) index)))
+
+    (define (allocated-size g-n-s)
+      (match g-n-s
+        ((name init-thunk . (? exact-integer? index)) 1)
+        ((name init-thunk getter setter index size) size)))
+
+    (define (slot-protection-and-kind options)
+      (define (subclass? class parent)
+        (memq parent (class-precedence-list class)))
+      (let ((type (kw-arg-ref options #:class)))
+        (if (and type (subclass? type <foreign-slot>))
+            (values (cond
+                     ((subclass? type <self-slot>) #\s)
+                     ((subclass? type <protected-slot>) #\p)
+                     (else #\u))
+                    (cond
+                     ((subclass? type <opaque-slot>) #\o)
+                     ((subclass? type <read-only-slot>) #\r)
+                     ((subclass? type <hidden-slot>) #\h)
+                     (else #\w)))
+            (values #\p #\w))))
+
+    (let ((layout (make-string (* nfields 2))))
+      (let lp ((n 0) (slots slots) (getters-n-setters getters-n-setters))
+        (match getters-n-setters
+          (()
+           (unless (= n nfields) (error "bad nfields"))
+           (unless (null? slots) (error "inconsistent g-n-s/slots"))
+           (when is-class?
+             (let ((class-layout (symbol->string (slot-ref <class> 'layout))))
+               (unless (string-prefix? class-layout layout)
+                 (error "bad layout for class"))))
+           layout)
+          ((g-n-s . getters-n-setters)
+           (match slots
+             (((name . options) . slots)
+              (cond
+               ((instance-allocated? g-n-s)
+                (unless (< n nfields) (error "bad nfields"))
+                (unless (= n (allocated-index g-n-s)) (error "bad allocation"))
+                (call-with-values (lambda () (slot-protection-and-kind 
options))
+                  (lambda (protection kind)
+                    (let init ((n n) (size (allocated-size g-n-s)))
+                      (cond
+                       ((zero? size) (lp n slots getters-n-setters))
+                       (else
+                        (string-set! layout (* n 2) protection)
+                        (string-set! layout (1+ (* n 2)) kind)
+                        (init (1+ n) (1- size))))))))
+               (else
+                (lp n slots getters-n-setters))))))))))
+
+  (define (%prep-layout! class)
+    (let* ((is-class? (and (memq <class> (slot-ref class 'cpl)) #t))
+           (layout (%compute-layout (slot-ref class 'slots)
+                                    (slot-ref class 'getters-n-setters)
+                                    (slot-ref class 'nfields)
+                                    is-class?)))
+      (%init-layout! class layout)))
+
+  (define (make-standard-class class name dsupers dslots)
+    (let ((z (make-struct/no-tail class)))
+      (slot-set! z 'direct-supers dsupers)
+      (let* ((cpl (compute-cpl z))
+             (dslots (map (lambda (slot)
+                            (if (pair? slot) slot (list slot)))
+                          dslots))
+             (slots (build-slots-list dslots cpl))
+             (nfields (length slots))
+             (g-n-s (%compute-getters-n-setters slots)))
+        (slot-set! z 'name name)
+        (slot-set! z 'direct-slots dslots)
+        (slot-set! z 'direct-subclasses '())
+        (slot-set! z 'direct-methods '())
+        (slot-set! z 'cpl cpl)
+        (slot-set! z 'slots slots)
+        (slot-set! z 'nfields nfields)
+        (slot-set! z 'getters-n-setters g-n-s)
+        (slot-set! z 'redefined #f)
+        (for-each (lambda (super)
+                    (let ((subclasses (slot-ref super 'direct-subclasses)))
+                      (slot-set! super 'direct-subclasses (cons z 
subclasses))))
+                  dsupers)
+        (%prep-layout! z)
+        (%inherit-magic! z dsupers)
+        z)))
+
+  (define <class>
+    (let ((dslots (build-<class>-slots #f)))
+      (%make-root-class '<class> dslots (%compute-getters-n-setters dslots))))
+
+  (define-syntax define-standard-class
+    (syntax-rules ()
+      ((define-standard-class name (super ...) #:metaclass meta slot ...)
+       (define name
+         (make-standard-class meta 'name (list super ...) '(slot ...))))
+      ((define-standard-class name (super ...) slot ...)
+       (define-standard-class name (super ...) #:metaclass <class> slot ...))))
+
+  (define-standard-class <top> ())
+  (define-standard-class <object> (<top>))
+
+  ;; <top>, <object>, and <class> were partially initialized.  Correct
+  ;; them here.
+  (slot-set! <object> 'direct-subclasses (list <class>))
+  (slot-set! <class> 'direct-supers (list <object>))
+  (slot-set! <class> 'cpl (list <class> <object> <top>))
+
+  (define-standard-class <foreign-slot> (<top>))
+  (define-standard-class <protected-slot> (<foreign-slot>))
+  (define-standard-class <hidden-slot> (<foreign-slot>))
+  (define-standard-class <opaque-slot> (<foreign-slot>))
+  (define-standard-class <read-only-slot> (<foreign-slot>))
+  (define-standard-class <self-slot> (<read-only-slot>))
+  (define-standard-class <protected-opaque-slot> (<protected-slot>
+                                                  <opaque-slot>))
+  (define-standard-class <protected-hidden-slot> (<protected-slot>
+                                                  <hidden-slot>))
+  (define-standard-class <protected-read-only-slot> (<protected-slot>
+                                                     <read-only-slot>))
+  (define-standard-class <scm-slot> (<protected-slot>))
+  (define-standard-class <int-slot> (<foreign-slot>))
+  (define-standard-class <float-slot> (<foreign-slot>))
+  (define-standard-class <double-slot> (<foreign-slot>))
+
+  ;; Finish initialization of <class>.
+  (let ((dslots (build-<class>-slots #t)))
+    (slot-set! <class> 'direct-slots dslots)
+    (slot-set! <class> 'slots dslots)
+    (slot-set! <class> 'getters-n-setters (%compute-getters-n-setters dslots)))
+
+  ;; Applicables and their classes.
+  (define-standard-class <procedure-class> (<class>))
+  (define-standard-class <applicable-struct-class> (<procedure-class>))
+  (%bless-applicable-struct-vtable! <applicable-struct-class>)
+  (define-standard-class <method> (<object>)
+    generic-function
+    specializers
+    procedure
+    formals
+    body
+    make-procedure)
+  (define-standard-class <accessor-method> (<method>)
+    (slot-definition #:init-keyword #:slot-definition))
+  (define-standard-class <applicable> (<top>))
+  (define-standard-class <applicable-struct> (<object> <applicable>)
+    #:metaclass <applicable-struct-class>
+    procedure)
+  (define-standard-class <generic> (<applicable-struct>)
+    #:metaclass <applicable-struct-class>
+    methods
+    (n-specialized #:init-value 0)
+    (extended-by #:init-value ())
+    effective-methods)
+  (%bless-pure-generic-vtable! <generic>)
+  (define-standard-class <extended-generic> (<generic>)
+    #:metaclass <applicable-struct-class>
+    (extends #:init-value ()))
+  (%bless-pure-generic-vtable! <extended-generic>)
+  (define-standard-class <generic-with-setter> (<generic>)
+    #:metaclass <applicable-struct-class>
+    setter)
+  (%bless-pure-generic-vtable! <generic-with-setter>)
+  (define-standard-class <accessor> (<generic-with-setter>)
+    #:metaclass <applicable-struct-class>)
+  (%bless-pure-generic-vtable! <accessor>)
+  (define-standard-class <extended-generic-with-setter> (<extended-generic>
+                                                         <generic-with-setter>)
+    #:metaclass <applicable-struct-class>)
+  (%bless-pure-generic-vtable! <extended-generic-with-setter>)
+  (define-standard-class <extended-accessor> (<accessor>
+                                              <extended-generic-with-setter>)
+    #:metaclass <applicable-struct-class>)
+  (%bless-pure-generic-vtable! <extended-accessor>)
+
+  ;; Primitive types classes
+  (define-standard-class <boolean> (<top>))
+  (define-standard-class <char> (<top>))
+  (define-standard-class <list> (<top>))
+  ;; Not all pairs are lists, but there is code out there that relies on
+  ;; (is-a? '(1 2 3) <list>) to work.  Terrible.  How to fix?
+  (define-standard-class <pair> (<list>))
+  (define-standard-class <null> (<list>))
+  (define-standard-class <string> (<top>))
+  (define-standard-class <symbol> (<top>))
+  (define-standard-class <vector> (<top>))
+  (define-standard-class <foreign> (<top>))
+  (define-standard-class <hashtable> (<top>))
+  (define-standard-class <fluid> (<top>))
+  (define-standard-class <dynamic-state> (<top>))
+  (define-standard-class <frame> (<top>))
+  (define-standard-class <vm-continuation> (<top>))
+  (define-standard-class <bytevector> (<top>))
+  (define-standard-class <uvec> (<bytevector>))
+  (define-standard-class <array> (<top>))
+  (define-standard-class <bitvector> (<top>))
+  (define-standard-class <number> (<top>))
+  (define-standard-class <complex> (<number>))
+  (define-standard-class <real> (<complex>))
+  (define-standard-class <integer> (<real>))
+  (define-standard-class <fraction> (<real>))
+  (define-standard-class <keyword> (<top>))
+  (define-standard-class <unknown> (<top>))
+  (define-standard-class <procedure> (<applicable>)
+    #:metaclass <procedure-class>)
+  (define-standard-class <primitive-generic> (<procedure>)
+    #:metaclass <procedure-class>)
+  (define-standard-class <port> (<top>))
+  (define-standard-class <input-port> (<port>))
+  (define-standard-class <output-port> (<port>))
+  (define-standard-class <input-output-port> (<input-port> <output-port>))
+  )
+
 (eval-when (compile load eval)
   (%goops-early-init))
 
@@ -1481,7 +1791,8 @@
   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
 
 (define-method (compute-slots (class <class>))
-  (%compute-slots class))
+  (build-slots-list (class-direct-slots class)
+                    (class-precedence-list class)))
 
 ;;;
 ;;; {Initialize}



reply via email to

[Prev in Thread] Current Thread [Next in Thread]