[Guile-commits] 25/88: Generics with setters have <applicable-struct-with-setter> layout

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 6c7dd9ebd3702c71adf5dcce9509294ebb52f226
Author: Andy Wingo <address@hidden>
Date:   Tue Jan 6 13:41:56 2015 -0500

    Generics with setters have <applicable-struct-with-setter> layout
    
    * libguile/goops.c (scm_sys_set_object_setter_x): Remove.  Instead, we
      use slot-set! of 'setter.
      (scm_i_define_class_for_vtable): Move lower in the file, and fold in
      scm_make_extended_class_from_symbol and make_class_from_symbol.
      Properly handle applicable structs with setters.
      (scm_class_applicable_struct_with_setter_class): New private capture.
      (scm_sys_bless_applicable_struct_vtables_x): Rename to take two
      arguments, and bless the second argument as an applicable struct with
      setter vtable.
      (scm_sys_goops_early_init): Capture setter classes.
    
    * libguile/deprecated.c (SPEC_OF, CPL_OF): Access slots by name, not by
      index.
      (applicablep, more_specificp): Adapt to use CPL_OF.
      (scm_find_method): Access "methods" slot by name.
    
    * libguile/procs.c (scm_setter): Remove special case for generics; if
      it's a setter, it will be a normal applicable struct.
    * module/oop/goops.scm (<applicable-struct-with-setter-class>)
      (<applicable-struct-with-setter>): New classes.
      (<generic-with-setter>): Now an instance of the setter metaclass and a
      child of the setter class, so that the "setter" slot ends up in the
      right place.
      (<accessor>, <extended-generic-with-setter>, <extended-accessor>): Be
      instances of the setter metaclass.
      (<method>, <accessor-method>): Move definitions farther down.
      (make): Use slot-set! when initializing setters here.
      (initialize): Likewise for <applicable-struct-with-setter>.  Remove
      specialization for <generic-with-setter>.
---
 libguile/deprecated.c |   12 ++--
 libguile/goops.c      |  166 ++++++++++++++++++++++---------------------------
 libguile/goops.h      |   14 ----
 libguile/procs.c      |    4 -
 module/oop/goops.scm  |   59 ++++++++++-------
 5 files changed, 117 insertions(+), 138 deletions(-)

diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index e0c32f7..33fa170 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -103,8 +103,10 @@ scm_init_deprecated_goops (void)
 }
 
 #define BUFFSIZE 32            /* big enough for most uses */
