[Guile-commits] 53/87: Incorporate %inherit-magic! into %init-layout!

[Andy Wingo]

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

commit 8225240e79424d210be9d8ed83ff038795ce39ae
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 11 22:01:47 2015 +0100

    Incorporate %inherit-magic! into %init-layout!
    
    * libguile/goops.c (scm_make_standard_class, scm_sys_init_layout_x):
      Move definitions up.  Incorporate scm_sys_inherit_magic_x into
      scm_sys_init_layout_x.
    
    * libguile/goops.h: Remove scm_sys_init_layout_x declaration.
---
 libguile/goops.c     |   63 +++++++++++++++++++++++---------------------------
 libguile/goops.h     |    1 -
 module/oop/goops.scm |   10 ++-----
 3 files changed, 32 insertions(+), 42 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 24f5220..190b7e8 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -163,6 +163,35 @@ static SCM scm_sys_goops_early_init (void);
 static SCM scm_sys_goops_loaded (void);
 
 
+
+
+SCM
+scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
+{
+  return scm_call_4 (scm_variable_ref (var_make_standard_class),
+                     meta, name, dsupers, dslots);
+}
+
+SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
+           (SCM class, SCM layout),
+           "")
+#define FUNC_NAME s_scm_sys_init_layout_x
+{
+  SCM_VALIDATE_INSTANCE (1, class);
+  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));
+  scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
+  SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+
 /* This function is used for efficient type dispatch.  */
 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
            (SCM x),
@@ -286,42 +315,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
-           (SCM class, SCM layout),
-           "")
-#define FUNC_NAME s_scm_sys_init_layout_x
-{
-  SCM_VALIDATE_INSTANCE (1, class);
-  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
-
-SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
-           (SCM class, SCM dsupers),
-           "")
-#define FUNC_NAME s_scm_sys_inherit_magic_x
-{
-  SCM_VALIDATE_INSTANCE (1, class);
-  scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
-  SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
-
-  return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
 
/******************************************************************************/
 
-SCM
-scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
-{
-  return scm_call_4 (scm_variable_ref (var_make_standard_class),
-                     meta, name, dsupers, dslots);
-}
-
 
/******************************************************************************/
 
 SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0,
diff --git a/libguile/goops.h b/libguile/goops.h
index fafd7fa..ca9c41b 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -102,7 +102,6 @@ SCM_API SCM scm_slot_ref (SCM obj, SCM slot_name);
 SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value);
 
 SCM_INTERNAL void scm_i_inherit_applicable (SCM c);
-SCM_API SCM scm_sys_inherit_magic_x (SCM c, SCM dsupers);
 SCM_API SCM scm_instance_p (SCM obj);
 SCM_API int scm_is_generic (SCM x);
 SCM_API int scm_is_method (SCM x);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 359f15d..77450ca 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -447,7 +447,6 @@
                                  (cons z subclasses))))
                 dsupers)
       (%prep-layout! z)
-      (%inherit-magic! z dsupers)
       z)))
 
 (define <class>
@@ -2470,12 +2469,9 @@ var{initargs}."
                                (cons class dsubs))))
               supers)
 
-    ;; Support for the underlying structs:
-
-    ;; Set the layout slot
-    (%prep-layout! class)
-    ;; Inherit class flags (invisible on scheme level) from supers
-    (%inherit-magic! class supers)))
+    ;; Compute struct layout of instances, set the `layout' slot, and
+    ;; update class flags.
+    (%prep-layout! class)))
 
 (define (initialize-object-procedure object initargs)
   (let ((proc (get-keyword #:procedure initargs #f)))