[Guile-commits] 40/88: Move slot-ref et al to Scheme

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit ade4cf4c921bf1f01ff3b392c3ca3f7a5e340630
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 10 00:50:33 2015 +0100

    Move slot-ref et al to Scheme
    
    * libguile/goops.c:
    * module/oop/goops.scm (slot-ref-using-class, slot-set-using-class!):
      (slot-bound-using-class?, slot-exists-using-class?, slot-set!):
      (slot-bound?, slot-exists?): Move implementation to Scheme.
---
 libguile/goops.c     |  256 ++++++++++----------------------------------------
 module/oop/goops.scm |  110 ++++++++++++++++++++--
 2 files changed, 153 insertions(+), 213 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index f30be46..cf08f9c 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -82,6 +82,16 @@ static SCM var_method_generic_function = SCM_BOOL_F;
 static SCM var_method_specializers = SCM_BOOL_F;
 static SCM var_method_procedure = SCM_BOOL_F;
 
+static SCM var_slot_ref_using_class = SCM_BOOL_F;
+static SCM var_slot_set_using_class_x = SCM_BOOL_F;
+static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
+static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
+
+static SCM var_slot_ref = SCM_BOOL_F;
+static SCM var_slot_set_x = SCM_BOOL_F;
+static SCM var_slot_bound_p = SCM_BOOL_F;
+static SCM var_slot_exists_p = SCM_BOOL_F;
+
 
 SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
 SCM_SYMBOL (sym_slot_missing, "slot-missing");
@@ -360,8 +370,6 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
 
 SCM_KEYWORD (k_init_keyword, "init-keyword");
 
-static SCM get_slot_value (SCM class, SCM obj, SCM slotdef);
-static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value);
 
 SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
            (SCM obj, SCM initargs),
@@ -417,16 +425,13 @@ SCM_DEFINE (scm_sys_initialize_object, 
"%initialize-object", 2, 0, 0,
 
       if (!SCM_GOOPS_UNBOUNDP (slot_value))
        /* set slot to provided value */
-       set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
+       scm_slot_set_x (obj, slot_name, slot_value);
       else
        {
          /* set slot to its :init-form if it exists */
          tmp = SCM_CADAR (get_n_set);
          if (scm_is_true (tmp))
-            set_slot_value (class,
-                            obj,
-                            SCM_CAR (get_n_set),
-                            scm_call_0 (tmp));
+            scm_slot_set_x (obj, slot_name, scm_call_0 (tmp));
        }
     }
 
@@ -641,229 +646,58 @@ SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
 
 
 
-/** Utilities **/
-
-/* In the future, this function will return the effective slot
- * definition associated with SLOT_NAME.  Now it just returns some of
- * the information which will be stored in the effective slot
- * definition.
- */
-
-static SCM
-slot_definition_using_name (SCM class, SCM slot_name)
-{
-  register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
-  for (; !scm_is_null (slots); slots = SCM_CDR (slots))
-    if (scm_is_eq (SCM_CAAR (slots), slot_name))
-      return SCM_CAR (slots);
-  return SCM_BOOL_F;
-}
-
-static SCM
-get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
-#define FUNC_NAME "%get-slot-value"
-{
-  SCM access = SCM_CDDR (slotdef);
-  /* Two cases here:
-   *   - access is an integer (the offset of this slot in the slots vector)
-   *   - otherwise (car access) is the getter function to apply
-   *
-   * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
-   * we can just assume fixnums here.
-   */
-  if (SCM_I_INUMP (access))
-    /* Don't poke at the slots directly, because scm_struct_ref handles the
-       access bits for us. */
-    return scm_struct_ref (obj, access);
-  else
-    return scm_call_1 (SCM_CAR (access), obj);
-}
-#undef FUNC_NAME
-
-static SCM
-get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
-{
-  SCM slotdef = slot_definition_using_name (class, slot_name);
-  if (scm_is_true (slotdef))
-    return get_slot_value (class, obj, slotdef);
-  else
-    return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, 
slot_name);
-}
-
-static SCM
-set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
-#define FUNC_NAME "%set-slot-value"
-{
-  SCM access = SCM_CDDR (slotdef);
-  /* Two cases here:
-   *   - access is an integer (the offset of this slot in the slots vector)
-   *   - otherwise (cadr access) is the setter function to apply
-   *
-   * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
-   * we can just assume fixnums here.
-   */
-  if (SCM_I_INUMP (access))
-    /* obey permissions bits via going through struct-set! */
-    scm_struct_set_x (obj, access, value);
-  else
-    /* ((cadr l) obj value) */
-    scm_call_2 (SCM_CADR (access), obj, value);
-  return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-static SCM
-set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
-{
-  SCM slotdef = slot_definition_using_name (class, slot_name);
-  if (scm_is_true (slotdef))
-    return set_slot_value (class, obj, slotdef, value);
-  else
-    return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, 
slot_name, value);
-}
-
-static SCM
-test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name)
-{
-  register SCM l;
-
-  for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l))
-    if (scm_is_eq (SCM_CAAR (l), slot_name))
-      return SCM_BOOL_T;
-
-  return SCM_BOOL_F;
-}
-
-               /* ======================================== */
 
-SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0,
-           (SCM class, SCM obj, SCM slot_name),
-           "")
-#define FUNC_NAME s_scm_slot_ref_using_class
+SCM
+scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
 {
-  SCM res;
-
-  SCM_VALIDATE_CLASS (1, class);
-  SCM_VALIDATE_INSTANCE (2, obj);
-  SCM_VALIDATE_SYMBOL (3, slot_name);
-
-  res = get_slot_value_using_name (class, obj, slot_name);
-  if (SCM_GOOPS_UNBOUNDP (res))
-    return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, 
slot_name);
-  return res;
+  return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
+                     class, obj, slot_name);
 }
-#undef FUNC_NAME
 
-
-SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0,
-           (SCM class, SCM obj, SCM slot_name, SCM value),
-           "")
-#define FUNC_NAME s_scm_slot_set_using_class_x
+SCM
+scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
 {
-  SCM_VALIDATE_CLASS (1, class);
-  SCM_VALIDATE_INSTANCE (2, obj);
-  SCM_VALIDATE_SYMBOL (3, slot_name);
-
-  return set_slot_value_using_name (class, obj, slot_name, value);
+  return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
+                     class, obj, slot_name, value);
 }
-#undef FUNC_NAME
 
-
-SCM_DEFINE (scm_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0,
-           (SCM class, SCM obj, SCM slot_name),
-           "")
-#define FUNC_NAME s_scm_slot_bound_using_class_p
+SCM
+scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
 {
-  SCM_VALIDATE_CLASS (1, class);
-  SCM_VALIDATE_INSTANCE (2, obj);
-  SCM_VALIDATE_SYMBOL (3, slot_name);
-
-  return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, 
slot_name))
-         ? SCM_BOOL_F
-         : SCM_BOOL_T);
+  return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
+                     class, obj, slot_name);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0,
-           (SCM class, SCM obj, SCM slot_name),
-           "")
-#define FUNC_NAME s_scm_slot_exists_using_class_p
+SCM
+scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
 {
-  SCM_VALIDATE_CLASS (1, class);
-  SCM_VALIDATE_INSTANCE (2, obj);
-  SCM_VALIDATE_SYMBOL (3, slot_name);
-  return test_slot_existence (class, obj, slot_name);
+  return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
+                     class, obj, slot_name);
 }
-#undef FUNC_NAME
-
 
