From 48c981c9b69d0041ec0b9af73627dea12f1cb444 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 9 Jan 2015 22:05:01 +0100 Subject: [PATCH] Port method and generic accessors to Scheme * libguile/goops.c: * module/oop/goops.scm (generic-function-methods) (method-generic-function, method-specializers, method-procedure): Port to Scheme. --- libguile/goops.c | 104 +++++++++++++------------------------------ module/oop/goops.scm | 45 +++++++++++++++++++ 2 files changed, 76 insertions(+), 73 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index dd1b5a28e..f30be468b 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -77,6 +77,12 @@ 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; +static SCM var_generic_function_methods = SCM_BOOL_F; +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; + + SCM_SYMBOL (sym_slot_unbound, "slot-unbound"); SCM_SYMBOL (sym_slot_missing, "slot-missing"); SCM_SYMBOL (sym_change_class, "change-class"); @@ -585,83 +591,29 @@ SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0, } #undef FUNC_NAME -SCM_SYMBOL (sym_methods, "methods"); -SCM_SYMBOL (sym_extended_by, "extended-by"); -SCM_SYMBOL (sym_extends, "extends"); - -static -SCM fold_downward_gf_methods (SCM method_lists, SCM gf) +SCM +scm_generic_function_methods (SCM obj) { - SCM gfs = scm_slot_ref (gf, sym_extended_by); - method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists); - while (!scm_is_null (gfs)) - { - method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs)); - gfs = SCM_CDR (gfs); - } - return method_lists; + return scm_call_1 (scm_variable_ref (var_generic_function_methods), obj); } -static -SCM fold_upward_gf_methods (SCM method_lists, SCM gf) +SCM +scm_method_generic_function (SCM obj) { - if (SCM_IS_A_P (gf, class_extended_generic)) - { - SCM gfs = scm_slot_ref (gf, sym_extends); - while (!scm_is_null (gfs)) - { - SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods); - method_lists = fold_upward_gf_methods (scm_cons (methods, - method_lists), - SCM_CAR (gfs)); - gfs = SCM_CDR (gfs); - } - } - return method_lists; + return scm_call_1 (scm_variable_ref (var_method_generic_function), obj); } -SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0, - (SCM obj), - "Return the methods of the generic function @var{obj}.") -#define FUNC_NAME s_scm_generic_function_methods +SCM +scm_method_specializers (SCM obj) { - SCM methods; - SCM_VALIDATE_GENERIC (1, obj); - methods = fold_upward_gf_methods (SCM_EOL, obj); - methods = fold_downward_gf_methods (methods, obj); - return scm_append (methods); + return scm_call_1 (scm_variable_ref (var_method_specializers), obj); } -#undef FUNC_NAME -SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0, - (SCM obj), - "Return the generic function for the method @var{obj}.") -#define FUNC_NAME s_scm_method_generic_function +SCM +scm_method_procedure (SCM obj) { - SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, scm_from_latin1_symbol ("generic-function")); + return scm_call_1 (scm_variable_ref (var_method_procedure), obj); } -#undef FUNC_NAME - -SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0, - (SCM obj), - "Return specializers of the method @var{obj}.") -#define FUNC_NAME s_scm_method_specializers -{ - SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, scm_from_latin1_symbol ("specializers")); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0, - (SCM obj), - "Return the procedure of the method @var{obj}.") -#define FUNC_NAME s_scm_method_procedure -{ - SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, sym_procedure); -} -#undef FUNC_NAME /****************************************************************************** * @@ -1581,13 +1533,6 @@ 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 ("")); @@ -1673,6 +1618,19 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, #define FUNC_NAME s_scm_sys_goops_loaded { goops_loaded_p = 1; + 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"); + + var_generic_function_methods = scm_c_lookup ("generic-function-methods"); + var_method_generic_function = scm_c_lookup ("method-generic-function"); + var_method_specializers = scm_c_lookup ("method-specializers"); + var_method_procedure = scm_c_lookup ("method-procedure"); + var_slot_unbound = scm_module_variable (scm_module_goops, sym_slot_unbound); var_slot_missing = diff --git a/module/oop/goops.scm b/module/oop/goops.scm index b1da1ffa5..7fbca04d5 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -640,6 +640,27 @@ (error "boot `make' does not support this class" class))) z)))) +(define (method-generic-function obj) + "Return the generic function for the method @var{obj}." + (unless (is-a? obj ) + (scm-error 'wrong-type-arg #f "Not a method: ~S" + (list obj) #f)) + (slot-ref obj 'generic-function)) + +(define (method-specializers obj) + "Return specializers of the method @var{obj}." + (unless (is-a? obj ) + (scm-error 'wrong-type-arg #f "Not a method: ~S" + (list obj) #f)) + (slot-ref obj 'specializers)) + +(define (method-procedure obj) + "Return the procedure of the method @var{obj}." + (unless (is-a? obj ) + (scm-error 'wrong-type-arg #f "Not a method: ~S" + (list obj) #f)) + (slot-ref obj 'procedure)) + (define *dispatch-module* (current-module)) ;;; @@ -1319,6 +1340,30 @@ (define (%sort-applicable-methods methods types) (sort methods (lambda (a b) (%method-more-specific? a b types)))) +(define (generic-function-methods obj) + "Return the methods of the generic function @var{obj}." + (define (fold-upward method-lists gf) + (cond + ((is-a? gf ) + (let lp ((method-lists method-lists) (gfs (slot-ref gf 'extends))) + (match gfs + (() method-lists) + ((gf . gfs) + (lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf) + gfs))))) + (else method-lists))) + (define (fold-downward method-lists gf) + (let lp ((method-lists (cons (slot-ref gf 'methods) method-lists)) + (gfs (slot-ref gf 'extended-by))) + (match gfs + (() method-lists) + ((gf . gfs) + (lp (fold-downward method-lists gf) gfs))))) + (unless (is-a? obj ) + (scm-error 'wrong-type-arg #f "Not a generic: ~S" + (list obj) #f)) + (concatenate (fold-downward (fold-upward '() obj) obj))) + (define (%compute-applicable-methods gf args) (define (method-applicable? m types) (let lp ((specs (method-specializers m)) (types types))