[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 38/88: <class> accessors implemented in Scheme
From: |
Andy Wingo |
Subject: |
[Guile-commits] 38/88: <class> accessors implemented in Scheme |
Date: |
Fri, 23 Jan 2015 15:25:37 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 70dd600070c6d7abb072d85a5f0fccfd0b13e5e6
Author: Andy Wingo <address@hidden>
Date: Fri Jan 9 21:01:03 2015 +0100
<class> accessors implemented in Scheme
* libguile/goops.c (scm_class_p): New internal helper, exported to
goops.scm.
(scm_class_name, scm_class_direct_supers, scm_class_direct_slots):
(scm_class_direct_subclasses, scm_class_direct_methods):
(scm_class_precedence_list, scm_class_slots): Dispatch to Scheme.
(scm_sys_goops_early_init): Capture <class> accessors.
* module/oop/goops.scm (define-class-accessor): New helper.
(class-name, class-direct-supers, class-direct-slots):
(class-direct-subclasses, class-direct-methods)
(class-precedence-list, class-slots): Define in Scheme.
(compute-std-cpl, compute-cpl): Move lower.
---
libguile/goops.c | 104 ++++++++++++++++--------------------
module/oop/goops.scm | 145 ++++++++++++++++++++++++++++++--------------------
2 files changed, 135 insertions(+), 114 deletions(-)
diff --git a/libguile/goops.c b/libguile/goops.c
index 5e3b210..dd1b5a2 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -69,6 +69,13 @@ static SCM var_slot_unbound = SCM_BOOL_F;
static SCM var_slot_missing = SCM_BOOL_F;
static SCM var_change_class = SCM_BOOL_F;
static SCM var_make = SCM_BOOL_F;
+static SCM var_class_name = SCM_BOOL_F;
+static SCM var_class_direct_supers = SCM_BOOL_F;
+static SCM var_class_direct_slots = SCM_BOOL_F;
+static SCM var_class_direct_subclasses = SCM_BOOL_F;
+static SCM var_class_direct_methods = SCM_BOOL_F;
+static SCM var_class_precedence_list = SCM_BOOL_F;
+static SCM var_class_slots = SCM_BOOL_F;
SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
SCM_SYMBOL (sym_slot_missing, "slot-missing");
@@ -163,6 +170,7 @@ SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
static SCM scm_make_unbound (void);
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_bless_pure_generic_vtable_x (SCM vtable);
@@ -496,6 +504,15 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_class_p, "class?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a class.")
+#define FUNC_NAME s_scm_class_p
+{
+ return scm_from_bool (SCM_CLASSP (obj));
+}
+#undef FUNC_NAME
+
int
scm_is_generic (SCM x)
{
@@ -515,85 +532,51 @@ scm_is_method (SCM x)
******************************************************************************/
SCM_SYMBOL (sym_procedure, "procedure");
-SCM_SYMBOL (sym_direct_supers, "direct-supers");
-SCM_SYMBOL (sym_direct_slots, "direct-slots");
-SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
-SCM_SYMBOL (sym_direct_methods, "direct-methods");
-SCM_SYMBOL (sym_cpl, "cpl");
-SCM_SYMBOL (sym_slots, "slots");
-
-SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0,
- (SCM obj),
- "Return the class name of @var{obj}.")
-#define FUNC_NAME s_scm_class_name
+
+SCM
+scm_class_name (SCM obj)
{
- SCM_VALIDATE_CLASS (1, obj);
- return scm_slot_ref (obj, scm_sym_name);
+ return scm_call_1 (scm_variable_ref (var_class_name), obj);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
- (SCM obj),
- "Return the direct superclasses of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_direct_supers
+SCM
+scm_class_direct_supers (SCM obj)
{
- SCM_VALIDATE_CLASS (1, obj);
- return scm_slot_ref (obj, sym_direct_supers);
+ return scm_call_1 (scm_variable_ref (var_class_direct_supers), obj);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
- (SCM obj),
- "Return the direct slots of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_direct_slots
+SCM
+scm_class_direct_slots (SCM obj)
{
- SCM_VALIDATE_CLASS (1, obj);
- return scm_slot_ref (obj, sym_direct_slots);
+ return scm_call_1 (scm_variable_ref (var_class_direct_slots), obj);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
- (SCM obj),
- "Return the direct subclasses of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_direct_subclasses
+SCM
+scm_class_direct_subclasses (SCM obj)
{
- SCM_VALIDATE_CLASS (1, obj);
- return scm_slot_ref(obj, sym_direct_subclasses);
+ return scm_call_1 (scm_variable_ref (var_class_direct_subclasses), obj);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
- (SCM obj),
- "Return the direct methods of the class @var{obj}")
-#define FUNC_NAME s_scm_class_direct_methods
+SCM
+scm_class_direct_methods (SCM obj)
{
- SCM_VALIDATE_CLASS (1, obj);
- return scm_slot_ref (obj, sym_direct_methods);
+ return scm_call_1 (scm_variable_ref (var_class_direct_methods), obj);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
- (SCM obj),
- "Return the class precedence list of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_precedence_list
+SCM
+scm_class_precedence_list (SCM obj)
{
- SCM_VALIDATE_CLASS (1, obj);
- return scm_slot_ref (obj, sym_cpl);
+ return scm_call_1 (scm_variable_ref (var_class_precedence_list), obj);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
- (SCM obj),
- "Return the slot list of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_slots
+SCM
+scm_class_slots (SCM obj)
{
- SCM_VALIDATE_CLASS (1, obj);
- return scm_slot_ref (obj, sym_slots);
+ return scm_call_1 (scm_variable_ref (var_class_slots), obj);
}
-#undef FUNC_NAME
SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
- (SCM obj),
+ (SCM obj),
"Return the name of the generic function @var{obj}.")
#define FUNC_NAME s_scm_generic_function_name
{
@@ -1598,6 +1581,13 @@ 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_class_name = scm_c_lookup ("class-name");
+ var_class_direct_supers = scm_c_lookup ("class-direct-supers");
+ var_class_direct_slots = scm_c_lookup ("class-direct-slots");
+ var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses");
+ var_class_direct_methods = scm_c_lookup ("class-direct-methods");
+ var_class_precedence_list = scm_c_lookup ("class-precedence-list");
+ var_class_slots = scm_c_lookup ("class-slots");
class_class = scm_variable_ref (scm_c_lookup ("<class>"));
class_top = scm_variable_ref (scm_c_lookup ("<top>"));
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 77c387d..b1da1ff 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -150,63 +150,6 @@
(use-modules ((language tree-il primitives) :select
(add-interesting-primitive!)))
(add-interesting-primitive! 'class-of))
-;;; The standard class precedence list computation algorithm
-;;;
-;;; Correct behaviour:
-;;;
-;;; (define-class food ())
-;;; (define-class fruit (food))
-;;; (define-class spice (food))
-;;; (define-class apple (fruit))
-;;; (define-class cinnamon (spice))
-;;; (define-class pie (apple cinnamon))
-;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
-;;;
-;;; (define-class d ())
-;;; (define-class e ())
-;;; (define-class f ())
-;;; (define-class b (d e))
-;;; (define-class c (e f))
-;;; (define-class a (b c))
-;;; => cpl (a) = a b d c e f object top
-;;;
-
-(define (compute-std-cpl c get-direct-supers)
- (define (only-non-null lst)
- (filter (lambda (l) (not (null? l))) lst))
-
- (define (merge-lists reversed-partial-result inputs)
- (cond
- ((every null? inputs)
- (reverse! reversed-partial-result))
- (else
- (let* ((candidate (lambda (c)
- (and (not (any (lambda (l)
- (memq c (cdr l)))
- inputs))
- c)))
- (candidate-car (lambda (l)
- (and (not (null? l))
- (candidate (car l)))))
- (next (any candidate-car inputs)))
- (if (not next)
- (goops-error "merge-lists: Inconsistent precedence graph"))
- (let ((remove-next (lambda (l)
- (if (eq? (car l) next)
- (cdr l)
- l))))
- (merge-lists (cons next reversed-partial-result)
- (only-non-null (map remove-next inputs))))))))
- (let ((c-direct-supers (get-direct-supers c)))
- (merge-lists (list c)
- (only-non-null (append (map class-precedence-list
- c-direct-supers)
- (list c-direct-supers))))))
-
-;; Bootstrap version.
-(define (compute-cpl class)
- (compute-std-cpl class class-direct-supers))
-
(define-syntax macro-fold-left
(syntax-rules ()
((_ folder seed ()) seed)
@@ -264,6 +207,94 @@
tail))))))
(fold-<class>-slots macro-fold-left define-class-index (begin)))
+(define-syntax-rule (define-class-accessor name docstring field)
+ (define (name obj)
+ docstring
+ (let ((val obj))
+ (unless (class? val)
+ (scm-error 'wrong-type-arg #f "Not a class: ~S"
+ (list val) #f))
+ (struct-ref val field))))
+
+(define-class-accessor class-name
+ "Return the class name of @var{obj}."
+ class-index-name)
+(define-class-accessor class-direct-supers
+ "Return the direct superclasses of the class @var{obj}."
+ class-index-direct-supers)
+(define-class-accessor class-direct-slots
+ "Return the direct slots of the class @var{obj}."
+ class-index-direct-slots)
+(define-class-accessor class-direct-subclasses
+ "Return the direct subclasses of the class @var{obj}."
+ class-index-direct-subclasses)
+(define-class-accessor class-direct-methods
+ "Return the direct methods of the class @var{obj}."
+ class-index-direct-methods)
+(define-class-accessor class-precedence-list
+ "Return the class precedence list of the class @var{obj}."
+ class-index-cpl)
+(define-class-accessor class-slots
+ "Return the slot list of the class @var{obj}."
+ class-index-slots)
+
+;;; The standard class precedence list computation algorithm
+;;;
+;;; Correct behaviour:
+;;;
+;;; (define-class food ())
+;;; (define-class fruit (food))
+;;; (define-class spice (food))
+;;; (define-class apple (fruit))
+;;; (define-class cinnamon (spice))
+;;; (define-class pie (apple cinnamon))
+;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
+;;;
+;;; (define-class d ())
+;;; (define-class e ())
+;;; (define-class f ())
+;;; (define-class b (d e))
+;;; (define-class c (e f))
+;;; (define-class a (b c))
+;;; => cpl (a) = a b d c e f object top
+;;;
+
+(define (compute-std-cpl c get-direct-supers)
+ (define (only-non-null lst)
+ (filter (lambda (l) (not (null? l))) lst))
+
+ (define (merge-lists reversed-partial-result inputs)
+ (cond
+ ((every null? inputs)
+ (reverse! reversed-partial-result))
+ (else
+ (let* ((candidate (lambda (c)
+ (and (not (any (lambda (l)
+ (memq c (cdr l)))
+ inputs))
+ c)))
+ (candidate-car (lambda (l)
+ (and (not (null? l))
+ (candidate (car l)))))
+ (next (any candidate-car inputs)))
+ (if (not next)
+ (goops-error "merge-lists: Inconsistent precedence graph"))
+ (let ((remove-next (lambda (l)
+ (if (eq? (car l) next)
+ (cdr l)
+ l))))
+ (merge-lists (cons next reversed-partial-result)
+ (only-non-null (map remove-next inputs))))))))
+ (let ((c-direct-supers (get-direct-supers c)))
+ (merge-lists (list c)
+ (only-non-null (append (map class-precedence-list
+ c-direct-supers)
+ (list c-direct-supers))))))
+
+;; Bootstrap version.
+(define (compute-cpl class)
+ (compute-std-cpl class class-direct-supers))
+
(define (build-slots-list dslots cpl)
(define (check-cpl slots class-slots)
(when (or-map (lambda (slot-def) (assq (car slot-def) slots))
- [Guile-commits] 19/88: Remove unused scm_t_method and SCM_METHOD, (continued)
- [Guile-commits] 19/88: Remove unused scm_t_method and SCM_METHOD, Andy Wingo, 2015/01/23
- [Guile-commits] 32/88: Remove unused union scm_t_debug_info, Andy Wingo, 2015/01/23
- [Guile-commits] 28/88: Remove scm_at_assert_bound_ref, Andy Wingo, 2015/01/23
- [Guile-commits] 33/88: More goops.c cleanups, and fix a security issue, Andy Wingo, 2015/01/23
- [Guile-commits] 34/88: Remove GOOPS random state, Andy Wingo, 2015/01/23
- [Guile-commits] 36/88: Statically compute offsets for slots of <class> in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 21/88: Remove unreachable code in scm_setter, Andy Wingo, 2015/01/23
- [Guile-commits] 18/88: Fold GOOPS compile and dispatch modules into main GOOPS module, Andy Wingo, 2015/01/23
- [Guile-commits] 39/88: Port method and generic accessors to Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 35/88: Refactor to <class> slot computation, Andy Wingo, 2015/01/23
- [Guile-commits] 38/88: <class> accessors implemented in Scheme,
Andy Wingo <=
- [Guile-commits] 30/88: Remove private var_no_applicable_method capture, Andy Wingo, 2015/01/23
- [Guile-commits] 26/88: Deprecate C exports of GOOPS classes., Andy Wingo, 2015/01/23
- [Guile-commits] 41/88: Goops slot-unbound / slot-missing cleanups, Andy Wingo, 2015/01/23
- [Guile-commits] 40/88: Move slot-ref et al to Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 44/88: No more concept of "pure generics", Andy Wingo, 2015/01/23
- [Guile-commits] 45/88: Remove scm_c_extend_primitive_generic, Andy Wingo, 2015/01/23
- [Guile-commits] 47/88: Rewrite %initialize-object in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 48/88: Deprecate scm_get_keyword, Andy Wingo, 2015/01/23
- [Guile-commits] 43/88: Remove TEST_CHANGE_CLASS, Andy Wingo, 2015/01/23
- [Guile-commits] 42/88: Remove pure-generic?, Andy Wingo, 2015/01/23