-#define scm_si_specializers     1  /* offset of spec. slot in a <method> */
-#define SPEC_OF(x)  SCM_SLOT (x, scm_si_specializers)
+#define SPEC_OF(x) \
+  (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers"))))
+#define CPL_OF(x) \
+  (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl"))))
 
 static SCM
 scm_i_vector2list (SCM l, long len)
@@ -122,7 +124,7 @@ static int
 applicablep (SCM actual, SCM formal)
 {
   /* We already know that the cpl is well formed. */
-  return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
+  return scm_is_true (scm_c_memq (formal, CPL_OF (actual)));
 }
 
 static int
@@ -152,7 +154,7 @@ more_specificp (SCM m1, SCM m2, SCM const *targs)
     if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
       register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
 
-      for (l = SCM_SLOT (targs[i], scm_si_cpl);   ; l = SCM_CDR(l)) {
+      for (l = CPL_OF (targs[i]);   ; l = SCM_CDR(l)) {
        if (scm_is_eq (cs1, SCM_CAR (l)))
          return 1;
        if (scm_is_eq (cs2, SCM_CAR (l)))
@@ -322,7 +324,7 @@ scm_find_method (SCM l)
 
   gf = SCM_CAR(l); l = SCM_CDR(l);
   SCM_VALIDATE_GENERIC (1, gf);
-  if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
+  if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods"))))
     SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
 
   return scm_compute_applicable_methods (gf, l, len - 1, 1);
diff --git a/libguile/goops.c b/libguile/goops.c
index ad0f04c..fd1fe2d 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -140,6 +140,7 @@ SCM scm_class_method;
 SCM scm_class_accessor_method;
 SCM scm_class_procedure_class;
 SCM scm_class_applicable_struct_class;
+static SCM scm_class_applicable_struct_with_setter_class;
 SCM scm_class_number, scm_class_list;
 SCM scm_class_keyword;
 SCM scm_class_port, scm_class_input_output_port;
@@ -176,55 +177,16 @@ 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_applicable_struct_vtables_x (SCM applicable,
+                                                      SCM setter);
 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, 
-                                               int applicablep);
 
 
-SCM
-scm_i_define_class_for_vtable (SCM vtable)
-{
-  SCM class;
-
-  scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
-  if (scm_is_false (vtable_class_map))
-    vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
-  scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
-  
-  if (scm_is_false (scm_struct_vtable_p (vtable)))
-    abort ();
-
-  class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
-
-  if (scm_is_false (class))
-    {
-      if (SCM_UNPACK (scm_class_class))
-        {
-          SCM name = SCM_VTABLE_NAME (vtable);
-          if (!scm_is_symbol (name))
-            name = scm_string_to_symbol (scm_nullstr);
-
-          class = scm_make_extended_class_from_symbol
-            (name, SCM_VTABLE_FLAG_IS_SET (vtable, 
SCM_VTABLE_FLAG_APPLICABLE));
-        }
-      else
-        /* `create_struct_classes' will fill this in later.  */
-        class = SCM_BOOL_F;
-
-      /* Don't worry about races.  This only happens when creating a
-         vtable, which happens by definition in one thread.  */
-      scm_weak_table_putq_x (vtable_class_map, vtable, class);
-    }
-
-  return class;
-}
-
 /* This function is used for efficient type dispatch.  */
 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
            (SCM x),
@@ -1053,21 +1015,6 @@ SCM_DEFINE (scm_sys_allocate_instance, 
"%allocate-instance", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
-           (SCM obj, SCM setter),
-           "")
-#define FUNC_NAME s_scm_sys_set_object_setter_x
-{
-  SCM_ASSERT (SCM_STRUCTP (obj)
-              && (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC),
-             obj,
-             SCM_ARG1,
-             FUNC_NAME);
-  SCM_SET_GENERIC_SETTER (obj, setter);
-  return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
 /******************************************************************************
  *
  * %modify-instance (used by change-class to modify in place)
@@ -1434,26 +1381,6 @@ make_class_from_template (char const *template, char 
const *type_name, SCM super
   return scm_make_standard_class (meta, name, supers, SCM_EOL);
 }
 
-static SCM
-make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
-{
-  SCM meta, name;
-
-  if (scm_is_true (type_name_sym))
-    {
-      name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
-                                           scm_symbol_to_string 
(type_name_sym),
-                                           scm_from_locale_string (">")));
-      name = scm_string_to_symbol (name);
-    }
-  else
-    name = SCM_GOOPS_UNBOUND;
-
-  meta = applicablep ? scm_class_procedure_class : scm_class_class;
-
-  return scm_make_standard_class (meta, name, supers, SCM_EOL);
-}
-
 SCM
 scm_make_extended_class (char const *type_name, int applicablep)
 {
@@ -1465,16 +1392,6 @@ scm_make_extended_class (char const *type_name, int 
applicablep)
                                   applicablep);
 }
 
-static SCM
-scm_make_extended_class_from_symbol (SCM type_name_sym, int applicablep)
-{
-  return make_class_from_symbol (type_name_sym,
-                                scm_list_1 (applicablep
-                                            ? scm_class_applicable
-                                            : scm_class_top),
-                                applicablep);
-}
-
 void
 scm_i_inherit_applicable (SCM c)
 {
@@ -1561,6 +1478,68 @@ create_port_classes (void)
     scm_make_port_classes (i, SCM_PTOBNAME (i));
 }
 
+SCM
+scm_i_define_class_for_vtable (SCM vtable)
+{
+  SCM class;
+
+  scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+  if (scm_is_false (vtable_class_map))
+    vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+  scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+  if (scm_is_false (scm_struct_vtable_p (vtable)))
+    abort ();
+
+  class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
+
+  if (scm_is_false (class))
+    {
+      if (SCM_UNPACK (scm_class_class))
+        {
+          SCM name, meta, supers;
+
+          name = SCM_VTABLE_NAME (vtable);
+          if (scm_is_symbol (name))
+            name = scm_string_to_symbol
+              (scm_string_append
+               (scm_list_3 (scm_from_latin1_string ("<"),
+                            scm_symbol_to_string (name),
+                            scm_from_latin1_string (">"))));
+          else
+            name = scm_from_latin1_symbol ("<>");
+
+          if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER))
+            {
+              meta = scm_class_applicable_struct_with_setter_class;
+              supers = scm_list_1 (scm_class_applicable_struct_with_setter);
+            }
+          else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable,
+                                                  SCM_VTABLE_FLAG_APPLICABLE))
+            {
+              meta = scm_class_applicable_struct_class;
+              supers = scm_list_1 (scm_class_applicable_struct);
+            }
+          else
+            {
+              meta = scm_class_class;
+              supers = scm_list_1 (scm_class_top);
+            }
+
+          return scm_make_standard_class (meta, name, supers, SCM_EOL);
+        }
+      else
+        /* `create_struct_classes' will fill this in later.  */
+        class = SCM_BOOL_F;
+
+      /* Don't worry about races.  This only happens when creating a
+         vtable, which happens by definition in one thread.  */
+      scm_weak_table_putq_x (vtable_class_map, vtable, class);
+    }
+
+  return class;
+}
+
 static SCM
 make_struct_class (void *closure SCM_UNUSED,
                   SCM vtable, SCM data, SCM prev SCM_UNUSED)
@@ -1635,13 +1614,15 @@ 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),
+SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, 
"%bless-applicable-struct-vtables!", 2, 0, 0,
+           (SCM applicable, SCM setter),
            "")