-               /* ======================================== */
-
-SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
-           (SCM obj, SCM slot_name),
-           "Return the value from @var{obj}'s slot with the name\n"
-           "@var{slot_name}.")
-#define FUNC_NAME s_scm_slot_ref
+SCM
+scm_slot_ref (SCM obj, SCM slot_name)
 {
-  SCM res, class;
-
-  SCM_VALIDATE_INSTANCE (1, obj);
-  TEST_CHANGE_CLASS (obj, class);
-
-  res = get_slot_value_using_name (class, obj, slot_name);
-  if (SCM_GOOPS_UNBOUNDP (res))
-    return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, 
slot_name);
-  return res;
+  return scm_call_2 (scm_variable_ref (var_slot_ref), obj, slot_name);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
-           (SCM obj, SCM slot_name, SCM value),
-           "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
-#define FUNC_NAME s_scm_slot_set_x
+SCM
+scm_slot_set_x (SCM obj, SCM slot_name, SCM value)
 {
-  SCM class;
-
-  SCM_VALIDATE_INSTANCE (1, obj);
-  TEST_CHANGE_CLASS(obj, class);
-
-  return set_slot_value_using_name (class, obj, slot_name, value);
+  return scm_call_3 (scm_variable_ref (var_slot_set_x), obj, slot_name, value);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
-           (SCM obj, SCM slot_name),
-           "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
-           "is bound.")
-#define FUNC_NAME s_scm_slot_bound_p
+SCM
+scm_slot_bound_p (SCM obj, SCM slot_name)
 {
-  SCM class;
-
-  SCM_VALIDATE_INSTANCE (1, obj);
-  TEST_CHANGE_CLASS(obj, class);
-
-  return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
-                                                        obj,
-                                                        slot_name))
-         ? SCM_BOOL_F
-         : SCM_BOOL_T);
+  return scm_call_2 (scm_variable_ref (var_slot_bound_p), obj, slot_name);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
-           (SCM obj, SCM slot_name),
-           "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
-#define FUNC_NAME s_scm_slot_exists_p
+SCM
+scm_slot_exists_p (SCM obj, SCM slot_name)
 {
-  SCM class;
-
-  SCM_VALIDATE_INSTANCE (1, obj);
-  SCM_VALIDATE_SYMBOL (2, slot_name);
-  TEST_CHANGE_CLASS (obj, class);
-
-  return test_slot_existence (class, obj, slot_name);
+  return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name);
 }
