Accessor methods only apply to subclasses with their slot

[bpt/guile.git] / libguile / goops.c

diff --git a/libguile/goops.c b/libguile/goops.c
index f4b2b34..9fd61b5 100644 (file)
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014,2015
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -659,7 +659,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
        get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
     {
       SCM slot_name  = SCM_CAR (slots);
-      SCM slot_value = SCM_PACK (0);
+      SCM slot_value = SCM_GOOPS_UNBOUND;
 
       if (!scm_is_null (SCM_CDR (slot_name)))
        {
@@ -683,12 +683,12 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
              slot_value = scm_i_get_keyword (tmp,
                                              initargs,
                                              n_initargs,
-                                             SCM_PACK (0),
+                                             SCM_GOOPS_UNBOUND,
                                              FUNC_NAME);
            }
        }
 
-      if (SCM_UNPACK (slot_value))
+      if (!SCM_GOOPS_UNBOUNDP (slot_value))
        /* set slot to provided value */
        set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
       else
@@ -696,14 +696,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
          /* set slot to its :init-form if it exists */
          tmp = SCM_CADAR (get_n_set);
          if (scm_is_true (tmp))
-           {
-             slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
-             if (SCM_GOOPS_UNBOUNDP (slot_value))
-                set_slot_value (class,
-                                obj,
-                                SCM_CAR (get_n_set),
-                                scm_call_0 (tmp));
-           }
+            set_slot_value (class,
+                            obj,
+                            SCM_CAR (get_n_set),
+                            scm_call_0 (tmp));
        }
     }
 
@@ -982,7 +978,7 @@ create_basic_classes (void)
   /**** <class> ****/
   SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
   SCM name = scm_from_latin1_symbol ("<class>");
-  scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL);
+  scm_class_class = scm_i_make_vtable_vtable (cs);
   SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
                                         | SCM_CLASSF_METACLASS));
 
@@ -1763,15 +1759,22 @@ scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
   return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
 }
 
-SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
+static SCM delayed_compile_var;
+
+static void
+init_delayed_compile_var (void)
+{
+  delayed_compile_var
+    = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
+}
+
 static SCM
 make_dispatch_procedure (SCM gf)
 {
-  static SCM var = SCM_BOOL_F;
-  if (scm_is_false (var))
-    var = scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
-                               sym_delayed_compile);
-  return scm_call_1 (SCM_VARIABLE_REF (var), gf);
+  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  scm_i_pthread_once (&once, init_delayed_compile_var);
+
+  return scm_call_1 (scm_variable_ref (delayed_compile_var), gf);
 }
 
 static void
@@ -2050,6 +2053,11 @@ sort_applicable_methods (SCM method_list, long size, SCM const *targs)
   return scm_vector_to_list (vector);
 }
 
+static int
+is_accessor_method (SCM method) {
+  return SCM_IS_A_P (method, scm_class_accessor_method);
+}
+
 SCM
 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
 {
@@ -2085,6 +2093,10 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
   for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
     {
       fl = SPEC_OF (SCM_CAR (l));
+      /* Only accept accessors which match exactly in first arg. */
+      if ((scm_is_null (fl) || types[0] != SCM_CAR (fl))
+          && is_accessor_method (SCM_CAR (l)))
+       continue;
       for (i = 0; ; i++, fl = SCM_CDR (fl))
        {
          if (SCM_INSTANCEP (fl)