[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 39/42: Move slot-ref et al to Scheme
From: |
Andy Wingo |
Subject: |
[Guile-commits] 39/42: Move slot-ref et al to Scheme |
Date: |
Sat, 10 Jan 2015 00:03:18 +0000 |
wingo pushed a commit to branch wip-goops-refactor
in repository guile.
commit d4414c87e5ed46fa9157c78fb70cf09b3dc3a041
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 d339570..3534e18 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");
@@ -358,8 +368,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),
@@ -415,16 +423,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));
}
}
@@ -639,229 +644,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 b722c48..54e7b67 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -237,6 +237,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:
@@ -639,6 +646,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 index size)
+ (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 index size)
+ (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>)
@@ -949,13 +1052,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}
;;;
- [Guile-commits] 31/42: Remove unused union scm_t_debug_info, (continued)
- [Guile-commits] 31/42: Remove unused union scm_t_debug_info, Andy Wingo, 2015/01/09
- [Guile-commits] 33/42: Remove GOOPS random state, Andy Wingo, 2015/01/09
- [Guile-commits] 35/42: Statically compute offsets for slots of <class> in Scheme, Andy Wingo, 2015/01/09
- [Guile-commits] 24/42: Generics with setters have <applicable-struct-with-setter> layout, Andy Wingo, 2015/01/09
- [Guile-commits] 11/42: Move GOOPS boot to Scheme, Andy Wingo, 2015/01/09
- [Guile-commits] 34/42: Refactor to <class> slot computation, Andy Wingo, 2015/01/09
- [Guile-commits] 42/42: Remove TEST_CHANGE_CLASS, Andy Wingo, 2015/01/09
- [Guile-commits] 41/42: Remove pure-generic?, Andy Wingo, 2015/01/09
- [Guile-commits] 40/42: Goops slot-unbound / slot-missing cleanups, Andy Wingo, 2015/01/09
- [Guile-commits] 38/42: Port method and generic accessors to Scheme, Andy Wingo, 2015/01/09
- [Guile-commits] 39/42: Move slot-ref et al to Scheme,
Andy Wingo <=
- [Guile-commits] 37/42: <class> accessors implemented in Scheme, Andy Wingo, 2015/01/09
- [Guile-commits] 32/42: More goops.c cleanups, and fix a security issue, Andy Wingo, 2015/01/09
- [Guile-commits] 25/42: Deprecate C exports of GOOPS classes., Andy Wingo, 2015/01/09
- [Guile-commits] 17/42: Fold GOOPS compile and dispatch modules into main GOOPS module, Andy Wingo, 2015/01/09
- [Guile-commits] 36/42: goops: use computed class slot offsets; untabify and fix whitepace, Andy Wingo, 2015/01/09