From 70dd600070c6d7abb072d85a5f0fccfd0b13e5e6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 9 Jan 2015 21:01:03 +0100 Subject: [PATCH] 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 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 5e3b21058..dd1b5a28e 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_top = scm_variable_ref (scm_c_lookup ("")); diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 77c387df2..b1da1ffa5 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--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)) -- 2.20.1