-#undef FUNC_NAME
 
 
 /******************************************************************************
@@ -1534,6 +1368,16 @@ SCM_DEFINE (scm_sys_goops_early_init, 
"%goops-early-init", 0, 0, 0,
   var_make_standard_class = scm_c_lookup ("make-standard-class");
   var_make = scm_c_lookup ("make");
 
+  var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
+  var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
+  var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
+  var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
+
+  var_slot_ref = scm_c_lookup ("slot-ref");
+  var_slot_set_x = scm_c_lookup ("slot-set!");
+  var_slot_bound_p = scm_c_lookup ("slot-bound?");
+  var_slot_exists_p = scm_c_lookup ("slot-exists?");
+
   class_class = scm_variable_ref (scm_c_lookup ("<class>"));
   class_top = scm_variable_ref (scm_c_lookup ("<top>"));
   class_object = scm_variable_ref (scm_c_lookup ("<object>"));
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 7fbca04..c7703ea 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -238,6 +238,13 @@
   "Return the slot list of the class @var{obj}."
   class-index-slots)
 
+;;
+;; is-a?
+;;
+(define (is-a? obj class)
+  (and (memq class (class-precedence-list (class-of obj))) #t))
+
+
 ;;; The standard class precedence list computation algorithm
 ;;;
 ;;; Correct behaviour:
@@ -640,6 +647,102 @@
         (error "boot `make' does not support this class" class)))
       z))))
 
+;; In the future, this function will return the effective slot
+;; definition associated with SLOT_NAME.  Now it just returns some of
+;; the information which will be stored in the effective slot
+;; definition.
+;;
+(define (get-slot-value-using-name class obj slot-name)
+  (match (assq slot-name (struct-ref class class-index-getters-n-setters))
+    (#f (slot-missing class obj slot-name))
+    ((name init-thunk . (? exact-integer? index))
+     (struct-ref obj index))
+    ((name init-thunk getter setter . _)
+     (getter obj))))
+
+(define (set-slot-value-using-name! class obj slot-name value)
+  (match (assq slot-name (struct-ref class class-index-getters-n-setters))
+    (#f (slot-missing class obj slot-name value))
+    ((name init-thunk . (? exact-integer? index))
+     (struct-set! obj index value))
+    ((name init-thunk getter setter . _)
+     (setter obj value))))
+
+(define (test-slot-existence class obj slot-name)
+  (and (assq slot-name (struct-ref class class-index-getters-n-setters))
+       #t))
+
+;; ========================================
+
+(define (check-slot-args class obj slot-name)
+  (unless (class? class)
+    (scm-error 'wrong-type-arg #f "Not a class: ~S"
+               (list class) #f))
+  (unless (is-a? obj <object>)
+    (scm-error 'wrong-type-arg #f "Not an instance: ~S"
+               (list obj) #f))
+  (unless (symbol? slot-name)
+    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+               (list slot-name) #f)))
+
+(define (slot-ref-using-class class obj slot-name)
+  (check-slot-args class obj slot-name)
+  (let ((val (get-slot-value-using-name class obj slot-name)))
+    (if (unbound? val)
+        (slot-unbound class obj slot-name)
+        val)))
+
+(define (slot-set-using-class! class obj slot-name value)
+  (check-slot-args class obj slot-name)
+  (set-slot-value-using-name! class obj slot-name value))
+
+(define (slot-bound-using-class? class obj slot-name)
+  (check-slot-args class obj slot-name)
+  (not (unbound? (get-slot-value-using-name class obj slot-name))))
+
+(define (slot-exists-using-class? class obj slot-name)
+  (check-slot-args class obj slot-name)
+  (test-slot-existence class obj slot-name))
+
+;; Class redefinition protocol:
+;;
+;; A class is represented by a heap header h1 which points to a
+;; malloc:ed memory block m1.
+;;
+;; When a new version of a class is created, a new header h2 and
+;; memory block m2 are allocated.  The headers h1 and h2 then switch
+;; pointers so that h1 refers to m2 and h2 to m1.  In this way, names
+;; bound to h1 will point to the new class at the same time as h2 will
+;; be a handle which the GC will use to free m1.
+;;
+;; The `redefined' slot of m1 will be set to point to h1.  An old
+;; instance will have its class pointer (the CAR of the heap header)
+;; pointing to m1.  The non-immediate `redefined'-slot in m1 indicates
+;; the class modification and the new class pointer can be found via
+;; h1.
+;;
+
+;; In the following interfaces, class-of handles the redefinition
+;; protocol.  There would seem to be some thread-unsafety though as the
+;; { class, object data } pair needs to be accessed atomically, not the
+;; { class, object } pair.
+
+(define (slot-ref obj slot-name)
+  "Return the value from @var{obj}'s slot with the nam var{slot_name}."
+  (slot-ref-using-class (class-of obj) obj slot-name))
+
+(define (slot-set! obj slot-name value)
+  "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
+  (slot-set-using-class! (class-of obj) obj slot-name value))
+
+(define (slot-bound? obj slot-name)
+  "Return the value from @var{obj}'s slot with the nam var{slot_name}."
+  (slot-bound-using-class? (class-of obj) obj slot-name))
+
+(define (slot-exists? obj slot-name)
+  "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
+  (slot-exists-using-class? (class-of obj) obj slot-name))
+
 (define (method-generic-function obj)
   "Return the generic function for the method @var{obj}."
   (unless (is-a? obj <method>)
@@ -950,13 +1053,6 @@
 (define (goops-error format-string . args)
   (scm-error 'goops-error #f format-string args '()))
 
-;;
-;; is-a?
-;;
-(define (is-a? obj class)
-  (and (memq class (class-precedence-list (class-of obj))) #t))
-
-
 ;;;
 ;;; {Meta classes}
 ;;;