From c2aa5d9bbad48ceb1acf1c8fa7e5129f9e29892c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 11 Jan 2015 22:23:51 +0100 Subject: [PATCH] Cosmetic goops refactors. * module/oop/goops.scm: Update comments. * libguile/goops.c: Cosmetic reorderings, re-commentings, and de-commentings. --- libguile/goops.c | 153 ++++++++++++++++--------------------------- module/oop/goops.scm | 33 +++++++--- 2 files changed, 80 insertions(+), 106 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 547b4d2c2..f829695c3 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -152,6 +152,8 @@ SCM scm_i_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT]; /* SMOB classes. */ SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT]; +SCM scm_module_goops; + static SCM scm_make_unbound (void); static SCM scm_unbound_p (SCM obj); static SCM scm_class_p (SCM obj); @@ -166,6 +168,33 @@ static SCM scm_sys_goops_loaded (void); +SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0, + (SCM layout), + "") +#define FUNC_NAME s_scm_sys_make_root_class +{ + SCM z; + + z = scm_i_make_vtable_vtable (layout); + SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS)); + + return z; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0, + (SCM applicable, SCM setter), + "") +#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x +{ + SCM_VALIDATE_CLASS (1, applicable); + SCM_VALIDATE_CLASS (2, setter); + SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE); + SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + SCM scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots) { @@ -316,25 +345,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, } #undef FUNC_NAME -/******************************************************************************/ -/******************************************************************************/ - -SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0, - (SCM layout), - "") -#define FUNC_NAME s_scm_sys_make_root_class -{ - SCM z; - - z = scm_i_make_vtable_vtable (layout); - SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS)); - - return z; -} -#undef FUNC_NAME - -/******************************************************************************/ + SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, (SCM obj), @@ -366,11 +378,8 @@ scm_is_method (SCM x) return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method); } -/****************************************************************************** - * - * Meta object accessors - * - ******************************************************************************/ + + SCM scm_class_name (SCM obj) @@ -414,6 +423,9 @@ scm_class_slots (SCM obj) return scm_call_1 (scm_variable_ref (var_class_slots), obj); } + + + SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0, (SCM obj), "Return the name of the generic function @var{obj}.") @@ -448,11 +460,8 @@ scm_method_procedure (SCM obj) return scm_call_1 (scm_variable_ref (var_method_procedure), obj); } -/****************************************************************************** - * - * S l o t a c c e s s - * - ******************************************************************************/ + + SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0, (), @@ -527,6 +536,9 @@ scm_slot_exists_p (SCM obj, SCM slot_name) return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name); } + + + SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 1, 0, 0, (SCM obj), "") @@ -550,15 +562,12 @@ SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 1, 0, 0, } #undef FUNC_NAME -/****************************************************************************** - * - * %modify-instance (used by change-class to modify in place) - * - ******************************************************************************/ + + SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, (SCM old, SCM new), - "") + "Used by change-class to modify objects in place.") #define FUNC_NAME s_scm_sys_modify_instance { SCM_VALIDATE_INSTANCE (1, old); @@ -687,21 +696,11 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class) } } -/****************************************************************************** - * - * GGGG FFFFF - * G F - * G GG FFF - * G G F - * GGG E N E R I C F U N C T I O N S - * - * This implementation provides - * - generic functions (with class specializers) - * - multi-methods - * - next-method - * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf - * - ******************************************************************************/ + + + +/* Primitive generics: primitives that can dispatch to generics if their + arguments fail to apply. */ SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0, (SCM proc), @@ -761,11 +760,6 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, } #undef FUNC_NAME -/* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is - * assumed that 'gf' is zero if uninitialized. It would be cleaner if - * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen. - */ - SCM scm_wta_dispatch_0 (SCM gf, const char *subr) { @@ -802,22 +796,8 @@ scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr) return scm_apply_0 (gf, args); } -/****************************************************************************** - * - * Protocol for calling a generic fumction - * This protocol is roughly equivalent to (parameter are a little bit different - * for efficiency reasons): - * - * + apply-generic (gf args) - * + compute-applicable-methods (gf args ...) - * + sort-applicable-methods (methods args) - * + apply-methods (gf methods args) - * - * apply-methods calls make-next-method to build the "continuation" of a a - * method. Applying a next-method will call apply-next-method which in - * turn will call apply again to call effectively the following method. - * - ******************************************************************************/ + + SCM_DEFINE (scm_make, "make", 0, 0, 1, (SCM args), @@ -830,11 +810,9 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, #undef FUNC_NAME -/********************************************************************** - * - * Smob classes - * - **********************************************************************/ + + +/* SMOB, struct, and port classes. */ static SCM make_class_name (const char *prefix, const char *type_name, const char *suffix) @@ -998,11 +976,8 @@ create_struct_classes (void) vtable_class_map); } -/********************************************************************** - * - * C interface - * - **********************************************************************/ + + void scm_load_goops () @@ -1032,22 +1007,8 @@ scm_ensure_accessor (SCM name) return gf; } -/* - * Initialization - */ -SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0, - (SCM applicable, SCM setter), - "") -#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x -{ - SCM_VALIDATE_CLASS (1, applicable); - SCM_VALIDATE_CLASS (2, setter); - SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE); - SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME + SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, (), @@ -1177,8 +1138,6 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, } #undef FUNC_NAME -SCM scm_module_goops; - static void scm_init_goops_builtins (void *unused) { diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 67e7bf806..ba3eaded8 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -2583,15 +2583,30 @@ var{initargs}." ;;; ;;; {apply-generic} ;;; -;;; Protocol for calling standard generic functions. This protocol is -;;; not used for real functions (in this case we use a -;;; completely C hard-coded protocol). Apply-generic is used by -;;; goops for calls to subclasses of and . -;;; The code below is similar to the first MOP described in AMOP. In -;;; particular, it doesn't used the currified approach to gf -;;; call. There are 2 reasons for that: -;;; - the protocol below is exposed to mimic completely the one written in C -;;; - the currified protocol would be imho inefficient in C. +;;; Protocol for calling generic functions, intended to be used when +;;; applying subclasses of and . The +;;; code below is similar to the first MOP described in AMOP. +;;; +;;; Note that standard generic functions dispatch only on the classes of +;;; the arguments, and the result of such dispatch can be memoized. The +;;; `cache-dispatch' routine implements this. `apply-generic' isn't +;;; called currently; the generic function MOP was never fully +;;; implemented in GOOPS. However now that GOOPS is implemented +;;; entirely in Scheme (2015) it's much easier to complete this work. +;;; Contributions gladly accepted! Please read the AMOP first though :) +;;; +;;; The protocol is: +;;; +;;; + apply-generic (gf args) +;;; + compute-applicable-methods (gf args ...) +;;; + sort-applicable-methods (gf methods args) +;;; + apply-methods (gf methods args) +;;; +;;; apply-methods calls make-next-method to build the "continuation" of +;;; a method. Applying a next-method will call apply-next-method which +;;; in turn will call apply again to call effectively the following +;;; method. (This paragraph is out of date but is kept so that maybe it +;;; illuminates some future hack.) ;;; (define-method (apply-generic (gf ) args)