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

@@ -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,
+static SCM scm_sys_make_root_class (SCM layout);
-                                    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);
@@ -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_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0,
-	    (SCM name, SCM dslots, SCM getters_n_setters),
+            (SCM layout),
 	    "")
 #define FUNC_NAME s_scm_sys_make_root_class
 {
-  SCM cs, z;
+  SCM z;
 
-  cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
+  z = scm_i_make_vtable_vtable (layout);
-  z = scm_i_make_vtable_vtable (cs);
+  SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS));
-  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);
 
   return z;
 }

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);

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);

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)))))
+                  ((_ (name class) tail) (cons (list 'name) tail))))
-    (let ((dslots (fold-<class>-slots macro-fold-right visit '())))
+               (cons-layout
-      (%make-root-class '<class> dslots (%compute-getters-n-setters dslots)))))
+                ;; 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 ()