-#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtable_x
+#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x
 {
-  SCM_VALIDATE_CLASS (1, vtable);
-  SCM_SET_VTABLE_FLAGS (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
+  SCM_VALIDATE_CLASS (1, applicable);
+  SCM_VALIDATE_CLASS (2, setter);
+  SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
+  SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -1686,11 +1667,14 @@ SCM_DEFINE (scm_sys_goops_early_init, 
"%goops-early-init", 0, 0, 0,
   /* 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_applicable_struct_with_setter_class =
+    scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-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_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup 
("<applicable-struct-with-setter>"));
   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>"));
diff --git a/libguile/goops.h b/libguile/goops.h
index bc6524c..062a7b8 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -137,19 +137,6 @@
 
 #define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
 
-#define SCM_SET_GENERIC_DISPATCH_PROCEDURE(G,C) (SCM_STRUCT_SLOT_SET (G, 
scm_si_dispatch_procedure, (C)))
-#define SCM_CLEAR_GENERIC_EFFECTIVE_METHODS(G) (SCM_STRUCT_SLOT_SET (G, 
scm_si_effective_methods, SCM_EOL));
-
-#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G) 
[scm_si_generic_setter]))
-#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) 
[scm_si_generic_setter] = SCM_UNPACK (C))
-
-#define scm_si_dispatch_procedure scm_applicable_struct_index_procedure /* 0 */
-#define scm_si_methods            1
-#define scm_si_n_specialized     2
-#define scm_si_extended_by       3
-#define scm_si_effective_methods  4
-#define scm_si_generic_setter     5
-
 /* C interface */
 SCM_API SCM scm_class_boolean;
 SCM_API SCM scm_class_char;
@@ -220,7 +207,6 @@ SCM_INTERNAL SCM scm_make_standard_class (SCM meta, SCM 
name, SCM dsupers,
 
 /* Primitives exported */
 SCM_API SCM scm_sys_allocate_instance (SCM c, SCM initargs);
-SCM_API SCM scm_sys_set_object_setter_x (SCM obj, SCM setter);
 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);
 
diff --git a/libguile/procs.c b/libguile/procs.c
index be9f220..08c5c35 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -117,10 +117,6 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
     return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
   if (SCM_STRUCT_SETTER_P (proc))
     return SCM_STRUCT_SETTER (proc);
-  if (SCM_PUREGENERICP (proc)
-      && SCM_IS_A_P (proc, scm_class_generic_with_setter))
-    /* FIXME: might not be an accessor */
-    return SCM_GENERIC_SETTER (proc);
   return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
 }
 #undef FUNC_NAME
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index f4ba91b..bac9600 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -51,8 +51,8 @@
             <procedure> <primitive-generic>
 
             ;; Applicable structs.
-            <applicable-struct-class>
-            <applicable-struct>
+            <applicable-struct-class> <applicable-struct-with-setter-class>
+            <applicable-struct> <applicable-struct-with-setter>
             <generic> <extended-generic>
             <generic-with-setter> <extended-generic-with-setter>
             <accessor> <extended-accessor>
@@ -434,21 +434,20 @@
 
 ;; 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-struct-class>
+  (<procedure-class>))
+(define-standard-class <applicable-struct-with-setter-class>
+  (<applicable-struct-class>))
+(%bless-applicable-struct-vtables! <applicable-struct-class>
+                                   <applicable-struct-with-setter-class>)
+
 (define-standard-class <applicable> (<top>))
 (define-standard-class <applicable-struct> (<object> <applicable>)
   #:metaclass <applicable-struct-class>
   procedure)
+(define-standard-class <applicable-struct-with-setter> (<applicable-struct>)
+  #:metaclass <applicable-struct-with-setter-class>
+  setter)
 (define-standard-class <generic> (<applicable-struct>)
   #:metaclass <applicable-struct-class>
   methods
@@ -460,22 +459,33 @@
   #: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)
+(define-standard-class <generic-with-setter> (<generic>
+                                              <applicable-struct-with-setter>)
+  #:metaclass <applicable-struct-with-setter-class>)
 (%bless-pure-generic-vtable! <generic-with-setter>)
 (define-standard-class <accessor> (<generic-with-setter>)
-  #:metaclass <applicable-struct-class>)
+  #:metaclass <applicable-struct-with-setter-class>)
 (%bless-pure-generic-vtable! <accessor>)
 (define-standard-class <extended-generic-with-setter> (<extended-generic>
                                                        <generic-with-setter>)
-  #:metaclass <applicable-struct-class>)
+  #:metaclass <applicable-struct-with-setter-class>)
 (%bless-pure-generic-vtable! <extended-generic-with-setter>)
 (define-standard-class <extended-accessor> (<accessor>
                                             <extended-generic-with-setter>)
-  #:metaclass <applicable-struct-class>)
+  #:metaclass <applicable-struct-with-setter-class>)
 (%bless-pure-generic-vtable! <extended-accessor>)
 
+;; Methods
+(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))
+
 ;; Primitive types classes
 (define-standard-class <boolean> (<top>))
 (define-standard-class <char> (<top>))
@@ -534,7 +544,7 @@
       (when (eq? class <accessor>)
         (let ((setter (get-keyword #:setter args #f)))
           (when setter
-            (%set-object-setter! z setter))))
+            (slot-set! z 'setter setter))))
       z))
    (else
     (let ((z (%allocate-instance class args)))
@@ -2160,6 +2170,11 @@
   (next-method)
   (initialize-object-procedure applicable-struct initargs))
 
+(define-method (initialize (applicable-struct <applicable-struct-with-setter>)
+                           initargs)
+  (next-method)
+  (slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f)))
+
 (define-method (initialize (generic <generic>) initargs)
   (let ((previous-definition (get-keyword #:default initargs #f))
        (name (get-keyword #:name initargs #f)))
@@ -2172,10 +2187,6 @@
        (set-procedure-property! generic 'name name))
     (invalidate-method-cache! generic)))
 
-(define-method (initialize (gws <generic-with-setter>) initargs)
-  (next-method)
-  (%set-object-setter! gws (get-keyword #:setter initargs #f)))
-
 (define-method (initialize (eg <extended-generic>) initargs)
   (next-method)
   (slot-set! eg 'extends (get-keyword #:extends initargs '())))