[Guile-commits] 24/61: Move <class> initialization to Scheme

[Andy Wingo]

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

commit 972e4e3aee7414744bf3406b44cda5ae2b8d304b
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 11 16:27:16 2015 +0100

    Move <class> initialization to Scheme
    
    * libguile/goops.c (scm_sys_make_root_class): Just make the
      vtable-vtable, and leave initialization to Scheme.
    
    * libguile/struct.c (scm_i_make_vtable_vtable): Change to take a full
      list of fields, not just the extra fields.
      (scm_init_struct): Adapt to scm_i_make_vtable_vtable change.
    
    * module/oop/goops.scm (<class>): Compute layout for <class>, and
      initialize <class> from here.
---
 libguile/goops.c     |   28 +++++++---------------------
 libguile/struct.c    |   15 +++++++--------
 libguile/struct.h    |    4 ++--
 module/oop/goops.scm |   38 ++++++++++++++++++++++++++++++++++----
 4 files changed, 50 insertions(+), 35 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 1ea7a94..37e3fd2 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -151,8 +151,7 @@ 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 name, SCM dslots,
-                                    SCM getters_n_setters);
+static SCM scm_sys_make_root_class (SCM layout);
 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);
@@ -317,28 +316,15 @@ scm_make_standard_class (SCM meta, SCM name, SCM dsupers, 
SCM dslots)
 
 
/******************************************************************************/
 
-SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 3, 0, 0,
-           (SCM name, SCM dslots, SCM getters_n_setters),
+SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0,
+            (SCM layout),
            "")
 #define FUNC_NAME s_scm_sys_make_root_class
 {
-  SCM cs, z;
-
-  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_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);
+  SCM z;
+
+  z = scm_i_make_vtable_vtable (layout);
+  SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS));
 
   return z;
 }
diff --git a/libguile/struct.c b/libguile/struct.c
index 1b61aa4..8bfbcf4 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
- *   2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *   2008, 2009, 2010, 2011, 2012, 2013, 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
@@ -597,20 +597,18 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
 #undef FUNC_NAME
 
 SCM
-scm_i_make_vtable_vtable (SCM user_fields)
+scm_i_make_vtable_vtable (SCM fields)
 #define FUNC_NAME "make-vtable-vtable"
 {
-  SCM fields, layout, obj;
+  SCM layout, obj;
   size_t basic_size;
   scm_t_bits v;
 
-  SCM_VALIDATE_STRING (1, user_fields);
+  SCM_VALIDATE_STRING (1, fields);
 
-  fields = scm_string_append (scm_list_2 (required_vtable_fields,
-                                         user_fields));
   layout = scm_make_struct_layout (fields);
   if (!scm_is_valid_vtable_layout (layout))
-    SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields));
+    SCM_MISC_ERROR ("invalid user fields", scm_list_1 (fields));
 
   basic_size = scm_i_symbol_length (layout) / 2;
 
@@ -997,7 +995,8 @@ scm_init_struct ()
   required_applicable_fields = scm_from_locale_string 
(SCM_APPLICABLE_BASE_LAYOUT);
   required_applicable_with_setter_fields = scm_from_locale_string 
(SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
 
-  scm_standard_vtable_vtable = scm_i_make_vtable_vtable (scm_nullstr);
+  scm_standard_vtable_vtable =
+    scm_i_make_vtable_vtable (required_vtable_fields);
   name = scm_from_utf8_symbol ("<standard-vtable>");
   scm_set_struct_vtable_name_x (scm_standard_vtable_vtable, name);
   scm_define (name, scm_standard_vtable_vtable);
diff --git a/libguile/struct.h b/libguile/struct.h
index f1f6c47..e8db316 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -3,7 +3,7 @@
 #ifndef SCM_STRUCT_H
 #define SCM_STRUCT_H
 
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 
2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 
2012, 2013, 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
@@ -181,7 +181,7 @@ SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, 
size_t n_inits,
 SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
                                 scm_t_bits init[]);
 SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
-SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM extra_fields);
+SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM fields);
 SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
 SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
 SCM_API SCM scm_struct_vtable (SCM handle);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index ed60d4c..9114e46 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -452,14 +452,44 @@
       z)))
 
 (define <class>
-  (let-syntax ((visit
+  (let-syntax ((cons-dslot
                 ;; The specialized slot classes have not been defined
                 ;; yet; initialize <class> with unspecialized slots.
                 (syntax-rules ()
                   ((_ (name) tail)       (cons (list 'name) tail))
-                  ((_ (name class) tail) (cons (list 'name) tail)))))
-    (let ((dslots (fold-<class>-slots macro-fold-right visit '())))
-      (%make-root-class '<class> dslots (%compute-getters-n-setters dslots)))))
+                  ((_ (name class) tail) (cons (list 'name) tail))))
+               (cons-layout
+                ;; A simple way to compute class layout for the concrete
+                ;; types used in <class>.
+                (syntax-rules (<protected-read-only-slot> <self-slot>
+                               <hidden-slot> <protected-hidden-slot>)
+                  ((_ (name) tail)
+                   (string-append "pw" tail))
+                  ((_ (name <protected-read-only-slot>) tail)
+                   (string-append "pr" tail))
+                  ((_ (name <self-slot>) tail)
+                   (string-append "sr" tail))
+                  ((_ (name <hidden-slot>) tail)
+                   (string-append "uh" tail))
+                  ((_ (name <protected-hidden-slot>) tail)
+                   (string-append "ph" tail)))))
+    (let* ((dslots (fold-<class>-slots macro-fold-right cons-dslot '()))
+           (layout (fold-<class>-slots macro-fold-right cons-layout ""))
+           (<class> (%make-root-class layout)))
+      ;; The `direct-supers', `direct-slots', `cpl', `slots', and
+      ;; `getters-n-setters' fields will be updated later.
+      (struct-set! <class> class-index-name '<class>)
+      (struct-set! <class> class-index-direct-supers '())
+      (struct-set! <class> class-index-direct-slots dslots)
+      (struct-set! <class> class-index-direct-subclasses '())
+      (struct-set! <class> class-index-direct-methods '())
+      (struct-set! <class> class-index-cpl '())
+      (struct-set! <class> class-index-slots dslots)
+      (struct-set! <class> class-index-nfields (length dslots))
+      (struct-set! <class> class-index-getters-n-setters
+                   (%compute-getters-n-setters dslots))
+      (struct-set! <class> class-index-redefined #f)
+      <class>)))
 
 (define-syntax define-standard-class
   (syntax-rules ()